![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tksend.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / src / tk|
Return to tksend.c CVS log | Up to [Micropolis - Activity] / micropolis / src / tk |
1.1 root 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
19: static 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:
30: typedef 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:
42: static 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:
56: typedef 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:
73: static 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:
130: static int AppendErrorProc _ANSI_ARGS_((ClientData clientData,
131: XErrorEvent *errorPtr));
132: static void AppendPropCarefully _ANSI_ARGS_((Display *display,
133: Window window, Atom property, char *value,
134: PendingCommand *pendingPtr));
135: static void DeleteProc _ANSI_ARGS_((ClientData clientData));
136: static Window LookupName _ANSI_ARGS_((TkDisplay *dispPtr, char *name,
137: int delete));
138: static void SendEventProc _ANSI_ARGS_((ClientData clientData,
139: XEvent *eventPtr));
140: static int SendInit _ANSI_ARGS_((Tcl_Interp *interp, TkDisplay *dispPtr));
141: static Bool SendRestrictProc _ANSI_ARGS_((Display *display,
142: XEvent *eventPtr, char *arg));
143: static void TimeoutProc _ANSI_ARGS_((ClientData clientData));
144:
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:
168: int
169: Tk_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:
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:
290: int
291: Tk_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:
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:
514: int
515: TkGetInterpNames(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 **) ®Prop);
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:
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:
601: static int
602: SendInit(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:
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:
660: static Window
661: LookupName(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 **) ®Prop);
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:
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:
776: static void
777: SendEventProc(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:
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:
996: static void
997: AppendPropCarefully(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 */
1024: static int
1025: AppendErrorProc(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:
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:
1072: static void
1073: TimeoutProc(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:
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:
1118: static void
1119: DeleteProc(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:
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 */
1162: static Bool
1163: SendRestrictProc(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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.