URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
[/] [or1k/] [tags/] [start/] [insight/] [tk/] [unix/] [tkUnixSend.c] - Rev 578
Go to most recent revision | Compare with Previous | Blame | View Log
/* * tkUnixSend.c -- * * This file provides procedures 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tkUnixSend.c,v 1.1.1.1 2002-01-16 10:26:01 markom Exp $ */ #include "tkPort.h" #include "tkInt.h" #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; static RegisteredInterp *registry = NULL; /* List of all interpreters * registered by this process. */ /* * 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. */ 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; static PendingCommand *pendingCommands = NULL; /* List of all commands currently * being waited for. */ /* * 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. */ /* * The following variable is the serial number that was used in the * last "send" command. It is exported only for testing purposes. */ int tkSendSerial = 0; /* * Maximum size property that can be read at one time by * this module: */ #define MAX_PROP_WORDS 100000 /* * The following variable can be set while debugging to do things like * skip locking the server. */ static int sendDebug = 0; /* * Forward declarations for procedures defined later in this file: */ static int AppendErrorProc _ANSI_ARGS_((ClientData clientData, XErrorEvent *errorPtr)); static void AppendPropCarefully _ANSI_ARGS_((Display *display, Window window, Atom property, char *value, int length, PendingCommand *pendingPtr)); static void DeleteProc _ANSI_ARGS_((ClientData clientData)); static void RegAddName _ANSI_ARGS_((NameRegistry *regPtr, char *name, Window commWindow)); static void RegClose _ANSI_ARGS_((NameRegistry *regPtr)); static void RegDeleteName _ANSI_ARGS_((NameRegistry *regPtr, char *name)); static Window RegFindName _ANSI_ARGS_((NameRegistry *regPtr, char *name)); static NameRegistry * RegOpen _ANSI_ARGS_((Tcl_Interp *interp, TkDisplay *dispPtr, int lock)); static void SendEventProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static int SendInit _ANSI_ARGS_((Tcl_Interp *interp, TkDisplay *dispPtr)); static Tk_RestrictAction SendRestrictProc _ANSI_ARGS_((ClientData clientData, XEvent *eventPtr)); static int ServerSecure _ANSI_ARGS_((TkDisplay *dispPtr)); static void UpdateCommWindow _ANSI_ARGS_((TkDisplay *dispPtr)); static int ValidateName _ANSI_ARGS_((TkDisplay *dispPtr, char *name, Window commWindow, int oldOK)); /* *---------------------------------------------------------------------- * * RegOpen -- * * This procedure 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 * neeeded, unlock the server if needed, and free memory. * *---------------------------------------------------------------------- */ static NameRegistry * RegOpen(interp, dispPtr, lock) 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; if (dispPtr->commTkwin == NULL) { SendInit(interp, dispPtr); } regPtr = (NameRegistry *) ckalloc(sizeof(NameRegistry)); regPtr->dispPtr = dispPtr; regPtr->locked = 0; regPtr->modified = 0; regPtr->allocedByX = 1; if (lock && !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 **) ®Ptr->property); 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 procedure 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(regPtr, name) NameRegistry *regPtr; /* Pointer to a registry opened with a * previous call to RegOpen. */ char *name; /* Name of an application. */ { char *p, *entry; unsigned int id; for (p = regPtr->property; (p-regPtr->property) < (int) regPtr->propLength; ) { entry = p; while ((*p != 0) && (!isspace(UCHAR(*p)))) { p++; } if ((*p != 0) && (strcmp(name, p+1) == 0)) { 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 procedure 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(regPtr, name) NameRegistry *regPtr; /* Pointer to a registry opened with a * previous call to RegOpen. */ char *name; /* Name of an application. */ { char *p, *entry, *entryName; int count; for (p = regPtr->property; (p-regPtr->property) < (int) regPtr->propLength; ) { entry = p; while ((*p != 0) && (!isspace(UCHAR(*p)))) { p++; } if (*p != 0) { p++; } entryName = p; while (*p != 0) { p++; } p++; if ((strcmp(name, entryName) == 0)) { /* * 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(regPtr, name, commWindow) NameRegistry *regPtr; /* Pointer to a registry opened with a * previous call to RegOpen. */ 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]; char *newProp; int idLength, newBytes; sprintf(id, "%x ", (unsigned int) commWindow); idLength = strlen(id); newBytes = idLength + strlen(name) + 1; newProp = (char *) ckalloc((unsigned) (regPtr->propLength + newBytes)); strcpy(newProp, id); strcpy(newProp+idLength, name); if (regPtr->property != NULL) { memcpy((VOID *) (newProp + newBytes), (VOID *) 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 procedure 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(regPtr) NameRegistry *regPtr; /* Pointer to a registry opened with a * previous call to RegOpen. */ { if (regPtr->modified) { if (!regPtr->locked && !sendDebug) { 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((char *) regPtr); } /* *---------------------------------------------------------------------- * * ValidateName -- * * This procedure 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(dispPtr, name, commWindow, oldOK) TkDisplay *dispPtr; /* Display for which to perform the * validation. */ 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; Tk_ErrorHandler handler; 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, (Tk_ErrorProc *) NULL, (ClientData) NULL); result = XGetWindowProperty(dispPtr->display, commWindow, dispPtr->appNameProperty, 0, MAX_PROP_WORDS, False, XA_STRING, &actualType, &actualFormat, &length, &bytesAfter, (unsigned char **) &property); 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((Tcl_Interp *) NULL, property, &argc, &argv) == TCL_OK) { for (i = 0; i < argc; i++) { if (strcmp(argv[i], name) == 0) { result = 1; break; } } ckfree((char *) 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(dispPtr) TkDisplay *dispPtr; /* Display to check. */ { #ifdef TK_NO_SECURITY return 1; #else XHostAddress *addrPtr; int numHosts, secure; Bool enabled; secure = 0; addrPtr = XListHosts(dispPtr->display, &numHosts, &enabled); if (enabled && (numHosts == 0)) { secure = 1; } if (addrPtr != NULL) { XFree((char *) addrPtr); } return secure; #endif /* TK_NO_SECURITY */ } /* *-------------------------------------------------------------- * * Tk_SetAppName -- * * This procedure 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. * *-------------------------------------------------------------- */ char * Tk_SetAppName(tkwin, name) Tk_Window tkwin; /* Token for any window in the application * to be named: it is just used to identify * the application and the display. */ 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; NameRegistry *regPtr; Tcl_Interp *interp; char *actualName; Tcl_DString dString; int offset, i; #ifdef __WIN32__ return name; #endif /* __WIN32__ */ dispPtr = winPtr->dispPtr; 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 = registry; ; 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 = registry; registry = riPtr; Tcl_CreateCommand(interp, "send", Tk_SendCmd, (ClientData) 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. */ 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+10); actualName = Tcl_DStringValue(&dString); } sprintf(actualName + 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 = registry; 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((unsigned) (strlen(actualName) + 1)); strcpy(riPtr->name, actualName); if (actualName != name) { Tcl_DStringFree(&dString); } UpdateCommWindow(dispPtr); return riPtr->name; } /* *-------------------------------------------------------------- * * Tk_SendCmd -- * * This procedure 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_SendCmd(clientData, interp, argc, argv) ClientData clientData; /* Information about sender (only * dispPtr field is used). */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { TkWindow *winPtr; Window commWindow; PendingCommand pending; register RegisteredInterp *riPtr; char *destName, buffer[30]; int result, c, async, i, firstArg; size_t length; Tk_RestrictProc *prevRestrictProc; ClientData prevArg; TkDisplay *dispPtr; Tcl_Time timeout; NameRegistry *regPtr; Tcl_DString request; 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 < (argc-1); ) { if (argv[i][0] != '-') { break; } c = argv[i][1]; length = strlen(argv[i]); if ((c == 'a') && (strncmp(argv[i], "-async", length) == 0)) { async = 1; i++; } else if ((c == 'd') && (strncmp(argv[i], "-displayof", length) == 0)) { winPtr = (TkWindow *) Tk_NameToWindow(interp, argv[i+1], (Tk_Window) winPtr); if (winPtr == NULL) { return TCL_ERROR; } i += 2; } else if (strcmp(argv[i], "--") == 0) { i++; break; } else { Tcl_AppendResult(interp, "bad option \"", argv[i], "\": must be -async, -displayof, or --", (char *) NULL); return TCL_ERROR; } } if (argc < (i+2)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?options? interpName arg ?arg ...?\"", (char *) NULL); return TCL_ERROR; } destName = argv[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 = registry; riPtr != NULL; riPtr = riPtr->nextPtr) { if ((riPtr->dispPtr != dispPtr) || (strcmp(riPtr->name, destName) != 0)) { continue; } Tcl_Preserve((ClientData) riPtr); localInterp = riPtr->interp; Tcl_Preserve((ClientData) localInterp); if (firstArg == (argc-1)) { result = Tcl_GlobalEval(localInterp, argv[firstArg]); } else { Tcl_DStringInit(&request); Tcl_DStringAppend(&request, argv[firstArg], -1); for (i = firstArg+1; i < argc; i++) { Tcl_DStringAppend(&request, " ", 1); Tcl_DStringAppend(&request, argv[i], -1); } result = Tcl_GlobalEval(localInterp, Tcl_DStringValue(&request)); Tcl_DStringFree(&request); } if (interp != localInterp) { if (result == TCL_ERROR) { /* * 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", (char *) NULL, TCL_GLOBAL_ONLY)); Tcl_SetVar2(interp, "errorCode", (char *) NULL, Tcl_GetVar2(localInterp, "errorCode", (char *) NULL, TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); } if (localInterp->freeProc != TCL_STATIC) { interp->result = localInterp->result; interp->freeProc = localInterp->freeProc; localInterp->freeProc = TCL_STATIC; } else { Tcl_SetResult(interp, localInterp->result, TCL_VOLATILE); } Tcl_ResetResult(localInterp); } Tcl_Release((ClientData) riPtr); Tcl_Release((ClientData) 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_AppendResult(interp, "no application named \"", destName, "\"", (char *) NULL); return TCL_ERROR; } /* * Send the command to the target interpreter by appending it to the * comm window in the communication window. */ tkSendSerial++; Tcl_DStringInit(&request); Tcl_DStringAppend(&request, "\0c\0-n ", 6); Tcl_DStringAppend(&request, destName, -1); if (!async) { sprintf(buffer, "%x %d", (unsigned int) Tk_WindowId(dispPtr->commTkwin), tkSendSerial); Tcl_DStringAppend(&request, "\0-r ", 4); Tcl_DStringAppend(&request, buffer, -1); } Tcl_DStringAppend(&request, "\0-s ", 4); Tcl_DStringAppend(&request, argv[firstArg], -1); for (i = firstArg+1; i < argc; i++) { Tcl_DStringAppend(&request, " ", 1); Tcl_DStringAppend(&request, argv[i], -1); } (void) AppendPropCarefully(dispPtr->display, commWindow, dispPtr->commProperty, Tcl_DStringValue(&request), Tcl_DStringLength(&request) + 1, (async) ? (PendingCommand *) 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 = tkSendSerial; 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 = pendingCommands; 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. */ prevRestrictProc = Tk_RestrictEvents(SendRestrictProc, (ClientData) NULL, &prevArg); TclpGetTime(&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)) { 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((unsigned) (strlen(msg) + 1)); strcpy(pending.result, msg); pending.gotResponse = 1; } else { TclpGetTime(&timeout); timeout.sec += 2; } } } (void) Tk_RestrictEvents(prevRestrictProc, prevArg, &prevArg); /* * Unregister the information about the pending command * and return the result. */ if (pendingCommands != &pending) { panic("Tk_SendCmd: corrupted send stack"); } 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_SetVar2(interp, "errorCode", (char *) NULL, pending.errorCode, TCL_GLOBAL_ONLY); ckfree(pending.errorCode); } Tcl_SetResult(interp, pending.result, TCL_DYNAMIC); return pending.code; } /* *---------------------------------------------------------------------- * * TkGetInterpNames -- * * This procedure 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. Interp->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 interp->result will hold an error message. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TkGetInterpNames(interp, tkwin) 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; char *p, *entry, *entryName; NameRegistry *regPtr; Window commWindow; int count; unsigned int id; /* * 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; ) { entry = p; if (sscanf(p, "%x",(unsigned int *) &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_AppendElement(interp, entryName); } else { /* * 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); return TCL_OK; } /* *-------------------------------------------------------------- * * SendInit -- * * This procedure 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(interp, dispPtr) 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_CreateWindow(interp, (Tk_Window) NULL, "_comm", DisplayString(dispPtr->display)); if (dispPtr->commTkwin == NULL) { panic("Tk_CreateWindow failed in SendInit!"); } atts.override_redirect = True; Tk_ChangeWindowAttributes(dispPtr->commTkwin, CWOverrideRedirect, &atts); Tk_CreateEventHandler(dispPtr->commTkwin, PropertyChangeMask, SendEventProc, (ClientData) 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 procedure is invoked automatically by the toolkit * event manager when a property changes on the communication * window. This procedure 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, eventPtr) ClientData clientData; /* Display information. */ XEvent *eventPtr; /* Information about event. */ { TkDisplay *dispPtr = (TkDisplay *) clientData; char *propInfo; register char *p; int result, actualFormat; unsigned long numItems, bytesAfter; Atom actualType; Tcl_Interp *remoteInterp; /* Interp in which to execute the command. */ 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 **) &propInfo); /* * 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; char *interpName, *script, *serial, *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 = registry; ; 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((ClientData) riPtr); /* * We must protect the interpreter because the script may * enter another event loop, which might call Tcl_DeleteInterp. */ remoteInterp = riPtr->interp; Tcl_Preserve((ClientData) remoteInterp); result = Tcl_GlobalEval(remoteInterp, script); /* * 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, remoteInterp->result, -1); if (result == TCL_ERROR) { char *varValue; varValue = Tcl_GetVar2(remoteInterp, "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY); if (varValue != NULL) { Tcl_DStringAppend(&reply, "\0-i ", 4); Tcl_DStringAppend(&reply, varValue, -1); } varValue = Tcl_GetVar2(remoteInterp, "errorCode", (char *) NULL, TCL_GLOBAL_ONLY); if (varValue != NULL) { Tcl_DStringAppend(&reply, "\0-e ", 4); Tcl_DStringAppend(&reply, varValue, -1); } } } Tcl_Release((ClientData) remoteInterp); Tcl_Release((ClientData) 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[20]; 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, (PendingCommand *) NULL); XFlush(dispPtr->display); Tcl_DStringFree(&reply); } } else if ((*p == 'r') && (p[1] == 0)) { int serial, code, gotSerial; 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 = pendingCommands; pcPtr != NULL; pcPtr = pcPtr->nextPtr) { if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) { continue; } pcPtr->code = code; if (resultString != NULL) { pcPtr->result = (char *) ckalloc((unsigned) (strlen(resultString) + 1)); strcpy(pcPtr->result, resultString); } if (code == TCL_ERROR) { if (errorInfo != NULL) { pcPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(errorInfo) + 1)); strcpy(pcPtr->errorInfo, errorInfo); } if (errorCode != NULL) { pcPtr->errorCode = (char *) ckalloc((unsigned) (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 * procedure 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, window, property, value, length, pendingPtr) 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, (ClientData) pendingPtr); XChangeProperty(display, window, property, XA_STRING, 8, PropModeAppend, (unsigned char *) value, length); Tk_DeleteErrorHandler(handler); } /* * The procedure below is invoked if an error occurs during * the XChangeProperty operation above. */ /* ARGSUSED */ static int AppendErrorProc(clientData, errorPtr) ClientData clientData; /* Command to mark complete, or NULL. */ XErrorEvent *errorPtr; /* Information about error. */ { PendingCommand *pendingPtr = (PendingCommand *) clientData; register PendingCommand *pcPtr; if (pendingPtr == NULL) { return 0; } /* * Make sure this command is still pending. */ for (pcPtr = pendingCommands; pcPtr != NULL; pcPtr = pcPtr->nextPtr) { if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) { pcPtr->result = (char *) ckalloc((unsigned) (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 procedure 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 clientData; /* Info about registration, passed * as ClientData. */ { RegisteredInterp *riPtr = (RegisteredInterp *) clientData; register RegisteredInterp *riPtr2; NameRegistry *regPtr; regPtr = RegOpen(riPtr->interp, riPtr->dispPtr, 1); RegDeleteName(regPtr, riPtr->name); RegClose(regPtr); if (registry == riPtr) { registry = riPtr->nextPtr; } else { for (riPtr2 = registry; riPtr2 != NULL; riPtr2 = riPtr2->nextPtr) { if (riPtr2->nextPtr == riPtr) { riPtr2->nextPtr = riPtr->nextPtr; break; } } } ckfree((char *) riPtr->name); riPtr->interp = NULL; UpdateCommWindow(riPtr->dispPtr); Tcl_EventuallyFree((ClientData) riPtr, TCL_DYNAMIC); } /* *---------------------------------------------------------------------- * * SendRestrictProc -- * * This procedure 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, eventPtr) ClientData clientData; /* Not used. */ register XEvent *eventPtr; /* Event that just arrived. */ { TkDisplay *dispPtr; if (eventPtr->type != PropertyNotify) { return TK_DEFER_EVENT; } for (dispPtr = tkDisplayList; 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 procedure 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(dispPtr) TkDisplay *dispPtr; /* Display whose commWindow is to be * updated. */ { Tcl_DString names; RegisteredInterp *riPtr; Tcl_DStringInit(&names); for (riPtr = registry; 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); }
Go to most recent revision | Compare with Previous | Blame | View Log