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