--- /dev/null
+/*
+ * tkUnixSend.c --
+ *
+ * This file provides functions that implement the "send" command,
+ * allowing commands to be passed from interpreter to interpreter.
+ *
+ * Copyright (c) 1989-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tkUnixInt.h"
+
+/*
+ * The following structure is used to keep track of the interpreters
+ * registered by this process.
+ */
+
+typedef struct RegisteredInterp {
+ char *name; /* Interpreter's name (malloc-ed). */
+ Tcl_Interp *interp; /* Interpreter associated with name. NULL
+ * means that the application was unregistered
+ * or deleted while a send was in progress to
+ * it. */
+ TkDisplay *dispPtr; /* Display for the application. Needed because
+ * we may need to unregister the interpreter
+ * after its main window has been deleted. */
+ struct RegisteredInterp *nextPtr;
+ /* Next in list of names associated with
+ * interps in this process. NULL means end of
+ * list. */
+} RegisteredInterp;
+
+/*
+ * A registry of all interpreters for a display is kept in a property
+ * "InterpRegistry" on the root window of the display. It is organized as a
+ * series of zero or more concatenated strings (in no particular order), each
+ * of the form
+ * window space name '\0'
+ * where "window" is the hex id of the comm. window to use to talk to an
+ * interpreter named "name".
+ *
+ * When the registry is being manipulated by an application (e.g. to add or
+ * remove an entry), it is loaded into memory using a structure of the
+ * following type:
+ */
+
+typedef struct NameRegistry {
+ TkDisplay *dispPtr; /* Display from which the registry was
+ * read. */
+ int locked; /* Non-zero means that the display was locked
+ * when the property was read in. */
+ int modified; /* Non-zero means that the property has been
+ * modified, so it needs to be written out
+ * when the NameRegistry is closed. */
+ unsigned long propLength; /* Length of the property, in bytes. */
+ char *property; /* The contents of the property, or NULL if
+ * none. See format description above; this is
+ * *not* terminated by the first null
+ * character. Dynamically allocated. */
+ int allocedByX; /* Non-zero means must free property with
+ * XFree; zero means use ckfree. */
+} NameRegistry;
+
+/*
+ * When a result is being awaited from a sent command, one of the following
+ * structures is present on a list of all outstanding sent commands. The
+ * information in the structure is used to process the result when it arrives.
+ * You're probably wondering how there could ever be multiple outstanding sent
+ * commands. This could happen if interpreters invoke each other recursively.
+ * It's unlikely, but possible.
+ */
+
+typedef struct PendingCommand {
+ int serial; /* Serial number expected in result. */
+ TkDisplay *dispPtr; /* Display being used for communication. */
+ const char *target; /* Name of interpreter command is being sent
+ * to. */
+ Window commWindow; /* Target's communication window. */
+ Tcl_Interp *interp; /* Interpreter from which the send was
+ * invoked. */
+ int code; /* Tcl return code for command will be stored
+ * here. */
+ char *result; /* String result for command (malloc'ed), or
+ * NULL. */
+ char *errorInfo; /* Information for "errorInfo" variable, or
+ * NULL (malloc'ed). */
+ char *errorCode; /* Information for "errorCode" variable, or
+ * NULL (malloc'ed). */
+ int gotResponse; /* 1 means a response has been received, 0
+ * means the command is still outstanding. */
+ struct PendingCommand *nextPtr;
+ /* Next in list of all outstanding commands.
+ * NULL means end of list. */
+} PendingCommand;
+
+typedef struct {
+ PendingCommand *pendingCommands;
+ /* List of all commands currently being waited
+ * for. */
+ RegisteredInterp *interpListPtr;
+ /* List of all interpreters registered in the
+ * current process. */
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * The information below is used for communication between processes during
+ * "send" commands. Each process keeps a private window, never even mapped,
+ * with one property, "Comm". When a command is sent to an interpreter, the
+ * command is appended to the comm property of the communication window
+ * associated with the interp's process. Similarly, when a result is returned
+ * from a sent command, it is also appended to the comm property.
+ *
+ * Each command and each result takes the form of ASCII text. For a command,
+ * the text consists of a zero character followed by several null-terminated
+ * ASCII strings. The first string consists of the single letter "c".
+ * Subsequent strings have the form "option value" where the following options
+ * are supported:
+ *
+ * -r commWindow serial
+ *
+ * This option means that a response should be sent to the window whose X
+ * identifier is "commWindow" (in hex), and the response should be
+ * identified with the serial number given by "serial" (in decimal). If
+ * this option isn't specified then the send is asynchronous and no
+ * response is sent.
+ *
+ * -n name
+ *
+ * "Name" gives the name of the application for which the command is
+ * intended. This option must be present.
+ *
+ * -s script
+ *
+ * "Script" is the script to be executed. This option must be present.
+ *
+ * The options may appear in any order. The -n and -s options must be present,
+ * but -r may be omitted for asynchronous RPCs. For compatibility with future
+ * releases that may add new features, there may be additional options
+ * present; as long as they start with a "-" character, they will be ignored.
+ *
+ * A result also consists of a zero character followed by several null-
+ * terminated ASCII strings. The first string consists of the single letter
+ * "r". Subsequent strings have the form "option value" where the following
+ * options are supported:
+ *
+ * -s serial
+ *
+ * Identifies the command for which this is the result. It is the same as
+ * the "serial" field from the -s option in the command. This option must
+ * be present.
+ *
+ * -c code
+ *
+ * "Code" is the completion code for the script, in decimal. If the code
+ * is omitted it defaults to TCL_OK.
+ *
+ * -r result
+ *
+ * "Result" is the result string for the script, which may be either a
+ * result or an error message. If this field is omitted then it defaults
+ * to an empty string.
+ *
+ * -i errorInfo
+ *
+ * "ErrorInfo" gives a string with which to initialize the errorInfo
+ * variable. This option may be omitted; it is ignored unless the
+ * completion code is TCL_ERROR.
+ *
+ * -e errorCode
+ *
+ * "ErrorCode" gives a string with with to initialize the errorCode
+ * variable. This option may be omitted; it is ignored unless the
+ * completion code is TCL_ERROR.
+ *
+ * Options may appear in any order, and only the -s option must be present. As
+ * with commands, there may be additional options besides these; unknown
+ * options are ignored.
+ */
+
+/*
+ * Other miscellaneous per-process data:
+ */
+
+static struct {
+ int sendSerial; /* The serial number that was used in the last
+ * "send" command. */
+ int sendDebug; /* This can be set while debugging to do
+ * things like skip locking the server. */
+} localData = {0, 0};
+
+/*
+ * Maximum size property that can be read at one time by this module:
+ */
+
+#define MAX_PROP_WORDS 100000
+
+/*
+ * Forward declarations for functions defined later in this file:
+ */
+
+static int AppendErrorProc(ClientData clientData,
+ XErrorEvent *errorPtr);
+static void AppendPropCarefully(Display *display,
+ Window window, Atom property, char *value,
+ int length, PendingCommand *pendingPtr);
+static void DeleteProc(ClientData clientData);
+static void RegAddName(NameRegistry *regPtr,
+ const char *name, Window commWindow);
+static void RegClose(NameRegistry *regPtr);
+static void RegDeleteName(NameRegistry *regPtr, const char *name);
+static Window RegFindName(NameRegistry *regPtr, const char *name);
+static NameRegistry * RegOpen(Tcl_Interp *interp,
+ TkDisplay *dispPtr, int lock);
+static void SendEventProc(ClientData clientData, XEvent *eventPtr);
+static int SendInit(Tcl_Interp *interp, TkDisplay *dispPtr);
+static Tk_RestrictProc SendRestrictProc;
+static int ServerSecure(TkDisplay *dispPtr);
+static void UpdateCommWindow(TkDisplay *dispPtr);
+static int ValidateName(TkDisplay *dispPtr, const char *name,
+ Window commWindow, int oldOK);
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * RegOpen --
+ *
+ * This function loads the name registry for a display into memory so
+ * that it can be manipulated.
+ *
+ * Results:
+ * The return value is a pointer to the loaded registry.
+ *
+ * Side effects:
+ * If "lock" is set then the server will be locked. It is the caller's
+ * responsibility to call RegClose when finished with the registry, so
+ * that we can write back the registry if needed, unlock the server if
+ * needed, and free memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static NameRegistry *
+RegOpen(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting
+ * (errors cause a panic so in fact no error
+ * is ever returned, but the interpreter is
+ * needed anyway). */
+ TkDisplay *dispPtr, /* Display whose name registry is to be
+ * opened. */
+ int lock) /* Non-zero means lock the window server when
+ * opening the registry, so no-one else can
+ * use the registry until we close it. */
+{
+ NameRegistry *regPtr;
+ int result, actualFormat;
+ unsigned long bytesAfter;
+ Atom actualType;
+ char **propertyPtr;
+ Tk_ErrorHandler handler;
+
+ if (dispPtr->commTkwin == NULL) {
+ SendInit(interp, dispPtr);
+ }
+
+ handler = Tk_CreateErrorHandler(dispPtr->display, -1, -1, -1, NULL, NULL);
+
+ regPtr = (NameRegistry *)ckalloc(sizeof(NameRegistry));
+ regPtr->dispPtr = dispPtr;
+ regPtr->locked = 0;
+ regPtr->modified = 0;
+ regPtr->allocedByX = 1;
+ propertyPtr = ®Ptr->property;
+
+ if (lock && !localData.sendDebug) {
+ XGrabServer(dispPtr->display);
+ regPtr->locked = 1;
+ }
+
+ /*
+ * Read the registry property.
+ */
+
+ result = XGetWindowProperty(dispPtr->display,
+ RootWindow(dispPtr->display, 0),
+ dispPtr->registryProperty, 0, MAX_PROP_WORDS,
+ False, XA_STRING, &actualType, &actualFormat,
+ ®Ptr->propLength, &bytesAfter,
+ (unsigned char **) propertyPtr);
+
+ if (actualType == None) {
+ regPtr->propLength = 0;
+ regPtr->property = NULL;
+ } else if ((result != Success) || (actualFormat != 8)
+ || (actualType != XA_STRING)) {
+ /*
+ * The property is improperly formed; delete it.
+ */
+
+ if (regPtr->property != NULL) {
+ XFree(regPtr->property);
+ regPtr->propLength = 0;
+ regPtr->property = NULL;
+ }
+ XDeleteProperty(dispPtr->display,
+ RootWindow(dispPtr->display, 0),
+ dispPtr->registryProperty);
+ XSync(dispPtr->display, False);
+ }
+
+ Tk_DeleteErrorHandler(handler);
+
+ /*
+ * Xlib placed an extra null byte after the end of the property, just to
+ * make sure that it is always NULL-terminated. Be sure to include this
+ * byte in our count if it's needed to ensure null termination (note: as
+ * of 8/95 I'm no longer sure why this code is needed; seems like it
+ * shouldn't be).
+ */
+
+ if ((regPtr->propLength > 0)
+ && (regPtr->property[regPtr->propLength-1] != 0)) {
+ regPtr->propLength++;
+ }
+ return regPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * RegFindName --
+ *
+ * Given an open name registry, this function finds an entry with a given
+ * name, if there is one, and returns information about that entry.
+ *
+ * Results:
+ * The return value is the X identifier for the comm window for the
+ * application named "name", or None if there is no such entry in the
+ * registry.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Window
+RegFindName(
+ NameRegistry *regPtr, /* Pointer to a registry opened with a
+ * previous call to RegOpen. */
+ const char *name) /* Name of an application. */
+{
+ char *p;
+
+ for (p=regPtr->property ; p-regPtr->property<(int)regPtr->propLength ;) {
+ char *entry = p;
+
+ while ((*p != 0) && (!isspace(UCHAR(*p)))) {
+ p++;
+ }
+ if ((*p != 0) && (strcmp(name, p+1) == 0)) {
+ unsigned id;
+
+ if (sscanf(entry, "%x", &id) == 1) {
+ /*
+ * Must cast from an unsigned int to a Window in case we are
+ * on a 64-bit architecture.
+ */
+
+ return (Window) id;
+ }
+ }
+ while (*p != 0) {
+ p++;
+ }
+ p++;
+ }
+ return None;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * RegDeleteName --
+ *
+ * This function deletes the entry for a given name from an open
+ * registry.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If there used to be an entry named "name" in the registry, then it is
+ * deleted and the registry is marked as modified so it will be written
+ * back when closed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RegDeleteName(
+ NameRegistry *regPtr, /* Pointer to a registry opened with a
+ * previous call to RegOpen. */
+ const char *name) /* Name of an application. */
+{
+ char *p;
+
+ for (p=regPtr->property ; p-regPtr->property<(int)regPtr->propLength ;) {
+ char *entry = p, *entryName;
+
+ while ((*p != 0) && (!isspace(UCHAR(*p)))) {
+ p++;
+ }
+ if (*p != 0) {
+ p++;
+ }
+ entryName = p;
+ while (*p != 0) {
+ p++;
+ }
+ p++;
+ if (strcmp(name, entryName) == 0) {
+ int count;
+
+ /*
+ * Found the matching entry. Copy everything after it down on top
+ * of it.
+ */
+
+ count = regPtr->propLength - (p - regPtr->property);
+ if (count > 0) {
+ char *src, *dst;
+
+ for (src=p , dst=entry ; count>0 ; src++, dst++, count--) {
+ *dst = *src;
+ }
+ }
+ regPtr->propLength -= p - entry;
+ regPtr->modified = 1;
+ return;
+ }
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * RegAddName --
+ *
+ * Add a new entry to an open registry.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The open registry is expanded; it is marked as modified so that it
+ * will be written back when closed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RegAddName(
+ NameRegistry *regPtr, /* Pointer to a registry opened with a
+ * previous call to RegOpen. */
+ const char *name, /* Name of an application. The caller must
+ * ensure that this name isn't already
+ * registered. */
+ Window commWindow) /* X identifier for comm. window of
+ * application. */
+{
+ char id[30], *newProp;
+ int idLength, newBytes;
+
+ sprintf(id, "%x ", (unsigned) commWindow);
+ idLength = strlen(id);
+ newBytes = idLength + strlen(name) + 1;
+ newProp = (char *)ckalloc(regPtr->propLength + newBytes);
+ strcpy(newProp, id);
+ strcpy(newProp+idLength, name);
+ if (regPtr->property != NULL) {
+ memcpy(newProp + newBytes, regPtr->property, regPtr->propLength);
+ if (regPtr->allocedByX) {
+ XFree(regPtr->property);
+ } else {
+ ckfree(regPtr->property);
+ }
+ }
+ regPtr->modified = 1;
+ regPtr->propLength += newBytes;
+ regPtr->property = newProp;
+ regPtr->allocedByX = 0;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * RegClose --
+ *
+ * This function is called to end a series of operations on a name
+ * registry.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The registry is written back if it has been modified, and the X server
+ * is unlocked if it was locked. Memory for the registry is freed, so the
+ * caller should never use regPtr again.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RegClose(
+ NameRegistry *regPtr) /* Pointer to a registry opened with a
+ * previous call to RegOpen. */
+{
+ Tk_ErrorHandler handler;
+
+ handler = Tk_CreateErrorHandler(regPtr->dispPtr->display, -1, -1, -1,
+ NULL, NULL);
+
+ if (regPtr->modified) {
+ if (!regPtr->locked && !localData.sendDebug) {
+ Tcl_Panic("The name registry was modified without being locked!");
+ }
+ XChangeProperty(regPtr->dispPtr->display,
+ RootWindow(regPtr->dispPtr->display, 0),
+ regPtr->dispPtr->registryProperty, XA_STRING, 8,
+ PropModeReplace, (unsigned char *) regPtr->property,
+ (int) regPtr->propLength);
+ }
+
+ if (regPtr->locked) {
+ XUngrabServer(regPtr->dispPtr->display);
+ }
+
+ /*
+ * After ungrabbing the server, it's important to flush the output
+ * immediately so that the server sees the ungrab command. Otherwise we
+ * might do something else that needs to communicate with the server (such
+ * as invoking a subprocess that needs to do I/O to the screen); if the
+ * ungrab command is still sitting in our output buffer, we could
+ * deadlock.
+ */
+
+ XFlush(regPtr->dispPtr->display);
+
+ Tk_DeleteErrorHandler(handler);
+
+ if (regPtr->property != NULL) {
+ if (regPtr->allocedByX) {
+ XFree(regPtr->property);
+ } else {
+ ckfree(regPtr->property);
+ }
+ }
+ ckfree(regPtr);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * ValidateName --
+ *
+ * This function checks to see if an entry in the registry is still
+ * valid.
+ *
+ * Results:
+ * The return value is 1 if the given commWindow exists and its name is
+ * "name". Otherwise 0 is returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ValidateName(
+ TkDisplay *dispPtr, /* Display for which to perform the
+ * validation. */
+ const char *name, /* The name of an application. */
+ Window commWindow, /* X identifier for the application's comm.
+ * window. */
+ int oldOK) /* Non-zero means that we should consider an
+ * application to be valid even if it looks
+ * like an old-style (pre-4.0) one; 0 means
+ * consider these invalid. */
+{
+ int result, actualFormat, argc, i;
+ unsigned long length, bytesAfter;
+ Atom actualType;
+ char *property, **propertyPtr = &property;
+ Tk_ErrorHandler handler;
+ const char **argv;
+
+ property = NULL;
+
+ /*
+ * Ignore X errors when reading the property (e.g., the window might not
+ * exist). If an error occurs, result will be some value other than
+ * Success.
+ */
+
+ handler = Tk_CreateErrorHandler(dispPtr->display, -1, -1, -1, NULL, NULL);
+ result = XGetWindowProperty(dispPtr->display, commWindow,
+ dispPtr->appNameProperty, 0, MAX_PROP_WORDS,
+ False, XA_STRING, &actualType, &actualFormat,
+ &length, &bytesAfter, (unsigned char **) propertyPtr);
+
+ if ((result == Success) && (actualType == None)) {
+ XWindowAttributes atts;
+
+ /*
+ * The comm. window exists but the property we're looking for doesn't
+ * exist. This probably means that the application comes from an older
+ * version of Tk (< 4.0) that didn't set the property; if this is the
+ * case, then assume for compatibility's sake that everything's OK.
+ * However, it's also possible that some random application has
+ * re-used the window id for something totally unrelated. Check a few
+ * characteristics of the window, such as its dimensions and mapped
+ * state, to be sure that it still "smells" like a commWindow.
+ */
+
+ if (!oldOK
+ || !XGetWindowAttributes(dispPtr->display, commWindow, &atts)
+ || (atts.width != 1) || (atts.height != 1)
+ || (atts.map_state != IsUnmapped)) {
+ result = 0;
+ } else {
+ result = 1;
+ }
+ } else if ((result == Success) && (actualFormat == 8)
+ && (actualType == XA_STRING)) {
+ result = 0;
+ if (Tcl_SplitList(NULL, property, &argc, &argv) == TCL_OK) {
+ for (i = 0; i < argc; i++) {
+ if (strcmp(argv[i], name) == 0) {
+ result = 1;
+ break;
+ }
+ }
+ ckfree(argv);
+ }
+ } else {
+ result = 0;
+ }
+ Tk_DeleteErrorHandler(handler);
+ if (property != NULL) {
+ XFree(property);
+ }
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * ServerSecure --
+ *
+ * Check whether a server is secure enough for us to trust Tcl scripts
+ * arriving via that server.
+ *
+ * Results:
+ * The return value is 1 if the server is secure, which means that
+ * host-style authentication is turned on but there are no hosts in the
+ * enabled list. This means that some other form of authorization
+ * (presumably more secure, such as xauth) is in use.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ServerSecure(
+ TkDisplay *dispPtr) /* Display to check. */
+{
+#ifdef TK_NO_SECURITY
+ return 1;
+#else
+ XHostAddress *addrPtr;
+ int numHosts, secure;
+ Bool enabled;
+
+ addrPtr = XListHosts(dispPtr->display, &numHosts, &enabled);
+ if (!enabled) {
+ insecure:
+ secure = 0;
+ } else if (numHosts == 0) {
+ secure = 1;
+ } else {
+ /*
+ * Recent versions of X11 have the extra feature of allowing more
+ * sophisticated authorization checks to be performed than the dozy
+ * old ones that used to plague xhost usage. However, not all deployed
+ * versions of Xlib know how to deal with this feature, so this code
+ * is conditional on having the right #def in place. [Bug 1909931]
+ *
+ * Note that at this point we know that there's at least one entry in
+ * the list returned by XListHosts. However there may be multiple
+ * entries; as long as each is one of either 'SI:localhost:*' or
+ * 'SI:localgroup:*' then we will claim to be secure enough.
+ */
+
+#ifdef FamilyServerInterpreted
+ XServerInterpretedAddress *siPtr;
+ int i;
+
+ for (i=0 ; i<numHosts ; i++) {
+ if (addrPtr[i].family != FamilyServerInterpreted) {
+ /*
+ * We don't understand what the X server is letting in, so we
+ * err on the side of safety.
+ */
+
+ goto insecure;
+ }
+ siPtr = (XServerInterpretedAddress *) addrPtr[0].address;
+
+ /*
+ * We don't check the username or group here. This is because it's
+ * officially non-portable and we are just making sure there
+ * aren't silly misconfigurations. (Apparently 'root' is not a
+ * very good choice, but we still don't put any effort in to spot
+ * that.) However we do check to see that the constraints are
+ * imposed against the connecting user and/or group.
+ */
+
+ if ( !(siPtr->typelength == 9 /* ==strlen("localuser") */
+ && !memcmp(siPtr->type, "localuser", 9))
+ && !(siPtr->typelength == 10 /* ==strlen("localgroup") */
+ && !memcmp(siPtr->type, "localgroup", 10))) {
+ /*
+ * The other defined types of server-interpreted controls
+ * involve particular hosts. These are still insecure for the
+ * same reasons that classic xhost access is insecure; there's
+ * just no way to be sure that the users on those systems are
+ * the ones who should be allowed to connect to this display.
+ */
+
+ goto insecure;
+ }
+ }
+ secure = 1;
+#else
+ /*
+ * We don't understand what the X server is letting in, so we err on
+ * the side of safety.
+ */
+
+ secure = 0;
+#endif /* FamilyServerInterpreted */
+ }
+ if (addrPtr != NULL) {
+ XFree((char *) addrPtr);
+ }
+ return secure;
+#endif /* TK_NO_SECURITY */
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_SetAppName --
+ *
+ * This function is called to associate an ASCII name with a Tk
+ * application. If the application has already been named, the name
+ * replaces the old one.
+ *
+ * Results:
+ * The return value is the name actually given to the application. This
+ * will normally be the same as name, but if name was already in use for
+ * an application then a name of the form "name #2" will be chosen, with
+ * a high enough number to make the name unique.
+ *
+ * Side effects:
+ * Registration info is saved, thereby allowing the "send" command to be
+ * used later to invoke commands in the application. In addition, the
+ * "send" command is created in the application's interpreter. The
+ * registration will be removed automatically if the interpreter is
+ * deleted or the "send" command is removed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+const char *
+Tk_SetAppName(
+ Tk_Window tkwin, /* Token for any window in the application to
+ * be named: it is just used to identify the
+ * application and the display. */
+ const char *name) /* The name that will be used to refer to the
+ * interpreter in later "send" commands. Must
+ * be globally unique. */
+{
+ RegisteredInterp *riPtr, *riPtr2;
+ Window w;
+ TkWindow *winPtr = (TkWindow *) tkwin;
+ TkDisplay *dispPtr = winPtr->dispPtr;
+ NameRegistry *regPtr;
+ Tcl_Interp *interp;
+ const char *actualName;
+ Tcl_DString dString;
+ int offset, i;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+
+ interp = winPtr->mainPtr->interp;
+ if (dispPtr->commTkwin == NULL) {
+ SendInit(interp, winPtr->dispPtr);
+ }
+
+ /*
+ * See if the application is already registered; if so, remove its current
+ * name from the registry.
+ */
+
+ regPtr = RegOpen(interp, winPtr->dispPtr, 1);
+ for (riPtr = tsdPtr->interpListPtr; ; riPtr = riPtr->nextPtr) {
+ if (riPtr == NULL) {
+ /*
+ * This interpreter isn't currently registered; create the data
+ * structure that will be used to register it locally, plus add
+ * the "send" command to the interpreter.
+ */
+
+ riPtr = (RegisteredInterp *)ckalloc(sizeof(RegisteredInterp));
+ riPtr->interp = interp;
+ riPtr->dispPtr = winPtr->dispPtr;
+ riPtr->nextPtr = tsdPtr->interpListPtr;
+ tsdPtr->interpListPtr = riPtr;
+ riPtr->name = NULL;
+ Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr, DeleteProc);
+ if (Tcl_IsSafe(interp)) {
+ Tcl_HideCommand(interp, "send", "send");
+ }
+ break;
+ }
+ if (riPtr->interp == interp) {
+ /*
+ * The interpreter is currently registered; remove it from the
+ * name registry.
+ */
+
+ if (riPtr->name) {
+ RegDeleteName(regPtr, riPtr->name);
+ ckfree(riPtr->name);
+ }
+ break;
+ }
+ }
+
+ /*
+ * Pick a name to use for the application. Use "name" if it's not already
+ * in use. Otherwise add a suffix such as " #2", trying larger and larger
+ * numbers until we eventually find one that is unique.
+ */
+
+ actualName = name;
+ offset = 0; /* Needed only to avoid "used before
+ * set" compiler warnings. */
+ for (i = 1; ; i++) {
+ if (i > 1) {
+ if (i == 2) {
+ Tcl_DStringInit(&dString);
+ Tcl_DStringAppend(&dString, name, -1);
+ Tcl_DStringAppend(&dString, " #", 2);
+ offset = Tcl_DStringLength(&dString);
+ Tcl_DStringSetLength(&dString, offset+TCL_INTEGER_SPACE);
+ actualName = Tcl_DStringValue(&dString);
+ }
+ sprintf(Tcl_DStringValue(&dString) + offset, "%d", i);
+ }
+ w = RegFindName(regPtr, actualName);
+ if (w == None) {
+ break;
+ }
+
+ /*
+ * The name appears to be in use already, but double-check to be sure
+ * (perhaps the application died without removing its name from the
+ * registry?).
+ */
+
+ if (w == Tk_WindowId(dispPtr->commTkwin)) {
+ for (riPtr2 = tsdPtr->interpListPtr; riPtr2 != NULL;
+ riPtr2 = riPtr2->nextPtr) {
+ if ((riPtr2->interp != interp) &&
+ (strcmp(riPtr2->name, actualName) == 0)) {
+ goto nextSuffix;
+ }
+ }
+ RegDeleteName(regPtr, actualName);
+ break;
+ } else if (!ValidateName(winPtr->dispPtr, actualName, w, 1)) {
+ RegDeleteName(regPtr, actualName);
+ break;
+ }
+ nextSuffix:
+ continue;
+ }
+
+ /*
+ * We've now got a name to use. Store it in the name registry and in the
+ * local entry for this application, plus put it in a property on the
+ * commWindow.
+ */
+
+ RegAddName(regPtr, actualName, Tk_WindowId(dispPtr->commTkwin));
+ RegClose(regPtr);
+ riPtr->name = (char *)ckalloc(strlen(actualName) + 1);
+ strcpy(riPtr->name, actualName);
+ if (actualName != name) {
+ Tcl_DStringFree(&dString);
+ }
+ UpdateCommWindow(dispPtr);
+
+ return riPtr->name;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_SendObjCmd --
+ *
+ * This function is invoked to process the "send" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_SendObjCmd(
+ TCL_UNUSED(void *), /* Information about sender (only dispPtr
+ * field is used). */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument strings. */
+{
+ enum {
+ SEND_ASYNC, SEND_DISPLAYOF, SEND_LAST
+ };
+ static const char *const sendOptions[] = {
+ "-async", "-displayof", "--", NULL
+ };
+ TkWindow *winPtr;
+ Window commWindow;
+ PendingCommand pending;
+ RegisteredInterp *riPtr;
+ const char *destName;
+ int result, index, async, i, firstArg;
+ Tk_RestrictProc *prevProc;
+ ClientData prevArg;
+ TkDisplay *dispPtr;
+ Tcl_Time timeout;
+ NameRegistry *regPtr;
+ Tcl_DString request;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+ Tcl_Interp *localInterp; /* Used when the interpreter to send the
+ * command to is within the same process. */
+
+ /*
+ * Process options, if any.
+ */
+
+ async = 0;
+ winPtr = (TkWindow *) Tk_MainWindow(interp);
+ if (winPtr == NULL) {
+ return TCL_ERROR;
+ }
+ for (i = 1; i < objc; i++) {
+ if (Tcl_GetIndexFromObjStruct(interp, objv[i], sendOptions,
+ sizeof(char *), "option", 0, &index) != TCL_OK) {
+ break;
+ }
+ if (index == SEND_ASYNC) {
+ ++async;
+ } else if (index == SEND_DISPLAYOF) {
+ winPtr = (TkWindow *) Tk_NameToWindow(interp, Tcl_GetString(objv[++i]),
+ (Tk_Window) winPtr);
+ if (winPtr == NULL) {
+ return TCL_ERROR;
+ }
+ } else if (index == SEND_LAST) {
+ i++;
+ break;
+ }
+ }
+
+ if (objc < (i+2)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?-option value ...? interpName arg ?arg ...?");
+ return TCL_ERROR;
+ }
+ destName = Tcl_GetString(objv[i]);
+ firstArg = i+1;
+
+ dispPtr = winPtr->dispPtr;
+ if (dispPtr->commTkwin == NULL) {
+ SendInit(interp, winPtr->dispPtr);
+ }
+
+ /*
+ * See if the target interpreter is local. If so, execute the command
+ * directly without going through the X server. The only tricky thing is
+ * passing the result from the target interpreter to the invoking
+ * interpreter. Watch out: they could be the same!
+ */
+
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
+ if ((riPtr->dispPtr != dispPtr)
+ || (strcmp(riPtr->name, destName) != 0)) {
+ continue;
+ }
+ Tcl_Preserve(riPtr);
+ localInterp = riPtr->interp;
+ Tcl_Preserve(localInterp);
+ if (firstArg == (objc-1)) {
+ result = Tcl_EvalEx(localInterp, Tcl_GetString(objv[firstArg]), -1, TCL_EVAL_GLOBAL);
+ } else {
+ Tcl_DStringInit(&request);
+ Tcl_DStringAppend(&request, Tcl_GetString(objv[firstArg]), -1);
+ for (i = firstArg+1; i < objc; i++) {
+ Tcl_DStringAppend(&request, " ", 1);
+ Tcl_DStringAppend(&request, Tcl_GetString(objv[i]), -1);
+ }
+ result = Tcl_EvalEx(localInterp, Tcl_DStringValue(&request), -1, TCL_EVAL_GLOBAL);
+ Tcl_DStringFree(&request);
+ }
+ if (interp != localInterp) {
+ if (result == TCL_ERROR) {
+ Tcl_Obj *errorObjPtr;
+
+ /*
+ * An error occurred, so transfer error information from the
+ * destination interpreter back to our interpreter. Must clear
+ * interp's result before calling Tcl_AddErrorInfo, since
+ * Tcl_AddErrorInfo will store the interp's result in
+ * errorInfo before appending riPtr's $errorInfo; we've
+ * already got everything we need in riPtr's $errorInfo.
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_AddErrorInfo(interp, Tcl_GetVar2(localInterp,
+ "errorInfo", NULL, TCL_GLOBAL_ONLY));
+ errorObjPtr = Tcl_GetVar2Ex(localInterp, "errorCode", NULL,
+ TCL_GLOBAL_ONLY);
+ Tcl_SetObjErrorCode(interp, errorObjPtr);
+ }
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp));
+ Tcl_ResetResult(localInterp);
+ }
+ Tcl_Release(riPtr);
+ Tcl_Release(localInterp);
+ return result;
+ }
+
+ /*
+ * Bind the interpreter name to a communication window.
+ */
+
+ regPtr = RegOpen(interp, winPtr->dispPtr, 0);
+ commWindow = RegFindName(regPtr, destName);
+ RegClose(regPtr);
+ if (commWindow == None) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no application named \"%s\"", destName));
+ Tcl_SetErrorCode(interp, "TK", "LOOKUP", "APPLICATION", destName,
+ NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Send the command to the target interpreter by appending it to the comm
+ * window in the communication window.
+ */
+
+ localData.sendSerial++;
+ Tcl_DStringInit(&request);
+ Tcl_DStringAppend(&request, "\0c\0-n ", 6);
+ Tcl_DStringAppend(&request, destName, -1);
+ if (!async) {
+ char buffer[TCL_INTEGER_SPACE * 2];
+
+ sprintf(buffer, "%x %d",
+ (unsigned) Tk_WindowId(dispPtr->commTkwin),
+ localData.sendSerial);
+ Tcl_DStringAppend(&request, "\0-r ", 4);
+ Tcl_DStringAppend(&request, buffer, -1);
+ }
+ Tcl_DStringAppend(&request, "\0-s ", 4);
+ Tcl_DStringAppend(&request, Tcl_GetString(objv[firstArg]), -1);
+ for (i = firstArg+1; i < objc; i++) {
+ Tcl_DStringAppend(&request, " ", 1);
+ Tcl_DStringAppend(&request, Tcl_GetString(objv[i]), -1);
+ }
+
+ if (!async) {
+ /*
+ * Register the fact that we're waiting for a command to complete
+ * (this is needed by SendEventProc and by AppendErrorProc to pass
+ * back the command's results). Set up a timeout handler so that
+ * we can check during long sends to make sure that the destination
+ * application is still alive.
+ *
+ * We prepare the pending struct here in order to catch potential
+ * early X errors from AppendPropCarefully() due to XSync().
+ */
+
+ pending.serial = localData.sendSerial;
+ pending.dispPtr = dispPtr;
+ pending.target = destName;
+ pending.commWindow = commWindow;
+ pending.interp = interp;
+ pending.result = NULL;
+ pending.errorInfo = NULL;
+ pending.errorCode = NULL;
+ pending.gotResponse = 0;
+ pending.nextPtr = tsdPtr->pendingCommands;
+ tsdPtr->pendingCommands = &pending;
+ }
+ (void) AppendPropCarefully(dispPtr->display, commWindow,
+ dispPtr->commProperty, Tcl_DStringValue(&request),
+ Tcl_DStringLength(&request) + 1, (async ? NULL : &pending));
+ Tcl_DStringFree(&request);
+ if (async) {
+ /*
+ * This is an asynchronous send: return immediately without waiting
+ * for a response.
+ */
+
+ return TCL_OK;
+ }
+
+ /*
+ * Enter a loop processing X events until the result comes in or the
+ * target is declared to be dead. While waiting for a result, look only at
+ * send-related events so that the send is synchronous with respect to
+ * other events in the application.
+ */
+
+ prevProc = Tk_RestrictEvents(SendRestrictProc, NULL, &prevArg);
+ Tcl_GetTime(&timeout);
+ timeout.sec += 2;
+ while (!pending.gotResponse) {
+ if (!TkUnixDoOneXEvent(&timeout)) {
+ /*
+ * An unusually long amount of time has elapsed during the
+ * processing of a sent command. Check to make sure that the
+ * target application still exists. If it does, reset the timeout.
+ */
+
+ if (!ValidateName(pending.dispPtr, pending.target,
+ pending.commWindow, 0)) {
+ const char *msg;
+
+ if (ValidateName(pending.dispPtr, pending.target,
+ pending.commWindow, 1)) {
+ msg = "target application died or uses a Tk version before 4.0";
+ } else {
+ msg = "target application died";
+ }
+ pending.code = TCL_ERROR;
+ pending.result = (char *)ckalloc(strlen(msg) + 1);
+ strcpy(pending.result, msg);
+ pending.gotResponse = 1;
+ } else {
+ Tcl_GetTime(&timeout);
+ timeout.sec += 2;
+ }
+ }
+ }
+ Tk_RestrictEvents(prevProc, prevArg, &prevArg);
+
+ /*
+ * Unregister the information about the pending command and return the
+ * result.
+ */
+
+ if (tsdPtr->pendingCommands != &pending) {
+ Tcl_Panic("Tk_SendCmd: corrupted send stack");
+ }
+ tsdPtr->pendingCommands = pending.nextPtr;
+ if (pending.errorInfo != NULL) {
+ /*
+ * Special trick: must clear the interp's result before calling
+ * Tcl_AddErrorInfo, since Tcl_AddErrorInfo will store the interp's
+ * result in errorInfo before appending pending.errorInfo; we've
+ * already got everything we need in pending.errorInfo.
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_AddErrorInfo(interp, pending.errorInfo);
+ ckfree(pending.errorInfo);
+ }
+ if (pending.errorCode != NULL) {
+ Tcl_SetObjErrorCode(interp, Tcl_NewStringObj(pending.errorCode, -1));
+ ckfree(pending.errorCode);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(pending.result, -1));
+ ckfree(pending.result);
+ return pending.code;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkGetInterpNames --
+ *
+ * This function is invoked to fetch a list of all the interpreter names
+ * currently registered for the display of a particular window.
+ *
+ * Results:
+ * A standard Tcl return value. The interp's result will be set to hold a
+ * list of all the interpreter names defined for tkwin's display. If an
+ * error occurs, then TCL_ERROR is returned and the interp's result will
+ * hold an error message.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TkGetInterpNames(
+ Tcl_Interp *interp, /* Interpreter for returning a result. */
+ Tk_Window tkwin) /* Window whose display is to be used for the
+ * lookup. */
+{
+ TkWindow *winPtr = (TkWindow *) tkwin;
+ NameRegistry *regPtr;
+ Tcl_Obj *resultObj = Tcl_NewObj();
+ char *p;
+
+ /*
+ * Read the registry property, then scan through all of its entries.
+ * Validate each entry to be sure that its application still exists.
+ */
+
+ regPtr = RegOpen(interp, winPtr->dispPtr, 1);
+ for (p=regPtr->property ; p-regPtr->property<(int)regPtr->propLength ;) {
+ char *entry = p, *entryName;
+ Window commWindow;
+ unsigned id;
+
+ if (sscanf(p, "%x", (unsigned *) &id) != 1) {
+ commWindow = None;
+ } else {
+ commWindow = id;
+ }
+ while ((*p != 0) && (!isspace(UCHAR(*p)))) {
+ p++;
+ }
+ if (*p != 0) {
+ p++;
+ }
+ entryName = p;
+ while (*p != 0) {
+ p++;
+ }
+ p++;
+ if (ValidateName(winPtr->dispPtr, entryName, commWindow, 1)) {
+ /*
+ * The application still exists; add its name to the result.
+ */
+
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ Tcl_NewStringObj(entryName, -1));
+ } else {
+ int count;
+
+ /*
+ * This name is bogus (perhaps the application died without
+ * cleaning up its entry in the registry?). Delete the name.
+ */
+
+ count = regPtr->propLength - (p - regPtr->property);
+ if (count > 0) {
+ char *src, *dst;
+
+ for (src = p, dst = entry; count > 0; src++, dst++, count--) {
+ *dst = *src;
+ }
+ }
+ regPtr->propLength -= p - entry;
+ regPtr->modified = 1;
+ p = entry;
+ }
+ }
+ RegClose(regPtr);
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * TkSendCleanup --
+ *
+ * This function is called to free resources used by the communication
+ * channels for sending commands and receiving results.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees various data structures and windows.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+TkSendCleanup(
+ TkDisplay *dispPtr)
+{
+ if (dispPtr->commTkwin != NULL) {
+ Tk_DeleteEventHandler(dispPtr->commTkwin, PropertyChangeMask,
+ SendEventProc, dispPtr);
+ Tk_DestroyWindow(dispPtr->commTkwin);
+ Tcl_Release(dispPtr->commTkwin);
+ dispPtr->commTkwin = NULL;
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * SendInit --
+ *
+ * This function is called to initialize the communication channels for
+ * sending commands and receiving results.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets up various data structures and windows.
+ *
+ *--------------------------------------------------------------
+ */
+
+static int
+SendInit(
+ TCL_UNUSED(Tcl_Interp *), /* Interpreter to use for error reporting (no
+ * errors are ever returned, but the
+ * interpreter is needed anyway). */
+ TkDisplay *dispPtr) /* Display to initialize. */
+{
+ XSetWindowAttributes atts;
+
+ /*
+ * Create the window used for communication, and set up an event handler
+ * for it.
+ */
+
+ dispPtr->commTkwin = (Tk_Window) TkAllocWindow(dispPtr,
+ DefaultScreen(dispPtr->display), NULL);
+ Tcl_Preserve(dispPtr->commTkwin);
+ ((TkWindow *) dispPtr->commTkwin)->flags |=
+ TK_TOP_HIERARCHY|TK_TOP_LEVEL|TK_HAS_WRAPPER|TK_WIN_MANAGED;
+ TkWmNewWindow((TkWindow *) dispPtr->commTkwin);
+ atts.override_redirect = True;
+ Tk_ChangeWindowAttributes(dispPtr->commTkwin,
+ CWOverrideRedirect, &atts);
+ Tk_CreateEventHandler(dispPtr->commTkwin, PropertyChangeMask,
+ SendEventProc, dispPtr);
+ Tk_MakeWindowExist(dispPtr->commTkwin);
+
+ /*
+ * Get atoms used as property names.
+ */
+
+ dispPtr->commProperty = Tk_InternAtom(dispPtr->commTkwin, "Comm");
+ dispPtr->registryProperty = Tk_InternAtom(dispPtr->commTkwin,
+ "InterpRegistry");
+ dispPtr->appNameProperty = Tk_InternAtom(dispPtr->commTkwin,
+ "TK_APPLICATION");
+
+ return TCL_OK;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * SendEventProc --
+ *
+ * This function is invoked automatically by the toolkit event manager
+ * when a property changes on the communication window. This function
+ * reads the property and handles command requests and responses.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If there are command requests in the property, they are executed. If
+ * there are responses in the property, their information is saved for
+ * the (ostensibly waiting) "send" commands. The property is deleted.
+ *
+ *--------------------------------------------------------------
+ */
+
+static void
+SendEventProc(
+ ClientData clientData, /* Display information. */
+ XEvent *eventPtr) /* Information about event. */
+{
+ TkDisplay *dispPtr = (TkDisplay *)clientData;
+ char *propInfo, **propInfoPtr = &propInfo;
+ const char *p;
+ int result, actualFormat;
+ unsigned long numItems, bytesAfter;
+ Atom actualType;
+ Tcl_Interp *remoteInterp; /* Interp in which to execute the command. */
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+
+ if ((eventPtr->xproperty.atom != dispPtr->commProperty)
+ || (eventPtr->xproperty.state != PropertyNewValue)) {
+ return;
+ }
+
+ /*
+ * Read the comm property and delete it.
+ */
+
+ propInfo = NULL;
+ result = XGetWindowProperty(dispPtr->display,
+ Tk_WindowId(dispPtr->commTkwin), dispPtr->commProperty, 0,
+ MAX_PROP_WORDS, True, XA_STRING, &actualType, &actualFormat,
+ &numItems, &bytesAfter, (unsigned char **) propInfoPtr);
+
+ /*
+ * If the property doesn't exist or is improperly formed then ignore it.
+ */
+
+ if ((result != Success) || (actualType != XA_STRING)
+ || (actualFormat != 8)) {
+ if (propInfo != NULL) {
+ XFree(propInfo);
+ }
+ return;
+ }
+
+ /*
+ * Several commands and results could arrive in the property at one time;
+ * each iteration through the outer loop handles a single command or
+ * result.
+ */
+
+ for (p = propInfo; (p-propInfo) < (int) numItems; ) {
+ /*
+ * Ignore leading NULLs; each command or result starts with a NULL so
+ * that no matter how badly formed a preceding command is, we'll be
+ * able to tell that a new command/result is starting.
+ */
+
+ if (*p == 0) {
+ p++;
+ continue;
+ }
+
+ if ((*p == 'c') && (p[1] == 0)) {
+ Window commWindow;
+ const char *interpName, *script, *serial;
+ char *end;
+ Tcl_DString reply;
+ RegisteredInterp *riPtr;
+
+ /*
+ *----------------------------------------------------------
+ * This is an incoming command from some other application.
+ * Iterate over all of its options. Stop when we reach the end of
+ * the property or something that doesn't look like an option.
+ *----------------------------------------------------------
+ */
+
+ p += 2;
+ interpName = NULL;
+ commWindow = None;
+ serial = "";
+ script = NULL;
+ while (((p-propInfo) < (int) numItems) && (*p == '-')) {
+ switch (p[1]) {
+ case 'r':
+ commWindow = (Window) strtoul(p+2, &end, 16);
+ if ((end == p+2) || (*end != ' ')) {
+ commWindow = None;
+ } else {
+ p = serial = end+1;
+ }
+ break;
+ case 'n':
+ if (p[2] == ' ') {
+ interpName = p+3;
+ }
+ break;
+ case 's':
+ if (p[2] == ' ') {
+ script = p+3;
+ }
+ break;
+ }
+ while (*p != 0) {
+ p++;
+ }
+ p++;
+ }
+
+ if ((script == NULL) || (interpName == NULL)) {
+ continue;
+ }
+
+ /*
+ * Initialize the result property, so that we're ready at any time
+ * if we need to return an error.
+ */
+
+ if (commWindow != None) {
+ Tcl_DStringInit(&reply);
+ Tcl_DStringAppend(&reply, "\0r\0-s ", 6);
+ Tcl_DStringAppend(&reply, serial, -1);
+ Tcl_DStringAppend(&reply, "\0-r ", 4);
+ }
+
+ if (!ServerSecure(dispPtr)) {
+ if (commWindow != None) {
+ Tcl_DStringAppend(&reply,
+ "X server insecure (must use xauth-style "
+ "authorization); command ignored", -1);
+ }
+ result = TCL_ERROR;
+ goto returnResult;
+ }
+
+ /*
+ * Locate the application, then execute the script.
+ */
+
+ for (riPtr = tsdPtr->interpListPtr; ; riPtr = riPtr->nextPtr) {
+ if (riPtr == NULL) {
+ if (commWindow != None) {
+ Tcl_DStringAppend(&reply,
+ "receiver never heard of interpreter \"", -1);
+ Tcl_DStringAppend(&reply, interpName, -1);
+ Tcl_DStringAppend(&reply, "\"", 1);
+ }
+ result = TCL_ERROR;
+ goto returnResult;
+ }
+ if (strcmp(riPtr->name, interpName) == 0) {
+ break;
+ }
+ }
+ Tcl_Preserve(riPtr);
+
+ /*
+ * We must protect the interpreter because the script may enter
+ * another event loop, which might call Tcl_DeleteInterp.
+ */
+
+ remoteInterp = riPtr->interp;
+ Tcl_Preserve(remoteInterp);
+
+ result = Tcl_EvalEx(remoteInterp, script, -1, TCL_EVAL_GLOBAL);
+
+ /*
+ * The call to Tcl_Release may have released the interpreter which
+ * will cause the "send" command for that interpreter to be
+ * deleted. The command deletion callback will set the
+ * riPtr->interp field to NULL, hence the check below for NULL.
+ */
+
+ if (commWindow != None) {
+ Tcl_DStringAppend(&reply, Tcl_GetString(Tcl_GetObjResult(remoteInterp)),
+ -1);
+ if (result == TCL_ERROR) {
+ const char *varValue;
+
+ varValue = Tcl_GetVar2(remoteInterp, "errorInfo",
+ NULL, TCL_GLOBAL_ONLY);
+ if (varValue != NULL) {
+ Tcl_DStringAppend(&reply, "\0-i ", 4);
+ Tcl_DStringAppend(&reply, varValue, -1);
+ }
+ varValue = Tcl_GetVar2(remoteInterp, "errorCode",
+ NULL, TCL_GLOBAL_ONLY);
+ if (varValue != NULL) {
+ Tcl_DStringAppend(&reply, "\0-e ", 4);
+ Tcl_DStringAppend(&reply, varValue, -1);
+ }
+ }
+ }
+ Tcl_Release(remoteInterp);
+ Tcl_Release(riPtr);
+
+ /*
+ * Return the result to the sender if a commWindow was specified
+ * (if none was specified then this is an asynchronous call).
+ * Right now reply has everything but the completion code, but it
+ * needs the NULL to terminate the current option.
+ */
+
+ returnResult:
+ if (commWindow != None) {
+ if (result != TCL_OK) {
+ char buffer[TCL_INTEGER_SPACE];
+
+ sprintf(buffer, "%d", result);
+ Tcl_DStringAppend(&reply, "\0-c ", 4);
+ Tcl_DStringAppend(&reply, buffer, -1);
+ }
+ (void) AppendPropCarefully(dispPtr->display, commWindow,
+ dispPtr->commProperty, Tcl_DStringValue(&reply),
+ Tcl_DStringLength(&reply) + 1, NULL);
+ XFlush(dispPtr->display);
+ Tcl_DStringFree(&reply);
+ }
+ } else if ((*p == 'r') && (p[1] == 0)) {
+ int serial, code, gotSerial;
+ const char *errorInfo, *errorCode, *resultString;
+ PendingCommand *pcPtr;
+
+ /*
+ *----------------------------------------------------------
+ * This is a reply to some command that we sent out. Iterate over
+ * all of its options. Stop when we reach the end of the property
+ * or something that doesn't look like an option.
+ *----------------------------------------------------------
+ */
+
+ p += 2;
+ code = TCL_OK;
+ gotSerial = 0;
+ errorInfo = NULL;
+ errorCode = NULL;
+ resultString = "";
+ while (((p-propInfo) < (int) numItems) && (*p == '-')) {
+ switch (p[1]) {
+ case 'c':
+ if (sscanf(p+2, " %d", &code) != 1) {
+ code = TCL_OK;
+ }
+ break;
+ case 'e':
+ if (p[2] == ' ') {
+ errorCode = p+3;
+ }
+ break;
+ case 'i':
+ if (p[2] == ' ') {
+ errorInfo = p+3;
+ }
+ break;
+ case 'r':
+ if (p[2] == ' ') {
+ resultString = p+3;
+ }
+ break;
+ case 's':
+ if (sscanf(p+2, " %d", &serial) == 1) {
+ gotSerial = 1;
+ }
+ break;
+ }
+ while (*p != 0) {
+ p++;
+ }
+ p++;
+ }
+
+ if (!gotSerial) {
+ continue;
+ }
+
+ /*
+ * Give the result information to anyone who's waiting for it.
+ */
+
+ for (pcPtr = tsdPtr->pendingCommands; pcPtr != NULL;
+ pcPtr = pcPtr->nextPtr) {
+ if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) {
+ continue;
+ }
+ pcPtr->code = code;
+ if (resultString != NULL) {
+ pcPtr->result = (char *)ckalloc(strlen(resultString) + 1);
+ strcpy(pcPtr->result, resultString);
+ }
+ if (code == TCL_ERROR) {
+ if (errorInfo != NULL) {
+ pcPtr->errorInfo = (char *)ckalloc(strlen(errorInfo) + 1);
+ strcpy(pcPtr->errorInfo, errorInfo);
+ }
+ if (errorCode != NULL) {
+ pcPtr->errorCode = (char *)ckalloc(strlen(errorCode) + 1);
+ strcpy(pcPtr->errorCode, errorCode);
+ }
+ }
+ pcPtr->gotResponse = 1;
+ break;
+ }
+ } else {
+ /*
+ * Didn't recognize this thing. Just skip through the next null
+ * character and try again.
+ */
+
+ while (*p != 0) {
+ p++;
+ }
+ p++;
+ }
+ }
+ XFree(propInfo);
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * AppendPropCarefully --
+ *
+ * Append a given property to a given window, but set up an X error
+ * handler so that if the append fails this function can return an error
+ * code rather than having Xlib panic.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The given property on the given window is appended to. If this
+ * operation fails and if pendingPtr is non-NULL, then the pending
+ * operation is marked as complete with an error.
+ *
+ *--------------------------------------------------------------
+ */
+
+static void
+AppendPropCarefully(
+ Display *display, /* Display on which to operate. */
+ Window window, /* Window whose property is to be modified. */
+ Atom property, /* Name of property. */
+ char *value, /* Characters to append to property. */
+ int length, /* Number of bytes to append. */
+ PendingCommand *pendingPtr) /* Pending command to mark complete if an
+ * error occurs during the property op. NULL
+ * means just ignore the error. */
+{
+ Tk_ErrorHandler handler;
+
+ handler = Tk_CreateErrorHandler(display, -1, -1, -1, AppendErrorProc,
+ pendingPtr);
+ XChangeProperty(display, window, property, XA_STRING, 8,
+ PropModeAppend, (unsigned char *) value, length);
+ Tk_DeleteErrorHandler(handler);
+}
+
+/*
+ * The function below is invoked if an error occurs during the XChangeProperty
+ * operation above.
+ */
+
+static int
+AppendErrorProc(
+ ClientData clientData, /* Command to mark complete, or NULL. */
+ TCL_UNUSED(XErrorEvent *)) /* Information about error. */
+{
+ PendingCommand *pendingPtr = (PendingCommand *)clientData;
+ PendingCommand *pcPtr;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+
+ if (pendingPtr == NULL) {
+ return 0;
+ }
+
+ /*
+ * Make sure this command is still pending.
+ */
+
+ for (pcPtr = tsdPtr->pendingCommands; pcPtr != NULL;
+ pcPtr = pcPtr->nextPtr) {
+ if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) {
+ pcPtr->result = (char *)ckalloc(strlen(pcPtr->target) + 50);
+ sprintf(pcPtr->result, "no application named \"%s\"",
+ pcPtr->target);
+ pcPtr->code = TCL_ERROR;
+ pcPtr->gotResponse = 1;
+ break;
+ }
+ }
+ return 0;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * DeleteProc --
+ *
+ * This function is invoked by Tcl when the "send" command is deleted in
+ * an interpreter. It unregisters the interpreter.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The interpreter given by riPtr is unregistered.
+ *
+ *--------------------------------------------------------------
+ */
+
+static void
+DeleteProc(
+ ClientData clientData) /* Info about registration, passed as
+ * ClientData. */
+{
+ RegisteredInterp *riPtr = (RegisteredInterp *)clientData;
+ RegisteredInterp *riPtr2;
+ NameRegistry *regPtr;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+
+ regPtr = RegOpen(riPtr->interp, riPtr->dispPtr, 1);
+ RegDeleteName(regPtr, riPtr->name);
+ RegClose(regPtr);
+
+ if (tsdPtr->interpListPtr == riPtr) {
+ tsdPtr->interpListPtr = riPtr->nextPtr;
+ } else {
+ for (riPtr2 = tsdPtr->interpListPtr; riPtr2 != NULL;
+ riPtr2 = riPtr2->nextPtr) {
+ if (riPtr2->nextPtr == riPtr) {
+ riPtr2->nextPtr = riPtr->nextPtr;
+ break;
+ }
+ }
+ }
+ ckfree(riPtr->name);
+ riPtr->interp = NULL;
+ UpdateCommWindow(riPtr->dispPtr);
+ Tcl_EventuallyFree(riPtr, TCL_DYNAMIC);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * SendRestrictProc --
+ *
+ * This function filters incoming events when a "send" command is
+ * outstanding. It defers all events except those containing send
+ * commands and results.
+ *
+ * Results:
+ * False is returned except for property-change events on a commWindow.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tk_RestrictAction
+SendRestrictProc(
+ TCL_UNUSED(void *), /* Not used. */
+ XEvent *eventPtr) /* Event that just arrived. */
+{
+ TkDisplay *dispPtr;
+
+ if (eventPtr->type != PropertyNotify) {
+ return TK_DEFER_EVENT;
+ }
+ for (dispPtr = TkGetDisplayList(); dispPtr != NULL;
+ dispPtr = dispPtr->nextPtr) {
+ if ((eventPtr->xany.display == dispPtr->display)
+ && (eventPtr->xproperty.window
+ == Tk_WindowId(dispPtr->commTkwin))) {
+ return TK_PROCESS_EVENT;
+ }
+ }
+ return TK_DEFER_EVENT;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateCommWindow --
+ *
+ * This function updates the list of application names stored on our
+ * commWindow. It is typically called when interpreters are registered
+ * and unregistered.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The TK_APPLICATION property on the comm window is updated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateCommWindow(
+ TkDisplay *dispPtr) /* Display whose commWindow is to be
+ * updated. */
+{
+ Tcl_DString names;
+ RegisteredInterp *riPtr;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+
+ Tcl_DStringInit(&names);
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
+ Tcl_DStringAppendElement(&names, riPtr->name);
+ }
+ XChangeProperty(dispPtr->display, Tk_WindowId(dispPtr->commTkwin),
+ dispPtr->appNameProperty, XA_STRING, 8, PropModeReplace,
+ (unsigned char *) Tcl_DStringValue(&names),
+ Tcl_DStringLength(&names));
+ Tcl_DStringFree(&names);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkpTestsendCmd --
+ *
+ * This function implements the "testsend" command. It provides a set of
+ * functions for testing the "send" command and support function in
+ * tkSend.c.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Depends on option; see below.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TkpTestsendCmd(
+ ClientData clientData, /* Main window for application. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument strings. */
+{
+ enum {
+ TESTSEND_BOGUS, TESTSEND_PROP, TESTSEND_SERIAL
+ };
+ static const char *const testsendOptions[] = {
+ "bogus", "prop", "serial", NULL
+ };
+ TkWindow *winPtr = (TkWindow *)clientData;
+ Tk_ErrorHandler handler;
+ int index;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "option ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObjStruct(interp, objv[1], testsendOptions,
+ sizeof(char *), "option", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (index == TESTSEND_BOGUS) {
+ handler = Tk_CreateErrorHandler(winPtr->dispPtr->display, -1, -1, -1,
+ NULL, NULL);
+ XChangeProperty(winPtr->dispPtr->display,
+ RootWindow(winPtr->dispPtr->display, 0),
+ winPtr->dispPtr->registryProperty, XA_INTEGER, 32,
+ PropModeReplace,
+ (unsigned char *) "This is bogus information", 6);
+ Tk_DeleteErrorHandler(handler);
+ } else if (index == TESTSEND_PROP) {
+ int result, actualFormat;
+ unsigned long length, bytesAfter;
+ Atom actualType, propName;
+ char *property, **propertyPtr = &property, *p, *end;
+ Window w;
+
+ if ((objc != 4) && (objc != 5)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "prop window name ?value ?");
+ return TCL_ERROR;
+ }
+ if (strcmp(Tcl_GetString(objv[2]), "root") == 0) {
+ w = RootWindow(winPtr->dispPtr->display, 0);
+ } else if (strcmp(Tcl_GetString(objv[2]), "comm") == 0) {
+ w = Tk_WindowId(winPtr->dispPtr->commTkwin);
+ } else {
+ w = strtoul(Tcl_GetString(objv[2]), &end, 0);
+ }
+ propName = Tk_InternAtom((Tk_Window) winPtr, Tcl_GetString(objv[3]));
+ if (objc == 4) {
+ property = NULL;
+ result = XGetWindowProperty(winPtr->dispPtr->display, w, propName,
+ 0, 100000, False, XA_STRING, &actualType, &actualFormat,
+ &length, &bytesAfter, (unsigned char **) propertyPtr);
+ if ((result == Success) && (actualType != None)
+ && (actualFormat == 8) && (actualType == XA_STRING)) {
+ for (p = property; (unsigned long)(p-property) < length; p++) {
+ if (*p == 0) {
+ *p = '\n';
+ }
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(property, -1));
+ }
+ if (property != NULL) {
+ XFree(property);
+ }
+ } else if (Tcl_GetString(objv[4])[0] == 0) {
+ handler = Tk_CreateErrorHandler(winPtr->dispPtr->display,
+ -1, -1, -1, NULL, NULL);
+ XDeleteProperty(winPtr->dispPtr->display, w, propName);
+ Tk_DeleteErrorHandler(handler);
+ } else {
+ Tcl_DString tmp;
+
+ Tcl_DStringInit(&tmp);
+ for (p = Tcl_DStringAppend(&tmp, Tcl_GetString(objv[4]),
+ (int) strlen(Tcl_GetString(objv[4]))); *p != 0; p++) {
+ if (*p == '\n') {
+ *p = 0;
+ }
+ }
+ handler = Tk_CreateErrorHandler(winPtr->dispPtr->display,
+ -1, -1, -1, NULL, NULL);
+ XChangeProperty(winPtr->dispPtr->display, w, propName, XA_STRING,
+ 8, PropModeReplace, (unsigned char*)Tcl_DStringValue(&tmp),
+ p-Tcl_DStringValue(&tmp));
+ Tk_DeleteErrorHandler(handler);
+ Tcl_DStringFree(&tmp);
+ }
+ } else if (index == TESTSEND_SERIAL) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(localData.sendSerial+1));
+ }
+ return TCL_OK;
+}
+\f
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
OSDN Git Service
