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