1/* 2 * tkUnixSend.c -- 3 * 4 * This file provides functions that implement the "send" command, 5 * allowing commands to be passed from interpreter to interpreter. 6 * 7 * Copyright (c) 1989-1994 The Regents of the University of California. 8 * Copyright (c) 1994-1996 Sun Microsystems, Inc. 9 * Copyright (c) 1998-1999 by Scriptics Corporation. 10 * 11 * See the file "license.terms" for information on usage and redistribution of 12 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 * 14 * RCS: @(#) $Id$ 15 */ 16 17#include "tkUnixInt.h" 18 19/* 20 * The following structure is used to keep track of the interpreters 21 * registered by this process. 22 */ 23 24typedef struct RegisteredInterp { 25 char *name; /* Interpreter's name (malloc-ed). */ 26 Tcl_Interp *interp; /* Interpreter associated with name. NULL 27 * means that the application was unregistered 28 * or deleted while a send was in progress to 29 * it. */ 30 TkDisplay *dispPtr; /* Display for the application. Needed because 31 * we may need to unregister the interpreter 32 * after its main window has been deleted. */ 33 struct RegisteredInterp *nextPtr; 34 /* Next in list of names associated with 35 * interps in this process. NULL means end of 36 * list. */ 37} RegisteredInterp; 38 39/* 40 * A registry of all interpreters for a display is kept in a property 41 * "InterpRegistry" on the root window of the display. It is organized as a 42 * series of zero or more concatenated strings (in no particular order), each 43 * of the form 44 * window space name '\0' 45 * where "window" is the hex id of the comm. window to use to talk to an 46 * interpreter named "name". 47 * 48 * When the registry is being manipulated by an application (e.g. to add or 49 * remove an entry), it is loaded into memory using a structure of the 50 * following type: 51 */ 52 53typedef struct NameRegistry { 54 TkDisplay *dispPtr; /* Display from which the registry was 55 * read. */ 56 int locked; /* Non-zero means that the display was locked 57 * when the property was read in. */ 58 int modified; /* Non-zero means that the property has been 59 * modified, so it needs to be written out 60 * when the NameRegistry is closed. */ 61 unsigned long propLength; /* Length of the property, in bytes. */ 62 char *property; /* The contents of the property, or NULL if 63 * none. See format description above; this is 64 * *not* terminated by the first null 65 * character. Dynamically allocated. */ 66 int allocedByX; /* Non-zero means must free property with 67 * XFree; zero means use ckfree. */ 68} NameRegistry; 69 70/* 71 * When a result is being awaited from a sent command, one of the following 72 * structures is present on a list of all outstanding sent commands. The 73 * information in the structure is used to process the result when it arrives. 74 * You're probably wondering how there could ever be multiple outstanding sent 75 * commands. This could happen if interpreters invoke each other recursively. 76 * It's unlikely, but possible. 77 */ 78 79typedef struct PendingCommand { 80 int serial; /* Serial number expected in result. */ 81 TkDisplay *dispPtr; /* Display being used for communication. */ 82 CONST char *target; /* Name of interpreter command is being sent 83 * to. */ 84 Window commWindow; /* Target's communication window. */ 85 Tcl_Interp *interp; /* Interpreter from which the send was 86 * invoked. */ 87 int code; /* Tcl return code for command will be stored 88 * here. */ 89 char *result; /* String result for command (malloc'ed), or 90 * NULL. */ 91 char *errorInfo; /* Information for "errorInfo" variable, or 92 * NULL (malloc'ed). */ 93 char *errorCode; /* Information for "errorCode" variable, or 94 * NULL (malloc'ed). */ 95 int gotResponse; /* 1 means a response has been received, 0 96 * means the command is still outstanding. */ 97 struct PendingCommand *nextPtr; 98 /* Next in list of all outstanding commands. 99 * NULL means end of list. */ 100} PendingCommand; 101 102typedef struct ThreadSpecificData { 103 PendingCommand *pendingCommands; 104 /* List of all commands currently being waited 105 * for. */ 106 RegisteredInterp *interpListPtr; 107 /* List of all interpreters registered in the 108 * current process. */ 109} ThreadSpecificData; 110static Tcl_ThreadDataKey dataKey; 111 112/* 113 * The information below is used for communication between processes during 114 * "send" commands. Each process keeps a private window, never even mapped, 115 * with one property, "Comm". When a command is sent to an interpreter, the 116 * command is appended to the comm property of the communication window 117 * associated with the interp's process. Similarly, when a result is returned 118 * from a sent command, it is also appended to the comm property. 119 * 120 * Each command and each result takes the form of ASCII text. For a command, 121 * the text consists of a zero character followed by several null-terminated 122 * ASCII strings. The first string consists of the single letter "c". 123 * Subsequent strings have the form "option value" where the following options 124 * are supported: 125 * 126 * -r commWindow serial 127 * 128 * This option means that a response should be sent to the window whose X 129 * identifier is "commWindow" (in hex), and the response should be 130 * identified with the serial number given by "serial" (in decimal). If 131 * this option isn't specified then the send is asynchronous and no 132 * response is sent. 133 * 134 * -n name 135 * 136 * "Name" gives the name of the application for which the command is 137 * intended. This option must be present. 138 * 139 * -s script 140 * 141 * "Script" is the script to be executed. This option must be present. 142 * 143 * The options may appear in any order. The -n and -s options must be present, 144 * but -r may be omitted for asynchronous RPCs. For compatibility with future 145 * releases that may add new features, there may be additional options 146 * present; as long as they start with a "-" character, they will be ignored. 147 * 148 * A result also consists of a zero character followed by several null- 149 * terminated ASCII strings. The first string consists of the single letter 150 * "r". Subsequent strings have the form "option value" where the following 151 * options are supported: 152 * 153 * -s serial 154 * 155 * Identifies the command for which this is the result. It is the same as 156 * the "serial" field from the -s option in the command. This option must 157 * be present. 158 * 159 * -c code 160 * 161 * "Code" is the completion code for the script, in decimal. If the code 162 * is omitted it defaults to TCL_OK. 163 * 164 * -r result 165 * 166 * "Result" is the result string for the script, which may be either a 167 * result or an error message. If this field is omitted then it defaults 168 * to an empty string. 169 * 170 * -i errorInfo 171 * 172 * "ErrorInfo" gives a string with which to initialize the errorInfo 173 * variable. This option may be omitted; it is ignored unless the 174 * completion code is TCL_ERROR. 175 * 176 * -e errorCode 177 * 178 * "ErrorCode" gives a string with with to initialize the errorCode 179 * variable. This option may be omitted; it is ignored unless the 180 * completion code is TCL_ERROR. 181 * 182 * Options may appear in any order, and only the -s option must be present. As 183 * with commands, there may be additional options besides these; unknown 184 * options are ignored. 185 */ 186 187/* 188 * Other miscellaneous per-process data: 189 */ 190 191static struct { 192 int sendSerial; /* The serial number that was used in the last 193 * "send" command. */ 194 int sendDebug; /* This can be set while debugging to do 195 * things like skip locking the server. */ 196} localData = {0, 0}; 197 198/* 199 * Maximum size property that can be read at one time by this module: 200 */ 201 202#define MAX_PROP_WORDS 100000 203 204/* 205 * Forward declarations for functions defined later in this file: 206 */ 207 208static int AppendErrorProc(ClientData clientData, 209 XErrorEvent *errorPtr); 210static void AppendPropCarefully(Display *display, 211 Window window, Atom property, char *value, 212 int length, PendingCommand *pendingPtr); 213static void DeleteProc(ClientData clientData); 214static void RegAddName(NameRegistry *regPtr, 215 CONST char *name, Window commWindow); 216static void RegClose(NameRegistry *regPtr); 217static void RegDeleteName(NameRegistry *regPtr, CONST char *name); 218static Window RegFindName(NameRegistry *regPtr, CONST char *name); 219static NameRegistry * RegOpen(Tcl_Interp *interp, 220 TkDisplay *dispPtr, int lock); 221static void SendEventProc(ClientData clientData, XEvent *eventPtr); 222static int SendInit(Tcl_Interp *interp, TkDisplay *dispPtr); 223static Tk_RestrictAction SendRestrictProc(ClientData clientData, 224 XEvent *eventPtr); 225static int ServerSecure(TkDisplay *dispPtr); 226static void UpdateCommWindow(TkDisplay *dispPtr); 227static int ValidateName(TkDisplay *dispPtr, CONST char *name, 228 Window commWindow, int oldOK); 229 230/* 231 *---------------------------------------------------------------------- 232 * 233 * RegOpen -- 234 * 235 * This function loads the name registry for a display into memory so 236 * that it can be manipulated. 237 * 238 * Results: 239 * The return value is a pointer to the loaded registry. 240 * 241 * Side effects: 242 * If "lock" is set then the server will be locked. It is the caller's 243 * responsibility to call RegClose when finished with the registry, so 244 * that we can write back the registry if needed, unlock the server if 245 * needed, and free memory. 246 * 247 *---------------------------------------------------------------------- 248 */ 249 250static NameRegistry * 251RegOpen( 252 Tcl_Interp *interp, /* Interpreter to use for error reporting 253 * (errors cause a panic so in fact no error 254 * is ever returned, but the interpreter is 255 * needed anyway). */ 256 TkDisplay *dispPtr, /* Display whose name registry is to be 257 * opened. */ 258 int lock) /* Non-zero means lock the window server when 259 * opening the registry, so no-one else can 260 * use the registry until we close it. */ 261{ 262 NameRegistry *regPtr; 263 int result, actualFormat; 264 unsigned long bytesAfter; 265 Atom actualType; 266 char **propertyPtr; 267 268 if (dispPtr->commTkwin == NULL) { 269 SendInit(interp, dispPtr); 270 } 271 272 regPtr = (NameRegistry *) ckalloc(sizeof(NameRegistry)); 273 regPtr->dispPtr = dispPtr; 274 regPtr->locked = 0; 275 regPtr->modified = 0; 276 regPtr->allocedByX = 1; 277 propertyPtr = ®Ptr->property; 278 279 if (lock && !localData.sendDebug) { 280 XGrabServer(dispPtr->display); 281 regPtr->locked = 1; 282 } 283 284 /* 285 * Read the registry property. 286 */ 287 288 result = XGetWindowProperty(dispPtr->display, 289 RootWindow(dispPtr->display, 0), 290 dispPtr->registryProperty, 0, MAX_PROP_WORDS, 291 False, XA_STRING, &actualType, &actualFormat, 292 ®Ptr->propLength, &bytesAfter, 293 (unsigned char **) propertyPtr); 294 295 if (actualType == None) { 296 regPtr->propLength = 0; 297 regPtr->property = NULL; 298 } else if ((result != Success) || (actualFormat != 8) 299 || (actualType != XA_STRING)) { 300 /* 301 * The property is improperly formed; delete it. 302 */ 303 304 if (regPtr->property != NULL) { 305 XFree(regPtr->property); 306 regPtr->propLength = 0; 307 regPtr->property = NULL; 308 } 309 XDeleteProperty(dispPtr->display, 310 RootWindow(dispPtr->display, 0), 311 dispPtr->registryProperty); 312 } 313 314 /* 315 * Xlib placed an extra null byte after the end of the property, just to 316 * make sure that it is always NULL-terminated. Be sure to include this 317 * byte in our count if it's needed to ensure null termination (note: as 318 * of 8/95 I'm no longer sure why this code is needed; seems like it 319 * shouldn't be). 320 */ 321 322 if ((regPtr->propLength > 0) 323 && (regPtr->property[regPtr->propLength-1] != 0)) { 324 regPtr->propLength++; 325 } 326 return regPtr; 327} 328 329/* 330 *---------------------------------------------------------------------- 331 * 332 * RegFindName -- 333 * 334 * Given an open name registry, this function finds an entry with a given 335 * name, if there is one, and returns information about that entry. 336 * 337 * Results: 338 * The return value is the X identifier for the comm window for the 339 * application named "name", or None if there is no such entry in the 340 * registry. 341 * 342 * Side effects: 343 * None. 344 * 345 *---------------------------------------------------------------------- 346 */ 347 348static Window 349RegFindName( 350 NameRegistry *regPtr, /* Pointer to a registry opened with a 351 * previous call to RegOpen. */ 352 CONST char *name) /* Name of an application. */ 353{ 354 char *p; 355 356 for (p=regPtr->property ; p-regPtr->property<(int)regPtr->propLength ;) { 357 char *entry = p; 358 359 while ((*p != 0) && (!isspace(UCHAR(*p)))) { 360 p++; 361 } 362 if ((*p != 0) && (strcmp(name, p+1) == 0)) { 363 unsigned int id; 364 365 if (sscanf(entry, "%x", &id) == 1) { 366 /* 367 * Must cast from an unsigned int to a Window in case we are 368 * on a 64-bit architecture. 369 */ 370 371 return (Window) id; 372 } 373 } 374 while (*p != 0) { 375 p++; 376 } 377 p++; 378 } 379 return None; 380} 381 382/* 383 *---------------------------------------------------------------------- 384 * 385 * RegDeleteName -- 386 * 387 * This function deletes the entry for a given name from an open 388 * registry. 389 * 390 * Results: 391 * None. 392 * 393 * Side effects: 394 * If there used to be an entry named "name" in the registry, then it is 395 * deleted and the registry is marked as modified so it will be written 396 * back when closed. 397 * 398 *---------------------------------------------------------------------- 399 */ 400 401static void 402RegDeleteName( 403 NameRegistry *regPtr, /* Pointer to a registry opened with a 404 * previous call to RegOpen. */ 405 CONST char *name) /* Name of an application. */ 406{ 407 char *p; 408 409 for (p=regPtr->property ; p-regPtr->property<(int)regPtr->propLength ;) { 410 char *entry = p, *entryName; 411 412 while ((*p != 0) && (!isspace(UCHAR(*p)))) { 413 p++; 414 } 415 if (*p != 0) { 416 p++; 417 } 418 entryName = p; 419 while (*p != 0) { 420 p++; 421 } 422 p++; 423 if (strcmp(name, entryName) == 0) { 424 int count; 425 426 /* 427 * Found the matching entry. Copy everything after it down on top 428 * of it. 429 */ 430 431 count = regPtr->propLength - (p - regPtr->property); 432 if (count > 0) { 433 char *src, *dst; 434 435 for (src=p , dst=entry ; count>0 ; src++, dst++, count--) { 436 *dst = *src; 437 } 438 } 439 regPtr->propLength -= p - entry; 440 regPtr->modified = 1; 441 return; 442 } 443 } 444} 445 446/* 447 *---------------------------------------------------------------------- 448 * 449 * RegAddName -- 450 * 451 * Add a new entry to an open registry. 452 * 453 * Results: 454 * None. 455 * 456 * Side effects: 457 * The open registry is expanded; it is marked as modified so that it 458 * will be written back when closed. 459 * 460 *---------------------------------------------------------------------- 461 */ 462 463static void 464RegAddName( 465 NameRegistry *regPtr, /* Pointer to a registry opened with a 466 * previous call to RegOpen. */ 467 CONST char *name, /* Name of an application. The caller must 468 * ensure that this name isn't already 469 * registered. */ 470 Window commWindow) /* X identifier for comm. window of 471 * application. */ 472{ 473 char id[30], *newProp; 474 int idLength, newBytes; 475 476 sprintf(id, "%x ", (unsigned int) commWindow); 477 idLength = strlen(id); 478 newBytes = idLength + strlen(name) + 1; 479 newProp = ckalloc((unsigned) (regPtr->propLength + newBytes)); 480 strcpy(newProp, id); 481 strcpy(newProp+idLength, name); 482 if (regPtr->property != NULL) { 483 memcpy(newProp + newBytes, regPtr->property, regPtr->propLength); 484 if (regPtr->allocedByX) { 485 XFree(regPtr->property); 486 } else { 487 ckfree(regPtr->property); 488 } 489 } 490 regPtr->modified = 1; 491 regPtr->propLength += newBytes; 492 regPtr->property = newProp; 493 regPtr->allocedByX = 0; 494} 495 496/* 497 *---------------------------------------------------------------------- 498 * 499 * RegClose -- 500 * 501 * This function is called to end a series of operations on a name 502 * registry. 503 * 504 * Results: 505 * None. 506 * 507 * Side effects: 508 * The registry is written back if it has been modified, and the X server 509 * is unlocked if it was locked. Memory for the registry is freed, so the 510 * caller should never use regPtr again. 511 * 512 *---------------------------------------------------------------------- 513 */ 514 515static void 516RegClose( 517 NameRegistry *regPtr) /* Pointer to a registry opened with a 518 * previous call to RegOpen. */ 519{ 520 if (regPtr->modified) { 521 if (!regPtr->locked && !localData.sendDebug) { 522 Tcl_Panic("The name registry was modified without being locked!"); 523 } 524 XChangeProperty(regPtr->dispPtr->display, 525 RootWindow(regPtr->dispPtr->display, 0), 526 regPtr->dispPtr->registryProperty, XA_STRING, 8, 527 PropModeReplace, (unsigned char *) regPtr->property, 528 (int) regPtr->propLength); 529 } 530 531 if (regPtr->locked) { 532 XUngrabServer(regPtr->dispPtr->display); 533 } 534 535 /* 536 * After ungrabbing the server, it's important to flush the output 537 * immediately so that the server sees the ungrab command. Otherwise we 538 * might do something else that needs to communicate with the server (such 539 * as invoking a subprocess that needs to do I/O to the screen); if the 540 * ungrab command is still sitting in our output buffer, we could 541 * deadlock. 542 */ 543 544 XFlush(regPtr->dispPtr->display); 545 546 if (regPtr->property != NULL) { 547 if (regPtr->allocedByX) { 548 XFree(regPtr->property); 549 } else { 550 ckfree(regPtr->property); 551 } 552 } 553 ckfree((char *) regPtr); 554} 555 556/* 557 *---------------------------------------------------------------------- 558 * 559 * ValidateName -- 560 * 561 * This function checks to see if an entry in the registry is still 562 * valid. 563 * 564 * Results: 565 * The return value is 1 if the given commWindow exists and its name is 566 * "name". Otherwise 0 is returned. 567 * 568 * Side effects: 569 * None. 570 * 571 *---------------------------------------------------------------------- 572 */ 573 574static int 575ValidateName( 576 TkDisplay *dispPtr, /* Display for which to perform the 577 * validation. */ 578 CONST char *name, /* The name of an application. */ 579 Window commWindow, /* X identifier for the application's comm. 580 * window. */ 581 int oldOK) /* Non-zero means that we should consider an 582 * application to be valid even if it looks 583 * like an old-style (pre-4.0) one; 0 means 584 * consider these invalid. */ 585{ 586 int result, actualFormat, argc, i; 587 unsigned long length, bytesAfter; 588 Atom actualType; 589 char *property, **propertyPtr = &property; 590 Tk_ErrorHandler handler; 591 CONST char **argv; 592 593 property = NULL; 594 595 /* 596 * Ignore X errors when reading the property (e.g., the window might not 597 * exist). If an error occurs, result will be some value other than 598 * Success. 599 */ 600 601 handler = Tk_CreateErrorHandler(dispPtr->display, -1, -1, -1, NULL, NULL); 602 result = XGetWindowProperty(dispPtr->display, commWindow, 603 dispPtr->appNameProperty, 0, MAX_PROP_WORDS, 604 False, XA_STRING, &actualType, &actualFormat, 605 &length, &bytesAfter, (unsigned char **) propertyPtr); 606 607 if ((result == Success) && (actualType == None)) { 608 XWindowAttributes atts; 609 610 /* 611 * The comm. window exists but the property we're looking for doesn't 612 * exist. This probably means that the application comes from an older 613 * version of Tk (< 4.0) that didn't set the property; if this is the 614 * case, then assume for compatibility's sake that everything's OK. 615 * However, it's also possible that some random application has 616 * re-used the window id for something totally unrelated. Check a few 617 * characteristics of the window, such as its dimensions and mapped 618 * state, to be sure that it still "smells" like a commWindow. 619 */ 620 621 if (!oldOK 622 || !XGetWindowAttributes(dispPtr->display, commWindow, &atts) 623 || (atts.width != 1) || (atts.height != 1) 624 || (atts.map_state != IsUnmapped)) { 625 result = 0; 626 } else { 627 result = 1; 628 } 629 } else if ((result == Success) && (actualFormat == 8) 630 && (actualType == XA_STRING)) { 631 result = 0; 632 if (Tcl_SplitList(NULL, property, &argc, &argv) == TCL_OK) { 633 for (i = 0; i < argc; i++) { 634 if (strcmp(argv[i], name) == 0) { 635 result = 1; 636 break; 637 } 638 } 639 ckfree((char *) argv); 640 } 641 } else { 642 result = 0; 643 } 644 Tk_DeleteErrorHandler(handler); 645 if (property != NULL) { 646 XFree(property); 647 } 648 return result; 649} 650 651/* 652 *---------------------------------------------------------------------- 653 * 654 * ServerSecure -- 655 * 656 * Check whether a server is secure enough for us to trust Tcl scripts 657 * arriving via that server. 658 * 659 * Results: 660 * The return value is 1 if the server is secure, which means that 661 * host-style authentication is turned on but there are no hosts in the 662 * enabled list. This means that some other form of authorization 663 * (presumably more secure, such as xauth) is in use. 664 * 665 * Side effects: 666 * None. 667 * 668 *---------------------------------------------------------------------- 669 */ 670 671static int 672ServerSecure( 673 TkDisplay *dispPtr) /* Display to check. */ 674{ 675#ifdef TK_NO_SECURITY 676 return 1; 677#else 678 XHostAddress *addrPtr; 679 int numHosts, secure; 680 Bool enabled; 681 682 addrPtr = XListHosts(dispPtr->display, &numHosts, &enabled); 683 if (!enabled) { 684 insecure: 685 secure = 0; 686 } else if (numHosts == 0) { 687 secure = 1; 688 } else { 689 /* 690 * Recent versions of X11 have the extra feature of allowing more 691 * sophisticated authorization checks to be performed than the dozy 692 * old ones that used to plague xhost usage. However, not all deployed 693 * versions of Xlib know how to deal with this feature, so this code 694 * is conditional on having the right #def in place. [Bug 1909931] 695 * 696 * Note that at this point we know that there's at least one entry in 697 * the list returned by XListHosts. However there may be multiple 698 * entries; as long as each is one of either 'SI:localhost:*' or 699 * 'SI:localgroup:*' then we will claim to be secure enough. 700 */ 701 702#ifdef FamilyServerInterpreted 703 XServerInterpretedAddress *siPtr; 704 int i; 705 706 for (i=0 ; i<numHosts ; i++) { 707 if (addrPtr[i].family != FamilyServerInterpreted) { 708 /* 709 * We don't understand what the X server is letting in, so we 710 * err on the side of safety. 711 */ 712 713 goto insecure; 714 } 715 siPtr = (XServerInterpretedAddress *) addrPtr[0].address; 716 717 /* 718 * We don't check the username or group here. This is because it's 719 * officially non-portable and we are just making sure there 720 * aren't silly misconfigurations. (Apparently 'root' is not a 721 * very good choice, but we still don't put any effort in to spot 722 * that.) However we do check to see that the constraints are 723 * imposed against the connecting user and/or group. 724 */ 725 726 if ( !(siPtr->typelength == 9 /* ==strlen("localuser") */ 727 && !memcmp(siPtr->type, "localuser", 9)) 728 && !(siPtr->typelength == 10 /* ==strlen("localgroup") */ 729 && !memcmp(siPtr->type, "localgroup", 10))) { 730 /* 731 * The other defined types of server-interpreted controls 732 * involve particular hosts. These are still insecure for the 733 * same reasons that classic xhost access is insecure; there's 734 * just no way to be sure that the users on those systems are 735 * the ones who should be allowed to connect to this display. 736 */ 737 738 goto insecure; 739 } 740 } 741 secure = 1; 742#else 743 /* 744 * We don't understand what the X server is letting in, so we err on 745 * the side of safety. 746 */ 747 748 goto insecure; 749#endif /* FamilyServerInterpreted */ 750 } 751 if (addrPtr != NULL) { 752 XFree((char *) addrPtr); 753 } 754 return secure; 755#endif /* TK_NO_SECURITY */ 756} 757 758/* 759 *-------------------------------------------------------------- 760 * 761 * Tk_SetAppName -- 762 * 763 * This function is called to associate an ASCII name with a Tk 764 * application. If the application has already been named, the name 765 * replaces the old one. 766 * 767 * Results: 768 * The return value is the name actually given to the application. This 769 * will normally be the same as name, but if name was already in use for 770 * an application then a name of the form "name #2" will be chosen, with 771 * a high enough number to make the name unique. 772 * 773 * Side effects: 774 * Registration info is saved, thereby allowing the "send" command to be 775 * used later to invoke commands in the application. In addition, the 776 * "send" command is created in the application's interpreter. The 777 * registration will be removed automatically if the interpreter is 778 * deleted or the "send" command is removed. 779 * 780 *-------------------------------------------------------------- 781 */ 782 783CONST char * 784Tk_SetAppName( 785 Tk_Window tkwin, /* Token for any window in the application to 786 * be named: it is just used to identify the 787 * application and the display. */ 788 CONST char *name) /* The name that will be used to refer to the 789 * interpreter in later "send" commands. Must 790 * be globally unique. */ 791{ 792 RegisteredInterp *riPtr, *riPtr2; 793 Window w; 794 TkWindow *winPtr = (TkWindow *) tkwin; 795 TkDisplay *dispPtr = winPtr->dispPtr; 796 NameRegistry *regPtr; 797 Tcl_Interp *interp; 798 CONST char *actualName; 799 Tcl_DString dString; 800 int offset, i; 801 ThreadSpecificData *tsdPtr = (ThreadSpecificData *) 802 Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); 803 804 interp = winPtr->mainPtr->interp; 805 if (dispPtr->commTkwin == NULL) { 806 SendInit(interp, winPtr->dispPtr); 807 } 808 809 /* 810 * See if the application is already registered; if so, remove its current 811 * name from the registry. 812 */ 813 814 regPtr = RegOpen(interp, winPtr->dispPtr, 1); 815 for (riPtr = tsdPtr->interpListPtr; ; riPtr = riPtr->nextPtr) { 816 if (riPtr == NULL) { 817 /* 818 * This interpreter isn't currently registered; create the data 819 * structure that will be used to register it locally, plus add 820 * the "send" command to the interpreter. 821 */ 822 823 riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); 824 riPtr->interp = interp; 825 riPtr->dispPtr = winPtr->dispPtr; 826 riPtr->nextPtr = tsdPtr->interpListPtr; 827 tsdPtr->interpListPtr = riPtr; 828 riPtr->name = NULL; 829 Tcl_CreateCommand(interp, "send", Tk_SendCmd, (ClientData) riPtr, 830 DeleteProc); 831 if (Tcl_IsSafe(interp)) { 832 Tcl_HideCommand(interp, "send", "send"); 833 } 834 break; 835 } 836 if (riPtr->interp == interp) { 837 /* 838 * The interpreter is currently registered; remove it from the 839 * name registry. 840 */ 841 842 if (riPtr->name) { 843 RegDeleteName(regPtr, riPtr->name); 844 ckfree(riPtr->name); 845 } 846 break; 847 } 848 } 849 850 /* 851 * Pick a name to use for the application. Use "name" if it's not already 852 * in use. Otherwise add a suffix such as " #2", trying larger and larger 853 * numbers until we eventually find one that is unique. 854 */ 855 856 actualName = name; 857 offset = 0; /* Needed only to avoid "used before 858 * set" compiler warnings. */ 859 for (i = 1; ; i++) { 860 if (i > 1) { 861 if (i == 2) { 862 Tcl_DStringInit(&dString); 863 Tcl_DStringAppend(&dString, name, -1); 864 Tcl_DStringAppend(&dString, " #", 2); 865 offset = Tcl_DStringLength(&dString); 866 Tcl_DStringSetLength(&dString, offset+TCL_INTEGER_SPACE); 867 actualName = Tcl_DStringValue(&dString); 868 } 869 sprintf(Tcl_DStringValue(&dString) + offset, "%d", i); 870 } 871 w = RegFindName(regPtr, actualName); 872 if (w == None) { 873 break; 874 } 875 876 /* 877 * The name appears to be in use already, but double-check to be sure 878 * (perhaps the application died without removing its name from the 879 * registry?). 880 */ 881 882 if (w == Tk_WindowId(dispPtr->commTkwin)) { 883 for (riPtr2 = tsdPtr->interpListPtr; riPtr2 != NULL; 884 riPtr2 = riPtr2->nextPtr) { 885 if ((riPtr2->interp != interp) && 886 (strcmp(riPtr2->name, actualName) == 0)) { 887 goto nextSuffix; 888 } 889 } 890 RegDeleteName(regPtr, actualName); 891 break; 892 } else if (!ValidateName(winPtr->dispPtr, actualName, w, 1)) { 893 RegDeleteName(regPtr, actualName); 894 break; 895 } 896 nextSuffix: 897 continue; 898 } 899 900 /* 901 * We've now got a name to use. Store it in the name registry and in the 902 * local entry for this application, plus put it in a property on the 903 * commWindow. 904 */ 905 906 RegAddName(regPtr, actualName, Tk_WindowId(dispPtr->commTkwin)); 907 RegClose(regPtr); 908 riPtr->name = (char *) ckalloc((unsigned) (strlen(actualName) + 1)); 909 strcpy(riPtr->name, actualName); 910 if (actualName != name) { 911 Tcl_DStringFree(&dString); 912 } 913 UpdateCommWindow(dispPtr); 914 915 return riPtr->name; 916} 917 918/* 919 *-------------------------------------------------------------- 920 * 921 * Tk_SendCmd -- 922 * 923 * This function is invoked to process the "send" Tcl command. See the 924 * user documentation for details on what it does. 925 * 926 * Results: 927 * A standard Tcl result. 928 * 929 * Side effects: 930 * See the user documentation. 931 * 932 *-------------------------------------------------------------- 933 */ 934 935int 936Tk_SendCmd( 937 ClientData clientData, /* Information about sender (only dispPtr 938 * field is used). */ 939 Tcl_Interp *interp, /* Current interpreter. */ 940 int argc, /* Number of arguments. */ 941 CONST char **argv) /* Argument strings. */ 942{ 943 TkWindow *winPtr; 944 Window commWindow; 945 PendingCommand pending; 946 register RegisteredInterp *riPtr; 947 CONST char *destName; 948 int result, c, async, i, firstArg; 949 size_t length; 950 Tk_RestrictProc *prevRestrictProc; 951 ClientData prevArg; 952 TkDisplay *dispPtr; 953 Tcl_Time timeout; 954 NameRegistry *regPtr; 955 Tcl_DString request; 956 ThreadSpecificData *tsdPtr = (ThreadSpecificData *) 957 Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); 958 Tcl_Interp *localInterp; /* Used when the interpreter to send the 959 * command to is within the same process. */ 960 961 /* 962 * Process options, if any. 963 */ 964 965 async = 0; 966 winPtr = (TkWindow *) Tk_MainWindow(interp); 967 if (winPtr == NULL) { 968 return TCL_ERROR; 969 } 970 for (i = 1; i < (argc-1); ) { 971 if (argv[i][0] != '-') { 972 break; 973 } 974 c = argv[i][1]; 975 length = strlen(argv[i]); 976 if ((c == 'a') && (strncmp(argv[i], "-async", length) == 0)) { 977 async = 1; 978 i++; 979 } else if ((c == 'd') && (strncmp(argv[i], "-displayof", 980 length) == 0)) { 981 winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[i+1], 982 (Tk_Window) winPtr); 983 if (winPtr == NULL) { 984 return TCL_ERROR; 985 } 986 i += 2; 987 } else if (strcmp(argv[i], "--") == 0) { 988 i++; 989 break; 990 } else { 991 Tcl_AppendResult(interp, "bad option \"", argv[i], 992 "\": must be -async, -displayof, or --", NULL); 993 return TCL_ERROR; 994 } 995 } 996 997 if (argc < (i+2)) { 998 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], 999 " ?options? interpName arg ?arg ...?\"", NULL); 1000 return TCL_ERROR; 1001 } 1002 destName = argv[i]; 1003 firstArg = i+1; 1004 1005 dispPtr = winPtr->dispPtr; 1006 if (dispPtr->commTkwin == NULL) { 1007 SendInit(interp, winPtr->dispPtr); 1008 } 1009 1010 /* 1011 * See if the target interpreter is local. If so, execute the command 1012 * directly without going through the X server. The only tricky thing is 1013 * passing the result from the target interpreter to the invoking 1014 * interpreter. Watch out: they could be the same! 1015 */ 1016 1017 for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; 1018 riPtr = riPtr->nextPtr) { 1019 if ((riPtr->dispPtr != dispPtr) 1020 || (strcmp(riPtr->name, destName) != 0)) { 1021 continue; 1022 } 1023 Tcl_Preserve((ClientData) riPtr); 1024 localInterp = riPtr->interp; 1025 Tcl_Preserve((ClientData) localInterp); 1026 if (firstArg == (argc-1)) { 1027 result = Tcl_GlobalEval(localInterp, argv[firstArg]); 1028 } else { 1029 Tcl_DStringInit(&request); 1030 Tcl_DStringAppend(&request, argv[firstArg], -1); 1031 for (i = firstArg+1; i < argc; i++) { 1032 Tcl_DStringAppend(&request, " ", 1); 1033 Tcl_DStringAppend(&request, argv[i], -1); 1034 } 1035 result = Tcl_GlobalEval(localInterp, Tcl_DStringValue(&request)); 1036 Tcl_DStringFree(&request); 1037 } 1038 if (interp != localInterp) { 1039 if (result == TCL_ERROR) { 1040 Tcl_Obj *errorObjPtr; 1041 1042 /* 1043 * An error occurred, so transfer error information from the 1044 * destination interpreter back to our interpreter. Must clear 1045 * interp's result before calling Tcl_AddErrorInfo, since 1046 * Tcl_AddErrorInfo will store the interp's result in 1047 * errorInfo before appending riPtr's $errorInfo; we've 1048 * already got everything we need in riPtr's $errorInfo. 1049 */ 1050 1051 Tcl_ResetResult(interp); 1052 Tcl_AddErrorInfo(interp, Tcl_GetVar2(localInterp, 1053 "errorInfo", NULL, TCL_GLOBAL_ONLY)); 1054 errorObjPtr = Tcl_GetVar2Ex(localInterp, "errorCode", NULL, 1055 TCL_GLOBAL_ONLY); 1056 Tcl_SetObjErrorCode(interp, errorObjPtr); 1057 } 1058 Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp)); 1059 Tcl_ResetResult(localInterp); 1060 } 1061 Tcl_Release((ClientData) riPtr); 1062 Tcl_Release((ClientData) localInterp); 1063 return result; 1064 } 1065 1066 /* 1067 * Bind the interpreter name to a communication window. 1068 */ 1069 1070 regPtr = RegOpen(interp, winPtr->dispPtr, 0); 1071 commWindow = RegFindName(regPtr, destName); 1072 RegClose(regPtr); 1073 if (commWindow == None) { 1074 Tcl_AppendResult(interp, "no application named \"",destName,"\"",NULL); 1075 return TCL_ERROR; 1076 } 1077 1078 /* 1079 * Send the command to the target interpreter by appending it to the comm 1080 * window in the communication window. 1081 */ 1082 1083 localData.sendSerial++; 1084 Tcl_DStringInit(&request); 1085 Tcl_DStringAppend(&request, "\0c\0-n ", 6); 1086 Tcl_DStringAppend(&request, destName, -1); 1087 if (!async) { 1088 char buffer[TCL_INTEGER_SPACE * 2]; 1089 1090 sprintf(buffer, "%x %d", 1091 (unsigned int) Tk_WindowId(dispPtr->commTkwin), 1092 localData.sendSerial); 1093 Tcl_DStringAppend(&request, "\0-r ", 4); 1094 Tcl_DStringAppend(&request, buffer, -1); 1095 } 1096 Tcl_DStringAppend(&request, "\0-s ", 4); 1097 Tcl_DStringAppend(&request, argv[firstArg], -1); 1098 for (i = firstArg+1; i < argc; i++) { 1099 Tcl_DStringAppend(&request, " ", 1); 1100 Tcl_DStringAppend(&request, argv[i], -1); 1101 } 1102 (void) AppendPropCarefully(dispPtr->display, commWindow, 1103 dispPtr->commProperty, Tcl_DStringValue(&request), 1104 Tcl_DStringLength(&request) + 1, (async ? NULL : &pending)); 1105 Tcl_DStringFree(&request); 1106 if (async) { 1107 /* 1108 * This is an asynchronous send: return immediately without waiting 1109 * for a response. 1110 */ 1111 1112 return TCL_OK; 1113 } 1114 1115 /* 1116 * Register the fact that we're waiting for a command to complete (this is 1117 * needed by SendEventProc and by AppendErrorProc to pass back the 1118 * command's results). Set up a timeout handler so that we can check 1119 * during long sends to make sure that the destination application is 1120 * still alive. 1121 */ 1122 1123 pending.serial = localData.sendSerial; 1124 pending.dispPtr = dispPtr; 1125 pending.target = destName; 1126 pending.commWindow = commWindow; 1127 pending.interp = interp; 1128 pending.result = NULL; 1129 pending.errorInfo = NULL; 1130 pending.errorCode = NULL; 1131 pending.gotResponse = 0; 1132 pending.nextPtr = tsdPtr->pendingCommands; 1133 tsdPtr->pendingCommands = &pending; 1134 1135 /* 1136 * Enter a loop processing X events until the result comes in or the 1137 * target is declared to be dead. While waiting for a result, look only at 1138 * send-related events so that the send is synchronous with respect to 1139 * other events in the application. 1140 */ 1141 1142 prevRestrictProc = Tk_RestrictEvents(SendRestrictProc, NULL, &prevArg); 1143 Tcl_GetTime(&timeout); 1144 timeout.sec += 2; 1145 while (!pending.gotResponse) { 1146 if (!TkUnixDoOneXEvent(&timeout)) { 1147 /* 1148 * An unusually long amount of time has elapsed during the 1149 * processing of a sent command. Check to make sure that the 1150 * target application still exists. If it does, reset the timeout. 1151 */ 1152 1153 if (!ValidateName(pending.dispPtr, pending.target, 1154 pending.commWindow, 0)) { 1155 char *msg; 1156 1157 if (ValidateName(pending.dispPtr, pending.target, 1158 pending.commWindow, 1)) { 1159 msg = "target application died or uses a Tk version before 4.0"; 1160 } else { 1161 msg = "target application died"; 1162 } 1163 pending.code = TCL_ERROR; 1164 pending.result = (char *) ckalloc((unsigned) (strlen(msg) + 1)); 1165 strcpy(pending.result, msg); 1166 pending.gotResponse = 1; 1167 } else { 1168 Tcl_GetTime(&timeout); 1169 timeout.sec += 2; 1170 } 1171 } 1172 } 1173 (void) Tk_RestrictEvents(prevRestrictProc, prevArg, &prevArg); 1174 1175 /* 1176 * Unregister the information about the pending command and return the 1177 * result. 1178 */ 1179 1180 if (tsdPtr->pendingCommands != &pending) { 1181 Tcl_Panic("Tk_SendCmd: corrupted send stack"); 1182 } 1183 tsdPtr->pendingCommands = pending.nextPtr; 1184 if (pending.errorInfo != NULL) { 1185 /* 1186 * Special trick: must clear the interp's result before calling 1187 * Tcl_AddErrorInfo, since Tcl_AddErrorInfo will store the interp's 1188 * result in errorInfo before appending pending.errorInfo; we've 1189 * already got everything we need in pending.errorInfo. 1190 */ 1191 1192 Tcl_ResetResult(interp); 1193 Tcl_AddErrorInfo(interp, pending.errorInfo); 1194 ckfree(pending.errorInfo); 1195 } 1196 if (pending.errorCode != NULL) { 1197 Tcl_Obj *errorObjPtr = Tcl_NewStringObj(pending.errorCode, -1); 1198 1199 Tcl_SetObjErrorCode(interp, errorObjPtr); 1200 ckfree(pending.errorCode); 1201 } 1202 Tcl_SetResult(interp, pending.result, TCL_DYNAMIC); 1203 return pending.code; 1204} 1205 1206/* 1207 *---------------------------------------------------------------------- 1208 * 1209 * TkGetInterpNames -- 1210 * 1211 * This function is invoked to fetch a list of all the interpreter names 1212 * currently registered for the display of a particular window. 1213 * 1214 * Results: 1215 * A standard Tcl return value. The interp's result will be set to hold a 1216 * list of all the interpreter names defined for tkwin's display. If an 1217 * error occurs, then TCL_ERROR is returned and the interp's result will 1218 * hold an error message. 1219 * 1220 * Side effects: 1221 * None. 1222 * 1223 *---------------------------------------------------------------------- 1224 */ 1225 1226int 1227TkGetInterpNames( 1228 Tcl_Interp *interp, /* Interpreter for returning a result. */ 1229 Tk_Window tkwin) /* Window whose display is to be used for the 1230 * lookup. */ 1231{ 1232 TkWindow *winPtr = (TkWindow *) tkwin; 1233 NameRegistry *regPtr; 1234 char *p; 1235 1236 /* 1237 * Read the registry property, then scan through all of its entries. 1238 * Validate each entry to be sure that its application still exists. 1239 */ 1240 1241 regPtr = RegOpen(interp, winPtr->dispPtr, 1); 1242 for (p=regPtr->property ; p-regPtr->property<(int)regPtr->propLength ;) { 1243 char *entry = p, *entryName; 1244 Window commWindow; 1245 unsigned int id; 1246 1247 if (sscanf(p, "%x",(unsigned int *) &id) != 1) { 1248 commWindow = None; 1249 } else { 1250 commWindow = id; 1251 } 1252 while ((*p != 0) && (!isspace(UCHAR(*p)))) { 1253 p++; 1254 } 1255 if (*p != 0) { 1256 p++; 1257 } 1258 entryName = p; 1259 while (*p != 0) { 1260 p++; 1261 } 1262 p++; 1263 if (ValidateName(winPtr->dispPtr, entryName, commWindow, 1)) { 1264 /* 1265 * The application still exists; add its name to the result. 1266 */ 1267 1268 Tcl_AppendElement(interp, entryName); 1269 } else { 1270 int count; 1271 1272 /* 1273 * This name is bogus (perhaps the application died without 1274 * cleaning up its entry in the registry?). Delete the name. 1275 */ 1276 1277 count = regPtr->propLength - (p - regPtr->property); 1278 if (count > 0) { 1279 char *src, *dst; 1280 1281 for (src = p, dst = entry; count > 0; src++, dst++, count--) { 1282 *dst = *src; 1283 } 1284 } 1285 regPtr->propLength -= p - entry; 1286 regPtr->modified = 1; 1287 p = entry; 1288 } 1289 } 1290 RegClose(regPtr); 1291 return TCL_OK; 1292} 1293 1294/* 1295 *-------------------------------------------------------------- 1296 * 1297 * TkSendCleanup -- 1298 * 1299 * This function is called to free resources used by the communication 1300 * channels for sending commands and receiving results. 1301 * 1302 * Results: 1303 * None. 1304 * 1305 * Side effects: 1306 * Frees various data structures and windows. 1307 * 1308 *-------------------------------------------------------------- 1309 */ 1310 1311void 1312TkSendCleanup( 1313 TkDisplay *dispPtr) 1314{ 1315 if (dispPtr->commTkwin != NULL) { 1316 Tk_DeleteEventHandler(dispPtr->commTkwin, PropertyChangeMask, 1317 SendEventProc, (ClientData) dispPtr); 1318 Tk_DestroyWindow(dispPtr->commTkwin); 1319 Tcl_Release((ClientData) dispPtr->commTkwin); 1320 dispPtr->commTkwin = NULL; 1321 } 1322} 1323 1324/* 1325 *-------------------------------------------------------------- 1326 * 1327 * SendInit -- 1328 * 1329 * This function is called to initialize the communication channels for 1330 * sending commands and receiving results. 1331 * 1332 * Results: 1333 * None. 1334 * 1335 * Side effects: 1336 * Sets up various data structures and windows. 1337 * 1338 *-------------------------------------------------------------- 1339 */ 1340 1341static int 1342SendInit( 1343 Tcl_Interp *interp, /* Interpreter to use for error reporting (no 1344 * errors are ever returned, but the 1345 * interpreter is needed anyway). */ 1346 TkDisplay *dispPtr) /* Display to initialize. */ 1347{ 1348 XSetWindowAttributes atts; 1349 1350 /* 1351 * Create the window used for communication, and set up an event handler 1352 * for it. 1353 */ 1354 1355 dispPtr->commTkwin = Tk_CreateWindow(interp, (Tk_Window) NULL, 1356 "_comm", DisplayString(dispPtr->display)); 1357 if (dispPtr->commTkwin == NULL) { 1358 Tcl_Panic("Tk_CreateWindow failed in SendInit!"); 1359 } 1360 Tcl_Preserve((ClientData) dispPtr->commTkwin); 1361 atts.override_redirect = True; 1362 Tk_ChangeWindowAttributes(dispPtr->commTkwin, 1363 CWOverrideRedirect, &atts); 1364 Tk_CreateEventHandler(dispPtr->commTkwin, PropertyChangeMask, 1365 SendEventProc, (ClientData) dispPtr); 1366 Tk_MakeWindowExist(dispPtr->commTkwin); 1367 1368 /* 1369 * Get atoms used as property names. 1370 */ 1371 1372 dispPtr->commProperty = Tk_InternAtom(dispPtr->commTkwin, "Comm"); 1373 dispPtr->registryProperty = Tk_InternAtom(dispPtr->commTkwin, 1374 "InterpRegistry"); 1375 dispPtr->appNameProperty = Tk_InternAtom(dispPtr->commTkwin, 1376 "TK_APPLICATION"); 1377 1378 return TCL_OK; 1379} 1380 1381/* 1382 *-------------------------------------------------------------- 1383 * 1384 * SendEventProc -- 1385 * 1386 * This function is invoked automatically by the toolkit event manager 1387 * when a property changes on the communication window. This function 1388 * reads the property and handles command requests and responses. 1389 * 1390 * Results: 1391 * None. 1392 * 1393 * Side effects: 1394 * If there are command requests in the property, they are executed. If 1395 * there are responses in the property, their information is saved for 1396 * the (ostensibly waiting) "send" commands. The property is deleted. 1397 * 1398 *-------------------------------------------------------------- 1399 */ 1400 1401static void 1402SendEventProc( 1403 ClientData clientData, /* Display information. */ 1404 XEvent *eventPtr) /* Information about event. */ 1405{ 1406 TkDisplay *dispPtr = (TkDisplay *) clientData; 1407 char *propInfo, **propInfoPtr = &propInfo; 1408 register char *p; 1409 int result, actualFormat; 1410 unsigned long numItems, bytesAfter; 1411 Atom actualType; 1412 Tcl_Interp *remoteInterp; /* Interp in which to execute the command. */ 1413 ThreadSpecificData *tsdPtr = (ThreadSpecificData *) 1414 Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); 1415 1416 if ((eventPtr->xproperty.atom != dispPtr->commProperty) 1417 || (eventPtr->xproperty.state != PropertyNewValue)) { 1418 return; 1419 } 1420 1421 /* 1422 * Read the comm property and delete it. 1423 */ 1424 1425 propInfo = NULL; 1426 result = XGetWindowProperty(dispPtr->display, 1427 Tk_WindowId(dispPtr->commTkwin), dispPtr->commProperty, 0, 1428 MAX_PROP_WORDS, True, XA_STRING, &actualType, &actualFormat, 1429 &numItems, &bytesAfter, (unsigned char **) propInfoPtr); 1430 1431 /* 1432 * If the property doesn't exist or is improperly formed then ignore it. 1433 */ 1434 1435 if ((result != Success) || (actualType != XA_STRING) 1436 || (actualFormat != 8)) { 1437 if (propInfo != NULL) { 1438 XFree(propInfo); 1439 } 1440 return; 1441 } 1442 1443 /* 1444 * Several commands and results could arrive in the property at one time; 1445 * each iteration through the outer loop handles a single command or 1446 * result. 1447 */ 1448 1449 for (p = propInfo; (p-propInfo) < (int) numItems; ) { 1450 /* 1451 * Ignore leading NULLs; each command or result starts with a NULL so 1452 * that no matter how badly formed a preceding command is, we'll be 1453 * able to tell that a new command/result is starting. 1454 */ 1455 1456 if (*p == 0) { 1457 p++; 1458 continue; 1459 } 1460 1461 if ((*p == 'c') && (p[1] == 0)) { 1462 Window commWindow; 1463 char *interpName, *script, *serial, *end; 1464 Tcl_DString reply; 1465 RegisteredInterp *riPtr; 1466 1467 /* 1468 *---------------------------------------------------------- 1469 * This is an incoming command from some other application. 1470 * Iterate over all of its options. Stop when we reach the end of 1471 * the property or something that doesn't look like an option. 1472 *---------------------------------------------------------- 1473 */ 1474 1475 p += 2; 1476 interpName = NULL; 1477 commWindow = None; 1478 serial = ""; 1479 script = NULL; 1480 while (((p-propInfo) < (int) numItems) && (*p == '-')) { 1481 switch (p[1]) { 1482 case 'r': 1483 commWindow = (Window) strtoul(p+2, &end, 16); 1484 if ((end == p+2) || (*end != ' ')) { 1485 commWindow = None; 1486 } else { 1487 p = serial = end+1; 1488 } 1489 break; 1490 case 'n': 1491 if (p[2] == ' ') { 1492 interpName = p+3; 1493 } 1494 break; 1495 case 's': 1496 if (p[2] == ' ') { 1497 script = p+3; 1498 } 1499 break; 1500 } 1501 while (*p != 0) { 1502 p++; 1503 } 1504 p++; 1505 } 1506 1507 if ((script == NULL) || (interpName == NULL)) { 1508 continue; 1509 } 1510 1511 /* 1512 * Initialize the result property, so that we're ready at any time 1513 * if we need to return an error. 1514 */ 1515 1516 if (commWindow != None) { 1517 Tcl_DStringInit(&reply); 1518 Tcl_DStringAppend(&reply, "\0r\0-s ", 6); 1519 Tcl_DStringAppend(&reply, serial, -1); 1520 Tcl_DStringAppend(&reply, "\0-r ", 4); 1521 } 1522 1523 if (!ServerSecure(dispPtr)) { 1524 if (commWindow != None) { 1525 Tcl_DStringAppend(&reply, 1526 "X server insecure (must use xauth-style " 1527 "authorization); command ignored", -1); 1528 } 1529 result = TCL_ERROR; 1530 goto returnResult; 1531 } 1532 1533 /* 1534 * Locate the application, then execute the script. 1535 */ 1536 1537 for (riPtr = tsdPtr->interpListPtr; ; riPtr = riPtr->nextPtr) { 1538 if (riPtr == NULL) { 1539 if (commWindow != None) { 1540 Tcl_DStringAppend(&reply, 1541 "receiver never heard of interpreter \"", -1); 1542 Tcl_DStringAppend(&reply, interpName, -1); 1543 Tcl_DStringAppend(&reply, "\"", 1); 1544 } 1545 result = TCL_ERROR; 1546 goto returnResult; 1547 } 1548 if (strcmp(riPtr->name, interpName) == 0) { 1549 break; 1550 } 1551 } 1552 Tcl_Preserve((ClientData) riPtr); 1553 1554 /* 1555 * We must protect the interpreter because the script may enter 1556 * another event loop, which might call Tcl_DeleteInterp. 1557 */ 1558 1559 remoteInterp = riPtr->interp; 1560 Tcl_Preserve((ClientData) remoteInterp); 1561 1562 result = Tcl_GlobalEval(remoteInterp, script); 1563 1564 /* 1565 * The call to Tcl_Release may have released the interpreter which 1566 * will cause the "send" command for that interpreter to be 1567 * deleted. The command deletion callback will set the 1568 * riPtr->interp field to NULL, hence the check below for NULL. 1569 */ 1570 1571 if (commWindow != None) { 1572 Tcl_DStringAppend(&reply, Tcl_GetStringResult(remoteInterp), 1573 -1); 1574 if (result == TCL_ERROR) { 1575 CONST char *varValue; 1576 1577 varValue = Tcl_GetVar2(remoteInterp, "errorInfo", 1578 NULL, TCL_GLOBAL_ONLY); 1579 if (varValue != NULL) { 1580 Tcl_DStringAppend(&reply, "\0-i ", 4); 1581 Tcl_DStringAppend(&reply, varValue, -1); 1582 } 1583 varValue = Tcl_GetVar2(remoteInterp, "errorCode", 1584 NULL, TCL_GLOBAL_ONLY); 1585 if (varValue != NULL) { 1586 Tcl_DStringAppend(&reply, "\0-e ", 4); 1587 Tcl_DStringAppend(&reply, varValue, -1); 1588 } 1589 } 1590 } 1591 Tcl_Release((ClientData) remoteInterp); 1592 Tcl_Release((ClientData) riPtr); 1593 1594 /* 1595 * Return the result to the sender if a commWindow was specified 1596 * (if none was specified then this is an asynchronous call). 1597 * Right now reply has everything but the completion code, but it 1598 * needs the NULL to terminate the current option. 1599 */ 1600 1601 returnResult: 1602 if (commWindow != None) { 1603 if (result != TCL_OK) { 1604 char buffer[TCL_INTEGER_SPACE]; 1605 1606 sprintf(buffer, "%d", result); 1607 Tcl_DStringAppend(&reply, "\0-c ", 4); 1608 Tcl_DStringAppend(&reply, buffer, -1); 1609 } 1610 (void) AppendPropCarefully(dispPtr->display, commWindow, 1611 dispPtr->commProperty, Tcl_DStringValue(&reply), 1612 Tcl_DStringLength(&reply) + 1, NULL); 1613 XFlush(dispPtr->display); 1614 Tcl_DStringFree(&reply); 1615 } 1616 } else if ((*p == 'r') && (p[1] == 0)) { 1617 int serial, code, gotSerial; 1618 char *errorInfo, *errorCode, *resultString; 1619 PendingCommand *pcPtr; 1620 1621 /* 1622 *---------------------------------------------------------- 1623 * This is a reply to some command that we sent out. Iterate over 1624 * all of its options. Stop when we reach the end of the property 1625 * or something that doesn't look like an option. 1626 *---------------------------------------------------------- 1627 */ 1628 1629 p += 2; 1630 code = TCL_OK; 1631 gotSerial = 0; 1632 errorInfo = NULL; 1633 errorCode = NULL; 1634 resultString = ""; 1635 while (((p-propInfo) < (int) numItems) && (*p == '-')) { 1636 switch (p[1]) { 1637 case 'c': 1638 if (sscanf(p+2, " %d", &code) != 1) { 1639 code = TCL_OK; 1640 } 1641 break; 1642 case 'e': 1643 if (p[2] == ' ') { 1644 errorCode = p+3; 1645 } 1646 break; 1647 case 'i': 1648 if (p[2] == ' ') { 1649 errorInfo = p+3; 1650 } 1651 break; 1652 case 'r': 1653 if (p[2] == ' ') { 1654 resultString = p+3; 1655 } 1656 break; 1657 case 's': 1658 if (sscanf(p+2, " %d", &serial) == 1) { 1659 gotSerial = 1; 1660 } 1661 break; 1662 } 1663 while (*p != 0) { 1664 p++; 1665 } 1666 p++; 1667 } 1668 1669 if (!gotSerial) { 1670 continue; 1671 } 1672 1673 /* 1674 * Give the result information to anyone who's waiting for it. 1675 */ 1676 1677 for (pcPtr = tsdPtr->pendingCommands; pcPtr != NULL; 1678 pcPtr = pcPtr->nextPtr) { 1679 if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) { 1680 continue; 1681 } 1682 pcPtr->code = code; 1683 if (resultString != NULL) { 1684 pcPtr->result = (char *) ckalloc((unsigned) 1685 (strlen(resultString) + 1)); 1686 strcpy(pcPtr->result, resultString); 1687 } 1688 if (code == TCL_ERROR) { 1689 if (errorInfo != NULL) { 1690 pcPtr->errorInfo = (char *) ckalloc((unsigned) 1691 (strlen(errorInfo) + 1)); 1692 strcpy(pcPtr->errorInfo, errorInfo); 1693 } 1694 if (errorCode != NULL) { 1695 pcPtr->errorCode = (char *) ckalloc((unsigned) 1696 (strlen(errorCode) + 1)); 1697 strcpy(pcPtr->errorCode, errorCode); 1698 } 1699 } 1700 pcPtr->gotResponse = 1; 1701 break; 1702 } 1703 } else { 1704 /* 1705 * Didn't recognize this thing. Just skip through the next null 1706 * character and try again. 1707 */ 1708 1709 while (*p != 0) { 1710 p++; 1711 } 1712 p++; 1713 } 1714 } 1715 XFree(propInfo); 1716} 1717 1718/* 1719 *-------------------------------------------------------------- 1720 * 1721 * AppendPropCarefully -- 1722 * 1723 * Append a given property to a given window, but set up an X error 1724 * handler so that if the append fails this function can return an error 1725 * code rather than having Xlib panic. 1726 * 1727 * Results: 1728 * None. 1729 * 1730 * Side effects: 1731 * The given property on the given window is appended to. If this 1732 * operation fails and if pendingPtr is non-NULL, then the pending 1733 * operation is marked as complete with an error. 1734 * 1735 *-------------------------------------------------------------- 1736 */ 1737 1738static void 1739AppendPropCarefully( 1740 Display *display, /* Display on which to operate. */ 1741 Window window, /* Window whose property is to be modified. */ 1742 Atom property, /* Name of property. */ 1743 char *value, /* Characters to append to property. */ 1744 int length, /* Number of bytes to append. */ 1745 PendingCommand *pendingPtr) /* Pending command to mark complete if an 1746 * error occurs during the property op. NULL 1747 * means just ignore the error. */ 1748{ 1749 Tk_ErrorHandler handler; 1750 1751 handler = Tk_CreateErrorHandler(display, -1, -1, -1, AppendErrorProc, 1752 (ClientData) pendingPtr); 1753 XChangeProperty(display, window, property, XA_STRING, 8, 1754 PropModeAppend, (unsigned char *) value, length); 1755 Tk_DeleteErrorHandler(handler); 1756} 1757 1758/* 1759 * The function below is invoked if an error occurs during the XChangeProperty 1760 * operation above. 1761 */ 1762 1763 /* ARGSUSED */ 1764static int 1765AppendErrorProc( 1766 ClientData clientData, /* Command to mark complete, or NULL. */ 1767 XErrorEvent *errorPtr) /* Information about error. */ 1768{ 1769 PendingCommand *pendingPtr = (PendingCommand *) clientData; 1770 register PendingCommand *pcPtr; 1771 ThreadSpecificData *tsdPtr = (ThreadSpecificData *) 1772 Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); 1773 1774 if (pendingPtr == NULL) { 1775 return 0; 1776 } 1777 1778 /* 1779 * Make sure this command is still pending. 1780 */ 1781 1782 for (pcPtr = tsdPtr->pendingCommands; pcPtr != NULL; 1783 pcPtr = pcPtr->nextPtr) { 1784 if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) { 1785 pcPtr->result = (char *) ckalloc((unsigned) 1786 (strlen(pcPtr->target) + 50)); 1787 sprintf(pcPtr->result, "no application named \"%s\"", 1788 pcPtr->target); 1789 pcPtr->code = TCL_ERROR; 1790 pcPtr->gotResponse = 1; 1791 break; 1792 } 1793 } 1794 return 0; 1795} 1796 1797/* 1798 *-------------------------------------------------------------- 1799 * 1800 * DeleteProc -- 1801 * 1802 * This function is invoked by Tcl when the "send" command is deleted in 1803 * an interpreter. It unregisters the interpreter. 1804 * 1805 * Results: 1806 * None. 1807 * 1808 * Side effects: 1809 * The interpreter given by riPtr is unregistered. 1810 * 1811 *-------------------------------------------------------------- 1812 */ 1813 1814static void 1815DeleteProc( 1816 ClientData clientData) /* Info about registration, passed as 1817 * ClientData. */ 1818{ 1819 RegisteredInterp *riPtr = (RegisteredInterp *) clientData; 1820 register RegisteredInterp *riPtr2; 1821 NameRegistry *regPtr; 1822 ThreadSpecificData *tsdPtr = (ThreadSpecificData *) 1823 Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); 1824 1825 regPtr = RegOpen(riPtr->interp, riPtr->dispPtr, 1); 1826 RegDeleteName(regPtr, riPtr->name); 1827 RegClose(regPtr); 1828 1829 if (tsdPtr->interpListPtr == riPtr) { 1830 tsdPtr->interpListPtr = riPtr->nextPtr; 1831 } else { 1832 for (riPtr2 = tsdPtr->interpListPtr; riPtr2 != NULL; 1833 riPtr2 = riPtr2->nextPtr) { 1834 if (riPtr2->nextPtr == riPtr) { 1835 riPtr2->nextPtr = riPtr->nextPtr; 1836 break; 1837 } 1838 } 1839 } 1840 ckfree((char *) riPtr->name); 1841 riPtr->interp = NULL; 1842 UpdateCommWindow(riPtr->dispPtr); 1843 Tcl_EventuallyFree((ClientData) riPtr, TCL_DYNAMIC); 1844} 1845 1846/* 1847 *---------------------------------------------------------------------- 1848 * 1849 * SendRestrictProc -- 1850 * 1851 * This function filters incoming events when a "send" command is 1852 * outstanding. It defers all events except those containing send 1853 * commands and results. 1854 * 1855 * Results: 1856 * False is returned except for property-change events on a commWindow. 1857 * 1858 * Side effects: 1859 * None. 1860 * 1861 *---------------------------------------------------------------------- 1862 */ 1863 1864 /* ARGSUSED */ 1865static Tk_RestrictAction 1866SendRestrictProc( 1867 ClientData clientData, /* Not used. */ 1868 register XEvent *eventPtr) /* Event that just arrived. */ 1869{ 1870 TkDisplay *dispPtr; 1871 1872 if (eventPtr->type != PropertyNotify) { 1873 return TK_DEFER_EVENT; 1874 } 1875 for (dispPtr = TkGetDisplayList(); dispPtr != NULL; 1876 dispPtr = dispPtr->nextPtr) { 1877 if ((eventPtr->xany.display == dispPtr->display) 1878 && (eventPtr->xproperty.window 1879 == Tk_WindowId(dispPtr->commTkwin))) { 1880 return TK_PROCESS_EVENT; 1881 } 1882 } 1883 return TK_DEFER_EVENT; 1884} 1885 1886/* 1887 *---------------------------------------------------------------------- 1888 * 1889 * UpdateCommWindow -- 1890 * 1891 * This function updates the list of application names stored on our 1892 * commWindow. It is typically called when interpreters are registered 1893 * and unregistered. 1894 * 1895 * Results: 1896 * None. 1897 * 1898 * Side effects: 1899 * The TK_APPLICATION property on the comm window is updated. 1900 * 1901 *---------------------------------------------------------------------- 1902 */ 1903 1904static void 1905UpdateCommWindow( 1906 TkDisplay *dispPtr) /* Display whose commWindow is to be 1907 * updated. */ 1908{ 1909 Tcl_DString names; 1910 RegisteredInterp *riPtr; 1911 ThreadSpecificData *tsdPtr = (ThreadSpecificData *) 1912 Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); 1913 1914 Tcl_DStringInit(&names); 1915 for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; 1916 riPtr = riPtr->nextPtr) { 1917 Tcl_DStringAppendElement(&names, riPtr->name); 1918 } 1919 XChangeProperty(dispPtr->display, Tk_WindowId(dispPtr->commTkwin), 1920 dispPtr->appNameProperty, XA_STRING, 8, PropModeReplace, 1921 (unsigned char *) Tcl_DStringValue(&names), 1922 Tcl_DStringLength(&names)); 1923 Tcl_DStringFree(&names); 1924} 1925 1926/* 1927 *---------------------------------------------------------------------- 1928 * 1929 * TkpTestsendCmd -- 1930 * 1931 * This function implements the "testsend" command. It provides a set of 1932 * functions for testing the "send" command and support function in 1933 * tkSend.c. 1934 * 1935 * Results: 1936 * A standard Tcl result. 1937 * 1938 * Side effects: 1939 * Depends on option; see below. 1940 * 1941 *---------------------------------------------------------------------- 1942 */ 1943 1944 /* ARGSUSED */ 1945int 1946TkpTestsendCmd( 1947 ClientData clientData, /* Main window for application. */ 1948 Tcl_Interp *interp, /* Current interpreter. */ 1949 int argc, /* Number of arguments. */ 1950 CONST char **argv) /* Argument strings. */ 1951{ 1952 TkWindow *winPtr = (TkWindow *) clientData; 1953 1954 if (argc < 2) { 1955 Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], 1956 " option ?arg ...?\"", NULL); 1957 return TCL_ERROR; 1958 } 1959 1960 if (strcmp(argv[1], "bogus") == 0) { 1961 XChangeProperty(winPtr->dispPtr->display, 1962 RootWindow(winPtr->dispPtr->display, 0), 1963 winPtr->dispPtr->registryProperty, XA_INTEGER, 32, 1964 PropModeReplace, 1965 (unsigned char *) "This is bogus information", 6); 1966 } else if (strcmp(argv[1], "prop") == 0) { 1967 int result, actualFormat; 1968 unsigned long length, bytesAfter; 1969 Atom actualType, propName; 1970 char *property, **propertyPtr = &property, *p, *end; 1971 Window w; 1972 1973 if ((argc != 4) && (argc != 5)) { 1974 Tcl_AppendResult(interp, "wrong # args; must be \"", argv[0], 1975 " prop window name ?value ?\"", NULL); 1976 return TCL_ERROR; 1977 } 1978 if (strcmp(argv[2], "root") == 0) { 1979 w = RootWindow(winPtr->dispPtr->display, 0); 1980 } else if (strcmp(argv[2], "comm") == 0) { 1981 w = Tk_WindowId(winPtr->dispPtr->commTkwin); 1982 } else { 1983 w = strtoul(argv[2], &end, 0); 1984 } 1985 propName = Tk_InternAtom((Tk_Window) winPtr, argv[3]); 1986 if (argc == 4) { 1987 property = NULL; 1988 result = XGetWindowProperty(winPtr->dispPtr->display, w, propName, 1989 0, 100000, False, XA_STRING, &actualType, &actualFormat, 1990 &length, &bytesAfter, (unsigned char **) propertyPtr); 1991 if ((result == Success) && (actualType != None) 1992 && (actualFormat == 8) && (actualType == XA_STRING)) { 1993 for (p = property; (unsigned long)(p-property) < length; p++) { 1994 if (*p == 0) { 1995 *p = '\n'; 1996 } 1997 } 1998 Tcl_SetResult(interp, property, TCL_VOLATILE); 1999 } 2000 if (property != NULL) { 2001 XFree(property); 2002 } 2003 } else if (argv[4][0] == 0) { 2004 XDeleteProperty(winPtr->dispPtr->display, w, propName); 2005 } else { 2006 Tcl_DString tmp; 2007 2008 Tcl_DStringInit(&tmp); 2009 for (p = Tcl_DStringAppend(&tmp, argv[4], 2010 (int) strlen(argv[4])); *p != 0; p++) { 2011 if (*p == '\n') { 2012 *p = 0; 2013 } 2014 } 2015 2016 XChangeProperty(winPtr->dispPtr->display, w, propName, XA_STRING, 2017 8, PropModeReplace, (unsigned char*)Tcl_DStringValue(&tmp), 2018 p-Tcl_DStringValue(&tmp)); 2019 Tcl_DStringFree(&tmp); 2020 } 2021 } else if (strcmp(argv[1], "serial") == 0) { 2022 char buf[TCL_INTEGER_SPACE]; 2023 2024 sprintf(buf, "%d", localData.sendSerial+1); 2025 Tcl_SetResult(interp, buf, TCL_VOLATILE); 2026 } else { 2027 Tcl_AppendResult(interp, "bad option \"", argv[1], 2028 "\": must be bogus, prop, or serial", NULL); 2029 return TCL_ERROR; 2030 } 2031 return TCL_OK; 2032} 2033 2034/* 2035 * Local Variables: 2036 * mode: c 2037 * c-basic-offset: 4 2038 * fill-column: 78 2039 * End: 2040 */ 2041