]> git.zerfleddert.de Git - micropolis/blame - src/tk/tksend.c
src/sim/makefile: Micropolis build fixes for recent macOS
[micropolis] / src / tk / tksend.c
CommitLineData
6a5fa4e0
MG
1/*
2 * tkSend.c --
3 *
4 * This file provides procedures that implement the "send"
5 * command, allowing commands to be passed from interpreter
6 * to interpreter.
7 *
8 * Copyright 1989-1992 Regents of the University of California
9 * Permission to use, copy, modify, and distribute this
10 * software and its documentation for any purpose and without
11 * fee is hereby granted, provided that the above copyright
12 * notice appear in all copies. The University of California
13 * makes no representations about the suitability of this
14 * software for any purpose. It is provided "as is" without
15 * express or implied warranty.
16 */
17
18#ifndef lint
19static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkSend.c,v 1.26 92/08/13 10:29:26 ouster Exp $ SPRITE (Berkeley)";
20#endif
21
22#include "tkconfig.h"
23#include "tkint.h"
24
25/*
26 * The following structure is used to keep track of the
27 * interpreters registered by this process.
28 */
29
30typedef struct RegisteredInterp {
31 char *name; /* Interpreter's name (malloc-ed). */
32 Tcl_Interp *interp; /* Interpreter associated with
33 * name. */
34 TkDisplay *dispPtr; /* Display associated with name. */
35 TkWindow *winPtr; /* Window associated with name. */
36 struct RegisteredInterp *nextPtr;
37 /* Next in list of names associated
38 * with interps in this process.
39 * NULL means end of list. */
40} RegisteredInterp;
41
42static RegisteredInterp *registry = NULL;
43 /* List of all interpreters
44 * registered by this process. */
45
46/*
47 * When a result is being awaited from a sent command, one of
48 * the following structures is present on a list of all outstanding
49 * sent commands. The information in the structure is used to
50 * process the result when it arrives. You're probably wondering
51 * how there could ever be multiple outstanding sent commands.
52 * This could happen if interpreters invoke each other recursively.
53 * It's unlikely, but possible.
54 */
55
56typedef struct PendingCommand {
57 int serial; /* Serial number expected in
58 * result. */
59 char *target; /* Name of interpreter command is
60 * being sent to. */
61 Tcl_Interp *interp; /* Interpreter from which the send
62 * was invoked. */
63 int code; /* Tcl return code for command
64 * will be stored here. */
65 char *result; /* String result for command (malloc'ed).
66 * NULL means command still pending. */
67 struct PendingCommand *nextPtr;
68 /* Next in list of all outstanding
69 * commands. NULL means end of
70 * list. */
71} PendingCommand;
72
73static PendingCommand *pendingCommands = NULL;
74 /* List of all commands currently
75 * being waited for. */
76
77/*
78 * The information below is used for communication between
79 * processes during "send" commands. Each process keeps a
80 * private window, never even mapped, with one property,
81 * "Comm". When a command is sent to an interpreter, the
82 * command is appended to the comm property of the communication
83 * window associated with the interp's process. Similarly, when a
84 * result is returned from a sent command, it is also appended
85 * to the comm property. In each case, the property information
86 * is in the form of an ASCII string. The exact syntaxes are:
87 *
88 * Command:
89 * 'C' space window space serial space interpName '|' command '\0'
90 * The 'C' character indicates that this is a command and not
91 * a response. Window is the hex identifier for the comm
92 * window on which to append the response. Serial is a hex
93 * integer containing an identifying number assigned by the
94 * sender; it may be used by the sender to sort out concurrent
95 * responses. InterpName is the ASCII name of the desired
96 * interpreter, which must not contain any vertical bar characters
97 * The interpreter name is delimited by a vertical bar (this
98 * allows the name to include blanks), and is followed by
99 * the command to execute. The command is terminated by a
100 * NULL character.
101 *
102 * Response:
103 * 'R' space serial space code space result '\0'
104 * The 'R' character indicates that this is a response. Serial
105 * gives the identifier for the command (same value as in the
106 * command message). The code field is a decimal integer giving
107 * the Tcl return code from the command, and result is the string
108 * result. The result is terminated by a NULL character.
109 *
110 * The register of interpreters is kept in a property
111 * "InterpRegistry" on the root window of the display. It is
112 * organized as a series of zero or more concatenated strings
113 * (in no particular order), each of the form
114 * window space name '\0'
115 * where "window" is the hex id of the comm. window to use to talk
116 * to an interpreter named "name".
117 */
118
119/*
120 * Maximum size property that can be read at one time by
121 * this module:
122 */
123
124#define MAX_PROP_WORDS 100000
125
126/*
127 * Forward declarations for procedures defined later in this file:
128 */
129
130static int AppendErrorProc _ANSI_ARGS_((ClientData clientData,
131 XErrorEvent *errorPtr));
132static void AppendPropCarefully _ANSI_ARGS_((Display *display,
133 Window window, Atom property, char *value,
134 PendingCommand *pendingPtr));
135static void DeleteProc _ANSI_ARGS_((ClientData clientData));
136static Window LookupName _ANSI_ARGS_((TkDisplay *dispPtr, char *name,
137 int delete));
138static void SendEventProc _ANSI_ARGS_((ClientData clientData,
139 XEvent *eventPtr));
140static int SendInit _ANSI_ARGS_((Tcl_Interp *interp, TkDisplay *dispPtr));
141static Bool SendRestrictProc _ANSI_ARGS_((Display *display,
142 XEvent *eventPtr, char *arg));
143static void TimeoutProc _ANSI_ARGS_((ClientData clientData));
144\f
145/*
146 *--------------------------------------------------------------
147 *
148 * Tk_RegisterInterp --
149 *
150 * This procedure is called to associate an ASCII name
151 * with an interpreter. Tk_InitSend must previously
152 * have been called to set up communication channels
153 * and specify a display.
154 *
155 * Results:
156 * Zero is returned if the name was registered successfully.
157 * Non-zero means the name was already in use.
158 *
159 * Side effects:
160 * Registration info is saved, thereby allowing the
161 * "send" command to be used later to invoke commands
162 * in the interpreter. The registration will be removed
163 * automatically when the interpreter is deleted.
164 *
165 *--------------------------------------------------------------
166 */
167
168int
169Tk_RegisterInterp(interp, name, tkwin)
170 Tcl_Interp *interp; /* Interpreter associated with name. */
171 char *name; /* The name that will be used to
172 * refer to the interpreter in later
173 * "send" commands. Must be globally
174 * unique. */
175 Tk_Window tkwin; /* Token for window associated with
176 * interp; used to identify display
177 * for communication. */
178{
179#define TCL_MAX_NAME_LENGTH 1000
180 char propInfo[TCL_MAX_NAME_LENGTH + 20];
181 register RegisteredInterp *riPtr;
182 Window w;
183 TkWindow *winPtr = (TkWindow *) tkwin;
184 TkDisplay *dispPtr;
185
186 if (strchr(name, '|') != NULL) {
187 interp->result =
188 "interpreter name cannot contain '|' character";
189 return TCL_ERROR;
190 }
191
192 dispPtr = winPtr->dispPtr;
193 if (dispPtr->commWindow == NULL) {
194 int result;
195
196 result = SendInit(interp, dispPtr);
197 if (result != TCL_OK) {
198 return result;
199 }
200 }
201
202 /*
203 * Make sure the name is unique, and append info about it to
204 * the registry property. Eventually, it would probably be
205 * a good idea to lock the server here to prevent conflicting
206 * changes to the registry property. But that would make
207 * testing more difficult, and probably isn't necessary
208 * anyway because new windows don't get created all that often.
209 */
210
211 w = LookupName(dispPtr, name, 0);
212 if (w != (Window) 0) {
213 Tcl_Interp *tmpInterp;
214 RegisteredInterp tmpRi;
215 int result;
216 char *argv[3];
217
218 /*
219 * Name already exists. Ping the interpreter with a
220 * NULL command to see if it already exists. If not,
221 * unregister the old name (this could happen if an
222 * application dies without cleaning up the registry).
223 */
224
225 tmpInterp = Tcl_CreateInterp();
226 argv[0] = "send";
227 argv[1] = name;
228 argv[2] = "";
229 tmpRi.dispPtr = dispPtr;
230 tmpRi.winPtr = winPtr;
231 result = Tk_SendCmd((ClientData) &tmpRi, tmpInterp, 3, argv);
232 Tcl_DeleteInterp(tmpInterp);
233 if (result == TCL_OK) {
234 Tcl_AppendResult(interp, "interpreter name \"", name,
235 "\" is already in use", (char *) NULL);
236 return TCL_ERROR;
237 }
238 (void) LookupName(winPtr->dispPtr, name, 1);
239 }
240 sprintf(propInfo, "%x %.*s", Tk_WindowId(dispPtr->commWindow),
241 TCL_MAX_NAME_LENGTH, name);
242 XChangeProperty(dispPtr->display,
243 Tk_DefaultRootWindow(dispPtr->display),
244 dispPtr->registryProperty, XA_STRING, 8, PropModeAppend,
245 (unsigned char *) propInfo, strlen(propInfo)+1);
246
247 /*
248 * Add an entry in the local registry of names owned by this
249 * process.
250 */
251
252 riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
253 riPtr->name = (char *) ckalloc((unsigned) (strlen(name) + 1));
254 strcpy(riPtr->name, name);
255 riPtr->interp = interp;
256 riPtr->dispPtr = dispPtr;
257 riPtr->winPtr = winPtr;
258 riPtr->nextPtr = registry;
259 registry = riPtr;
260
261 /*
262 * Add the "send" command to this interpreter, and arrange for
263 * us to be notified when the interpreter is deleted (actually,
264 * when the "send" command is deleted).
265 */
266
267 Tcl_CreateCommand(interp, "send", Tk_SendCmd, (ClientData) riPtr,
268 DeleteProc);
269
270 return TCL_OK;
271}
272\f
273/*
274 *--------------------------------------------------------------
275 *
276 * Tk_SendCmd --
277 *
278 * This procedure is invoked to process the "send" Tcl command.
279 * See the user documentation for details on what it does.
280 *
281 * Results:
282 * A standard Tcl result.
283 *
284 * Side effects:
285 * See the user documentation.
286 *
287 *--------------------------------------------------------------
288 */
289
290int
291Tk_SendCmd(clientData, interp, argc, argv)
292 ClientData clientData; /* Information about sender (only
293 * dispPtr field is used). */
294 Tcl_Interp *interp; /* Current interpreter. */
295 int argc; /* Number of arguments. */
296 char **argv; /* Argument strings. */
297{
298 RegisteredInterp *senderRiPtr = (RegisteredInterp *) clientData;
299 Window w;
300#define STATIC_PROP_SPACE 100
301 char *property, staticSpace[STATIC_PROP_SPACE];
302 int length;
303 int quick = 0;
304 static int serial = 0; /* Running count of sent commands.
305 * Used to give each command a
306 * different serial number. */
307 PendingCommand pending;
308 Tk_TimerToken timeout;
309 register RegisteredInterp *riPtr;
310 char *cmd;
311 int result;
312 Bool (*prevRestrictProc)();
313 char *prevArg;
314 TkWindow *winPtr = senderRiPtr->winPtr;
315 TkDisplay *dispPtr = senderRiPtr->dispPtr;
316 int to_server = 0;
317
318 if (argc >= 2) {
319 Tk_Window tkwin = NULL;
320
321 if ((argv[1][0] == '-') &&
322 (strncmp(argv[1], "-quick", strlen(argv[1])) == 0)) {
323 quick = 1;
324 argv += 1; argc -= 1;
325 }
326 }
327
328 if (argc >= 3) {
329 Tk_Window tkwin = NULL;
330
331 if ((argv[1][0] == '-') &&
332 (strncmp(argv[1], "-server", strlen(argv[1])) == 0)) {
333 to_server = 1;
334 tkwin = Tk_NameToWindow(interp, argv[2], (Tk_Window) winPtr);
335 if (tkwin == NULL) {
336 Tcl_AppendResult(interp, "bad server arg, should be window name: ",
337 argv[2], (char *) NULL);
338 return TCL_ERROR;
339 }
340 winPtr = (TkWindow *) tkwin;
341 dispPtr = winPtr->dispPtr;
342 argv += 2; argc -= 2;
343 }
344 }
345
346 if (dispPtr->commWindow == NULL) {
347 result = SendInit(interp, dispPtr);
348 if (result != TCL_OK) {
349 return result;
350 }
351 }
352
353 if (argc < 3) {
354 badargs:
355 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
356 " interpName arg ?arg ...?\"", (char *) NULL);
357 return TCL_ERROR;
358 }
359
360 if (argc == 3) {
361 cmd = argv[2];
362 } else {
363 cmd = Tcl_Concat(argc-2, argv+2);
364 }
365
366 /*
367 * See if the target interpreter is local. If so, execute
368 * the command directly without going through the X server.
369 * The only tricky thing is passing the result from the target
370 * interpreter to the invoking interpreter. Watch out: they
371 * could be the same!
372 */
373
374 for (riPtr = registry; riPtr != NULL; riPtr = riPtr->nextPtr) {
375 if (strcmp(riPtr->name, argv[1]) != 0) {
376 continue;
377 }
378 if (interp == riPtr->interp) {
379 result = Tcl_GlobalEval(interp, cmd);
380 } else {
381 result = Tcl_GlobalEval(riPtr->interp, cmd);
382 interp->result = riPtr->interp->result;
383 interp->freeProc = riPtr->interp->freeProc;
384 riPtr->interp->freeProc = 0;
385 Tcl_ResetResult(riPtr->interp);
386 }
387 if (cmd != argv[2]) {
388 ckfree(cmd);
389 }
390 return result;
391 }
392
393 /*
394 * Bind the interpreter name to a communication window.
395 */
396
397 w = LookupName(dispPtr, argv[1], 0);
398 if (w == 0) {
399 Tcl_AppendResult(interp, "no registered interpeter named \"",
400 argv[1], "\"", (char *) NULL);
401 if (cmd != argv[2]) {
402 ckfree(cmd);
403 }
404 return TCL_ERROR;
405 }
406
407 if (!quick) {
408 /*
409 * Register the fact that we're waiting for a command to
410 * complete (this is needed by SendEventProc and by
411 * AppendErrorProc to pass back the command's results).
412 */
413
414 serial++;
415 pending.serial = serial;
416 pending.target = argv[1];
417 pending.interp = interp;
418 pending.result = NULL;
419 pending.nextPtr = pendingCommands;
420 pendingCommands = &pending;
421 }
422
423 /*
424 * Send the command to target interpreter by appending it to the
425 * comm window in the communication window.
426 */
427
428 length = strlen(argv[1]) + strlen(cmd) + 30;
429 if (length <= STATIC_PROP_SPACE) {
430 property = staticSpace;
431 } else {
432 property = (char *) ckalloc((unsigned) length);
433 }
434 sprintf(property, "C %x %x %s|%s",
435 Tk_WindowId(dispPtr->commWindow), serial, argv[1], cmd);
436 (void) AppendPropCarefully(dispPtr->display, w, dispPtr->commProperty,
437 property, &pending);
438 if (length > STATIC_PROP_SPACE) {
439 ckfree(property);
440 }
441 if (cmd != argv[2]) {
442 ckfree(cmd);
443 }
444
445 if (quick) {
446 sprintf(interp->result, "NoReturnValue");
447 return TCL_OK;
448 }
449
450 /*
451 * Enter a loop processing X events until the result comes
452 * in. If no response is received within a few seconds,
453 * then timeout. While waiting for a result, look only at
454 * send-related events (otherwise it would be possible for
455 * additional input events, such as mouse motion, to cause
456 * other sends, leading eventually to such a large number
457 * of nested Tcl_Eval calls that the Tcl interpreter panics).
458 */
459
460 prevRestrictProc = Tk_RestrictEvents(SendRestrictProc,
461 (char *) dispPtr->commWindow, &prevArg);
462 timeout = Tk_CreateTimerHandler(5000, TimeoutProc,
463 (ClientData) &pending);
464 while (pending.result == NULL) {
465 Tk_DoOneEvent(0);
466 }
467 Tk_DeleteTimerHandler(timeout);
468 (void) Tk_RestrictEvents(prevRestrictProc, prevArg, &prevArg);
469
470 /*
471 * Unregister the information about the pending command
472 * and return the result.
473 */
474
475 if (pendingCommands == &pending) {
476 pendingCommands = pending.nextPtr;
477 } else {
478 PendingCommand *pcPtr;
479
480 for (pcPtr = pendingCommands; pcPtr != NULL;
481 pcPtr = pcPtr->nextPtr) {
482 if (pcPtr->nextPtr == &pending) {
483 pcPtr->nextPtr = pending.nextPtr;
484 break;
485 }
486 }
487 }
488 Tcl_SetResult(interp, pending.result, TCL_DYNAMIC);
489 return pending.code;
490
491}
492\f
493/*
494 *----------------------------------------------------------------------
495 *
496 * TkGetInterpNames --
497 *
498 * This procedure is invoked to fetch a list of all the
499 * interpreter names currently registered for the display
500 * of a particular window.
501 *
502 * Results:
503 * A standard Tcl return value. Interp->result will be set
504 * to hold a list of all the interpreter names defined for
505 * tkwin's display. If an error occurs, then TCL_ERROR
506 * is returned and interp->result will hold an error message.
507 *
508 * Side effects:
509 * None.
510 *
511 *----------------------------------------------------------------------
512 */
513
514int
515TkGetInterpNames(interp, tkwin)
516 Tcl_Interp *interp; /* Interpreter for returning a result. */
517 Tk_Window tkwin; /* Window whose display is to be used
518 * for the lookup. */
519{
520 TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr;
521 char *regProp, *separator, *name;
522 register char *p;
523 int result, actualFormat;
524 unsigned long numItems, bytesAfter;
525 Atom actualType;
526
527 /*
528 * Read the registry property.
529 */
530
531 regProp = NULL;
532 result = XGetWindowProperty(dispPtr->display,
533 Tk_DefaultRootWindow(dispPtr->display),
534 dispPtr->registryProperty, 0, MAX_PROP_WORDS,
535 False, XA_STRING, &actualType, &actualFormat,
536 &numItems, &bytesAfter, (unsigned char **) &regProp);
537
538 if (actualType == None) {
539 sprintf(interp->result, "couldn't read intepreter registry property");
540 return TCL_ERROR;
541 }
542
543 /*
544 * If the property is improperly formed, then delete it.
545 */
546
547 if ((result != Success) || (actualFormat != 8)
548 || (actualType != XA_STRING)) {
549 if (regProp != NULL) {
550 XFree(regProp);
551 }
552 sprintf(interp->result, "intepreter registry property is badly formed");
553 return TCL_ERROR;
554 }
555
556 /*
557 * Scan all of the names out of the property.
558 */
559
560 separator = "";
561 for (p = regProp; (p-regProp) < numItems; p++) {
562 name = p;
563 while ((*p != 0) && (!isspace(*p))) {
564 p++;
565 }
566 if (*p != 0) {
567 name = p+1;
568 name = Tcl_Merge(1, &name);
569 Tcl_AppendResult(interp, separator, name, (char *) NULL);
570 while (*p != 0) {
571 p++;
572 }
573 separator = " ";
574 }
575 }
576 XFree(regProp);
577 return TCL_OK;
578}
579\f
580/*
581 *--------------------------------------------------------------
582 *
583 * SendInit --
584 *
585 * This procedure is called to initialize the
586 * communication channels for sending commands and
587 * receiving results.
588 *
589 * Results:
590 * The result is a standard Tcl return value, which is
591 * normally TCL_OK. If an error occurs then an error
592 * message is left in interp->result and TCL_ERROR is
593 * returned.
594 *
595 * Side effects:
596 * Sets up various data structures and windows.
597 *
598 *--------------------------------------------------------------
599 */
600
601static int
602SendInit(interp, dispPtr)
603 Tcl_Interp *interp; /* Interpreter to use for error
604 * reporting. */
605 register TkDisplay *dispPtr;/* Display to initialize. */
606
607{
608 XSetWindowAttributes atts;
609
610 /*
611 * Create the window used for communication, and set up an
612 * event handler for it.
613 */
614
615 dispPtr->commWindow = Tk_CreateWindow(interp, (Tk_Window) NULL,
616 "_comm", DisplayString(dispPtr->display));
617 if (dispPtr->commWindow == NULL) {
618 return TCL_ERROR;
619 }
620 atts.override_redirect = True;
621 Tk_ChangeWindowAttributes(dispPtr->commWindow,
622 CWOverrideRedirect, &atts);
623 Tk_CreateEventHandler(dispPtr->commWindow, PropertyChangeMask,
624 SendEventProc, (ClientData) dispPtr);
625 Tk_MakeWindowExist(dispPtr->commWindow);
626
627 /*
628 * Get atoms used as property names.
629 */
630
631 dispPtr->commProperty = XInternAtom(dispPtr->display,
632 "Comm", False);
633 dispPtr->registryProperty = XInternAtom(dispPtr->display,
634 "InterpRegistry", False);
635 return TCL_OK;
636}
637\f
638/*
639 *--------------------------------------------------------------
640 *
641 * LookupName --
642 *
643 * Given an interpreter name, see if the name exists in
644 * the interpreter registry for a particular display.
645 *
646 * Results:
647 * If the given name is registered, return the ID of
648 * the window associated with the name. If the name
649 * isn't registered, then return 0.
650 *
651 * Side effects:
652 * If the registry property is improperly formed, then
653 * it is deleted. If "delete" is non-zero, then if the
654 * named interpreter is found it is removed from the
655 * registry property.
656 *
657 *--------------------------------------------------------------
658 */
659
660static Window
661LookupName(dispPtr, name, delete)
662 register TkDisplay *dispPtr;
663 /* Display whose registry to check. */
664 char *name; /* Name of an interpreter. */
665 int delete; /* If non-zero, delete info about name. */
666{
667 char *regProp, *entry;
668 register char *p;
669 int result, actualFormat;
670 unsigned long numItems, bytesAfter;
671 Atom actualType;
672 Window returnValue;
673
674 /*
675 * Read the registry property.
676 */
677
678 regProp = NULL;
679 result = XGetWindowProperty(dispPtr->display,
680 Tk_DefaultRootWindow(dispPtr->display),
681 dispPtr->registryProperty, 0, MAX_PROP_WORDS,
682 False, XA_STRING, &actualType, &actualFormat,
683 &numItems, &bytesAfter, (unsigned char **) &regProp);
684
685 if (actualType == None) {
686 return 0;
687 }
688
689 /*
690 * If the property is improperly formed, then delete it.
691 */
692
693 if ((result != Success) || (actualFormat != 8)
694 || (actualType != XA_STRING)) {
695 if (regProp != NULL) {
696 XFree(regProp);
697 }
698 XDeleteProperty(dispPtr->display,
699 Tk_DefaultRootWindow(dispPtr->display),
700 dispPtr->registryProperty);
701 return 0;
702 }
703
704 /*
705 * Scan the property for the desired name.
706 */
707
708 returnValue = (Window) 0;
709 entry = NULL; /* Not needed, but eliminates compiler warning. */
710 for (p = regProp; (p-regProp) < numItems; ) {
711 entry = p;
712 while ((*p != 0) && (!isspace(*p))) {
713 p++;
714 }
715 if ((*p != 0) && (strcmp(name, p+1) == 0)) {
716 sscanf(entry, "%x", &returnValue);
717 break;
718 }
719 while (*p != 0) {
720 p++;
721 }
722 p++;
723 }
724
725 /*
726 * Delete the property, if that is desired (copy down the
727 * remainder of the registry property to overlay the deleted
728 * info, then rewrite the property).
729 */
730
731 if ((delete) && (returnValue != 0)) {
732 int count;
733
734 while (*p != 0) {
735 p++;
736 }
737 p++;
738 count = numItems - (p-regProp);
739 if (count > 0) {
740 memcpy((VOID *) entry, (VOID *) p, count);
741 }
742 XChangeProperty(dispPtr->display,
743 Tk_DefaultRootWindow(dispPtr->display),
744 dispPtr->registryProperty, XA_STRING, 8,
745 PropModeReplace, (unsigned char *) regProp,
746 (int) (numItems - (p-entry)));
747 XSync(dispPtr->display, False);
748 }
749
750 XFree(regProp);
751 return returnValue;
752}
753\f
754/*
755 *--------------------------------------------------------------
756 *
757 * SendEventProc --
758 *
759 * This procedure is invoked automatically by the toolkit
760 * event manager when a property changes on the communication
761 * window. This procedure reads the property and handles
762 * command requests and responses.
763 *
764 * Results:
765 * None.
766 *
767 * Side effects:
768 * If there are command requests in the property, they
769 * are executed. If there are responses in the property,
770 * their information is saved for the (ostensibly waiting)
771 * "send" commands. The property is deleted.
772 *
773 *--------------------------------------------------------------
774 */
775
776static void
777SendEventProc(clientData, eventPtr)
778 ClientData clientData; /* Display information. */
779 XEvent *eventPtr; /* Information about event. */
780{
781 TkDisplay *dispPtr = (TkDisplay *) clientData;
782 char *propInfo;
783 register char *p;
784 int result, actualFormat;
785 unsigned long numItems, bytesAfter;
786 Atom actualType;
787
788 if ((eventPtr->xproperty.atom != dispPtr->commProperty)
789 || (eventPtr->xproperty.state != PropertyNewValue)) {
790 return;
791 }
792
793 /*
794 * Read the comm property and delete it.
795 */
796
797 propInfo = NULL;
798 result = XGetWindowProperty(dispPtr->display,
799 Tk_WindowId(dispPtr->commWindow),
800 dispPtr->commProperty, 0, MAX_PROP_WORDS, True,
801 XA_STRING, &actualType, &actualFormat,
802 &numItems, &bytesAfter, (unsigned char **) &propInfo);
803
804 /*
805 * If the property doesn't exist or is improperly formed
806 * then ignore it.
807 */
808
809 if ((result != Success) || (actualType != XA_STRING)
810 || (actualFormat != 8)) {
811 if (propInfo != NULL) {
812 XFree(propInfo);
813 }
814 return;
815 }
816
817 /*
818 * The property is divided into records separated by null
819 * characters. Each record represents one command request
820 * or response. Scan through the property one record at a
821 * time.
822 */
823
824 for (p = propInfo; (p-propInfo) < numItems; ) {
825 if (*p == 'C') {
826 Window window;
827 int serial, resultSize;
828 char *resultString, *interpName, *returnProp, *end;
829 register RegisteredInterp *riPtr;
830 char errorMsg[100];
831#define STATIC_RESULT_SPACE 100
832 char staticSpace[STATIC_RESULT_SPACE];
833
834 /*
835 *-----------------------------------------------------
836 * This is an incoming command sent by another window.
837 * Parse the fields of the command string. If the command
838 * string isn't properly formed, send back an error message
839 * if there's enough well-formed information to generate
840 * a proper reply; otherwise just ignore the message.
841 *-----------------------------------------------------
842 */
843
844 p++;
845 window = (Window) strtol(p, &end, 16);
846 if (end == p) {
847 goto nextRecord;
848 }
849 p = end;
850 if (*p != ' ') {
851 goto nextRecord;
852 }
853 p++;
854 serial = strtol(p, &end, 16);
855 if (end == p) {
856 goto nextRecord;
857 }
858 p = end;
859 if (*p != ' ') {
860 goto nextRecord;
861 }
862 p++;
863 interpName = p;
864 while ((*p != 0) && (*p != '|')) {
865 p++;
866 }
867 if (*p != '|') {
868 result = TCL_ERROR;
869 resultString = "bad property format for sent command";
870 goto returnResult;
871 }
872 *p = 0;
873 p++;
874
875 /*
876 * Locate the interpreter for the command, then
877 * execute the command.
878 */
879
880 for (riPtr = registry; ; riPtr = riPtr->nextPtr) {
881 if (riPtr == NULL) {
882 result = TCL_ERROR;
883 sprintf(errorMsg,
884 "receiver never heard of interpreter \"%.40s\"",
885 interpName);
886 resultString = errorMsg;
887 goto returnResult;
888 }
889 if (strcmp(riPtr->name, interpName) == 0) {
890 break;
891 }
892 }
893 result = Tcl_GlobalEval(riPtr->interp, p);
894 resultString = riPtr->interp->result;
895
896 /*
897 * Return the result to the sender.
898 */
899
900 returnResult:
901 resultSize = strlen(resultString) + 30;
902 if (resultSize <= STATIC_RESULT_SPACE) {
903 returnProp = staticSpace;
904 } else {
905 returnProp = (char *) ckalloc((unsigned) resultSize);
906 }
907 sprintf(returnProp, "R %x %d %s", serial, result,
908 resultString);
909 (void) AppendPropCarefully(dispPtr->display, window,
910 dispPtr->commProperty, returnProp,
911 (PendingCommand *) NULL);
912 if (returnProp != staticSpace) {
913 ckfree(returnProp);
914 }
915 } else if (*p == 'R') {
916 int serial, code;
917 char *end;
918 register PendingCommand *pcPtr;
919
920 /*
921 *-----------------------------------------------------
922 * This record in the property is a result being
923 * returned for a command sent from here. First
924 * parse the fields.
925 *-----------------------------------------------------
926 */
927
928 p++;
929 serial = strtol(p, &end, 16);
930 if (end == p) {
931 goto nextRecord;
932 }
933 p = end;
934 if (*p != ' ') {
935 goto nextRecord;
936 }
937 p++;
938 code = strtol(p, &end, 10);
939 if (end == p) {
940 goto nextRecord;
941 }
942 p = end;
943 if (*p != ' ') {
944 goto nextRecord;
945 }
946 p++;
947
948 /*
949 * Give the result information to anyone who's
950 * waiting for it.
951 */
952
953 for (pcPtr = pendingCommands; pcPtr != NULL;
954 pcPtr = pcPtr->nextPtr) {
955 if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) {
956 continue;
957 }
958 pcPtr->code = code;
959 pcPtr->result = ckalloc((unsigned) (strlen(p) + 1));
960 strcpy(pcPtr->result, p);
961 break;
962 }
963 }
964
965 nextRecord:
966 while (*p != 0) {
967 p++;
968 }
969 p++;
970 }
971 XFree(propInfo);
972}
973\f
974/*
975 *--------------------------------------------------------------
976 *
977 * AppendPropCarefully --
978 *
979 * Append a given property to a given window, but set up
980 * an X error handler so that if the append fails this
981 * procedure can return an error code rather than having
982 * Xlib panic.
983 *
984 * Results:
985 * None.
986 *
987 * Side effects:
988 * The given property on the given window is appended to.
989 * If this operation fails and if pendingPtr is non-NULL,
990 * then the pending operation is marked as complete with
991 * an error.
992 *
993 *--------------------------------------------------------------
994 */
995
996static void
997AppendPropCarefully(display, window, property, value, pendingPtr)
998 Display *display; /* Display on which to operate. */
999 Window window; /* Window whose property is to
1000 * be modified. */
1001 Atom property; /* Name of property. */
1002 char *value; /* Characters (null-terminated) to
1003 * append to property. */
1004 PendingCommand *pendingPtr; /* Pending command to mark complete
1005 * if an error occurs during the
1006 * property op. NULL means just
1007 * ignore the error. */
1008{
1009 Tk_ErrorHandler handler;
1010
1011 handler = Tk_CreateErrorHandler(display, -1, -1, -1, AppendErrorProc,
1012 (ClientData) pendingPtr);
1013 XChangeProperty(display, window, property, XA_STRING, 8,
1014 PropModeAppend, (unsigned char *) value, strlen(value)+1);
1015 Tk_DeleteErrorHandler(handler);
1016}
1017
1018/*
1019 * The procedure below is invoked if an error occurs during
1020 * the XChangeProperty operation above.
1021 */
1022
1023 /* ARGSUSED */
1024static int
1025AppendErrorProc(clientData, errorPtr)
1026 ClientData clientData; /* Command to mark complete, or NULL. */
1027 XErrorEvent *errorPtr; /* Information about error. */
1028{
1029 PendingCommand *pendingPtr = (PendingCommand *) clientData;
1030 register PendingCommand *pcPtr;
1031
1032 if (pendingPtr == NULL) {
1033 return 0;
1034 }
1035
1036 /*
1037 * Make sure this command is still pending.
1038 */
1039
1040 for (pcPtr = pendingCommands; pcPtr != NULL;
1041 pcPtr = pcPtr->nextPtr) {
1042 if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) {
1043 pcPtr->result = ckalloc((unsigned) (strlen(pcPtr->target) + 50));
1044 sprintf(pcPtr->result,
1045 "send to \"%s\" failed (no communication window)",
1046 pcPtr->target);
1047 pcPtr->code = TCL_ERROR;
1048 break;
1049 }
1050 }
1051 return 0;
1052}
1053\f
1054/*
1055 *--------------------------------------------------------------
1056 *
1057 * TimeoutProc --
1058 *
1059 * This procedure is invoked when too much time has elapsed
1060 * during the processing of a sent command.
1061 *
1062 * Results:
1063 * None.
1064 *
1065 * Side effects:
1066 * Mark the pending command as complete, with an error
1067 * message signalling the timeout.
1068 *
1069 *--------------------------------------------------------------
1070 */
1071
1072static void
1073TimeoutProc(clientData)
1074 ClientData clientData; /* Information about command that
1075 * has been sent but not yet
1076 * responded to. */
1077{
1078 PendingCommand *pcPtr = (PendingCommand *) clientData;
1079 register PendingCommand *pcPtr2;
1080
1081 /*
1082 * Make sure that the command is still in the pending list
1083 * and that it hasn't already completed. Then register the
1084 * error.
1085 */
1086
1087 for (pcPtr2 = pendingCommands; pcPtr2 != NULL;
1088 pcPtr2 = pcPtr2->nextPtr) {
1089 static char msg[] = "remote interpreter did not respond";
1090 if ((pcPtr2 != pcPtr) || (pcPtr2->result != NULL)) {
1091 continue;
1092 }
1093 pcPtr2->code = TCL_ERROR;
1094 pcPtr2->result = ckalloc((unsigned) (sizeof(msg) + 1));
1095 strcpy(pcPtr2->result, msg);
1096 return;
1097 }
1098}
1099\f
1100/*
1101 *--------------------------------------------------------------
1102 *
1103 * DeleteProc --
1104 *
1105 * This procedure is invoked by Tcl when a registered
1106 * interpreter is about to be deleted. It unregisters
1107 * the interpreter.
1108 *
1109 * Results:
1110 * None.
1111 *
1112 * Side effects:
1113 * The interpreter given by riPtr is unregistered.
1114 *
1115 *--------------------------------------------------------------
1116 */
1117
1118static void
1119DeleteProc(clientData)
1120 ClientData clientData; /* Info about registration, passed
1121 * as ClientData. */
1122{
1123 RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
1124 register RegisteredInterp *riPtr2;
1125
1126 (void) LookupName(riPtr->dispPtr, riPtr->name, 1);
1127 if (registry == riPtr) {
1128 registry = riPtr->nextPtr;
1129 } else {
1130 for (riPtr2 = registry; riPtr2 != NULL;
1131 riPtr2 = riPtr2->nextPtr) {
1132 if (riPtr2->nextPtr == riPtr) {
1133 riPtr2->nextPtr = riPtr->nextPtr;
1134 break;
1135 }
1136 }
1137 }
1138 ckfree((char *) riPtr->name);
1139 ckfree((char *) riPtr);
1140}
1141\f
1142/*
1143 *----------------------------------------------------------------------
1144 *
1145 * SendRestrictProc --
1146 *
1147 * This procedure filters incoming events when a "send" command
1148 * is outstanding. It defers all events except those containing
1149 * send commands and results.
1150 *
1151 * Results:
1152 * False is returned except for property-change events on the
1153 * given commWindow.
1154 *
1155 * Side effects:
1156 * None.
1157 *
1158 *----------------------------------------------------------------------
1159 */
1160
1161 /* ARGSUSED */
1162static Bool
1163SendRestrictProc(display, eventPtr, arg)
1164 Display *display; /* Display from which event arrived. */
1165 register XEvent *eventPtr; /* Event that just arrived. */
1166 char *arg; /* Comunication window in which
1167 * we're interested. */
1168{
1169 register Tk_Window comm = (Tk_Window) arg;
1170
1171 if ((display != Tk_Display(comm))
1172 || (eventPtr->type != PropertyNotify)
1173 || (eventPtr->xproperty.window != Tk_WindowId(comm))) {
1174 return False;
1175 }
1176 return True;
1177}
Impressum, Datenschutz