summaryrefslogtreecommitdiffstats
path: root/tk8.6/unix/tkUnixSend.c
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2018-01-02 20:34:49 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2018-01-02 20:34:49 (GMT)
commit89c1ac99d375fbd73892aa659f06ef5e2c5ea56e (patch)
treee76ce80d68d11f1ea137bc33a42f71a1d1f32028 /tk8.6/unix/tkUnixSend.c
parent01e4cd2ef2ff59418766b2259fbc99771646aba6 (diff)
downloadblt-89c1ac99d375fbd73892aa659f06ef5e2c5ea56e.zip
blt-89c1ac99d375fbd73892aa659f06ef5e2c5ea56e.tar.gz
blt-89c1ac99d375fbd73892aa659f06ef5e2c5ea56e.tar.bz2
upgrade to tcl/tk 8.6.8
Diffstat (limited to 'tk8.6/unix/tkUnixSend.c')
-rw-r--r--tk8.6/unix/tkUnixSend.c2039
1 files changed, 0 insertions, 2039 deletions
diff --git a/tk8.6/unix/tkUnixSend.c b/tk8.6/unix/tkUnixSend.c
deleted file mode 100644
index bbbdd77..0000000
--- a/tk8.6/unix/tkUnixSend.c
+++ /dev/null
@@ -1,2039 +0,0 @@
-/*
- * 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 ThreadSpecificData {
- 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);
-
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-
- if (dispPtr->commTkwin == NULL) {
- SendInit(interp, dispPtr);
- }
-
- regPtr = ckalloc(sizeof(NameRegistry));
- regPtr->dispPtr = dispPtr;
- regPtr->locked = 0;
- regPtr->modified = 0;
- regPtr->allocedByX = 1;
- propertyPtr = &regPtr->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,
- &regPtr->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);
- }
-
- /*
- * 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- }
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 = 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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. */
-{
- 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);
-
- if (regPtr->property != NULL) {
- if (regPtr->allocedByX) {
- XFree(regPtr->property);
- } else {
- ckfree(regPtr->property);
- }
- }
- ckfree(regPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 */
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 =
- 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 = 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 = ckalloc(strlen(actualName) + 1);
- strcpy(riPtr->name, actualName);
- if (actualName != name) {
- Tcl_DStringFree(&dString);
- }
- UpdateCommWindow(dispPtr);
-
- return riPtr->name;
-}
-
-/*
- *--------------------------------------------------------------
- *
- * 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(
- ClientData clientData, /* 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;
- register 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 =
- 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);
- }
- (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;
- }
-
- /*
- * 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.
- */
-
- 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;
-
- /*
- * 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 = 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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;
-}
-
-/*
- *--------------------------------------------------------------
- *
- * 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;
- }
-}
-
-/*
- *--------------------------------------------------------------
- *
- * 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_Interp *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;
-}
-
-/*
- *--------------------------------------------------------------
- *
- * 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 = 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 =
- 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 = ckalloc(strlen(resultString) + 1);
- strcpy(pcPtr->result, resultString);
- }
- if (code == TCL_ERROR) {
- if (errorInfo != NULL) {
- pcPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
- strcpy(pcPtr->errorInfo, errorInfo);
- }
- if (errorCode != NULL) {
- pcPtr->errorCode = 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);
-}
-
-/*
- *--------------------------------------------------------------
- *
- * 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.
- */
-
- /* ARGSUSED */
-static int
-AppendErrorProc(
- ClientData clientData, /* Command to mark complete, or NULL. */
- XErrorEvent *errorPtr) /* Information about error. */
-{
- PendingCommand *pendingPtr = clientData;
- register PendingCommand *pcPtr;
- ThreadSpecificData *tsdPtr =
- 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 = ckalloc(strlen(pcPtr->target) + 50);
- sprintf(pcPtr->result, "no application named \"%s\"",
- pcPtr->target);
- pcPtr->code = TCL_ERROR;
- pcPtr->gotResponse = 1;
- break;
- }
- }
- return 0;
-}
-
-/*
- *--------------------------------------------------------------
- *
- * 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 = clientData;
- register RegisteredInterp *riPtr2;
- NameRegistry *regPtr;
- ThreadSpecificData *tsdPtr =
- 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);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-static Tk_RestrictAction
-SendRestrictProc(
- ClientData clientData, /* Not used. */
- register 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 =
- 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);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-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 = clientData;
- 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) {
- XChangeProperty(winPtr->dispPtr->display,
- RootWindow(winPtr->dispPtr->display, 0),
- winPtr->dispPtr->registryProperty, XA_INTEGER, 32,
- PropModeReplace,
- (unsigned char *) "This is bogus information", 6);
- } 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) {
- XDeleteProperty(winPtr->dispPtr->display, w, propName);
- } 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;
- }
- }
-
- XChangeProperty(winPtr->dispPtr->display, w, propName, XA_STRING,
- 8, PropModeReplace, (unsigned char*)Tcl_DStringValue(&tmp),
- p-Tcl_DStringValue(&tmp));
- Tcl_DStringFree(&tmp);
- }
- } else if (index == TESTSEND_SERIAL) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(localData.sendSerial+1));
- }
- return TCL_OK;
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */