![[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.