diff options
Diffstat (limited to 'mac/tkMacSend.c')
| -rw-r--r-- | mac/tkMacSend.c | 548 |
1 files changed, 0 insertions, 548 deletions
diff --git a/mac/tkMacSend.c b/mac/tkMacSend.c deleted file mode 100644 index e434d79..0000000 --- a/mac/tkMacSend.c +++ /dev/null @@ -1,548 +0,0 @@ -/* - * tkMacSend.c -- - * - * This file provides procedures that implement the "send" - * command, allowing commands to be passed from interpreter - * to interpreter. This current implementation for the Mac - * has most functionality stubed out. - * - * The current plan, which we have not had time to implement, is - * for the first Wish app to create a gestalt of type 'WIsH'. - * This gestalt will point to a table, in system memory, of - * Tk apps. Each Tk app, when it starts up, will register their - * name, and process ID, in this table. This will allow us to - * implement "tk appname". - * - * Then the send command will look up the process id of the target - * app in this table, and send an AppleEvent to that process. The - * AppleEvent handler is much like the do script handler, except that - * you have to specify the name of the tk app as well, since there may - * be many interps in one wish app, and you need to send it to the - * right one. - * - * Implementing this has been on our list of things to do, but what - * with the demise of Tcl at Sun, and the lack of resources at - * Scriptics it may not get done for awhile. So this sketch is - * offered for the brave to attempt if they need the functionality... - * - * Copyright (c) 1989-1994 The Regents of the University of California. - * Copyright (c) 1994-1998 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: tkMacSend.c,v 1.7 2002/10/09 11:56:54 das Exp $ - */ - -#include <Gestalt.h> -#include "tkPort.h" -#include "tkInt.h" - -EXTERN int Tk_SendObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); - - /* - * 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. */ - 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; - -static initialized = false; /* A flag to denote if we have initialized yet. */ - -static RegisteredInterp *interpListPtr = NULL; -/* List of all interpreters - * registered by this process. */ - - /* - * 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 - -/* - * Forward declarations for procedures defined later in this file: - */ - -static int AppendErrorProc _ANSI_ARGS_((ClientData clientData, - XErrorEvent *errorPtr)); -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, - TkWindow *winPtr, int lock)); -static void SendEventProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static int SendInit _ANSI_ARGS_((Tcl_Interp *interp)); -static Bool SendRestrictProc _ANSI_ARGS_((Display *display, - XEvent *eventPtr, char *arg)); -static int ServerSecure _ANSI_ARGS_((TkDisplay *dispPtr)); -static void TimeoutProc _ANSI_ARGS_((ClientData clientData)); -static int ValidateName _ANSI_ARGS_((TkDisplay *dispPtr, - char *name, Window commWindow, int oldOK)); - -/* - *-------------------------------------------------------------- - * - * 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. - * - *-------------------------------------------------------------- - */ - -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. */ -{ - TkWindow *winPtr = (TkWindow *) tkwin; - Tcl_Interp *interp = winPtr->mainPtr->interp; - int i, suffix, offset, result; - int createCommand = 0; - RegisteredInterp *riPtr, *prevPtr; - CONST char *actualName; - Tcl_DString dString; - Tcl_Obj *resultObjPtr, *interpNamePtr; - char *interpName; - - if (!initialized) { - SendInit(interp); - } - - /* - * See if the application is already registered; if so, remove its - * current name from the registry. The deletion of the command - * will take care of disposing of this entry. - */ - - for (riPtr = interpListPtr, prevPtr = NULL; riPtr != NULL; - prevPtr = riPtr, riPtr = riPtr->nextPtr) { - if (riPtr->interp == interp) { - if (prevPtr == NULL) { - interpListPtr = interpListPtr->nextPtr; - } else { - prevPtr->nextPtr = riPtr->nextPtr; - } - 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; - suffix = 1; - offset = 0; - Tcl_DStringInit(&dString); - - TkGetInterpNames(interp, tkwin); - resultObjPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(resultObjPtr); - for (i = 0; ; ) { - result = Tcl_ListObjIndex(NULL, resultObjPtr, i, &interpNamePtr); - if (interpNamePtr == NULL) { - break; - } - interpName = Tcl_GetStringFromObj(interpNamePtr, NULL); - if (strcmp(actualName, interpName) == 0) { - if (suffix == 1) { - Tcl_DStringAppend(&dString, name, -1); - Tcl_DStringAppend(&dString, " #", 2); - offset = Tcl_DStringLength(&dString); - Tcl_DStringSetLength(&dString, offset + 10); - actualName = Tcl_DStringValue(&dString); - } - suffix++; - sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix); - i = 0; - } else { - i++; - } - } - - Tcl_DecrRefCount(resultObjPtr); - Tcl_ResetResult(interp); - - /* - * We have found a unique name. Now add it to the registry. - */ - - riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); - riPtr->interp = interp; - riPtr->name = ckalloc(strlen(actualName) + 1); - riPtr->nextPtr = interpListPtr; - interpListPtr = riPtr; - strcpy(riPtr->name, actualName); - - Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, - (ClientData) riPtr, NULL /* TODO: DeleteProc */); - if (Tcl_IsSafe(interp)) { - Tcl_HideCommand(interp, "send", "send"); - } - Tcl_DStringFree(&dString); - - return riPtr->name; -} - -/* - *-------------------------------------------------------------- - * - * Tk_SendObjCmd -- - * - * 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_SendObjCmd( - ClientData clientData, /* Used only for deletion */ - Tcl_Interp *interp, /* The interp we are sending from */ - int objc, /* Number of arguments */ - Tcl_Obj *CONST objv[]) /* The arguments */ -{ - static CONST char *sendOptions[] = {"-async", "-displayof", "-", (char *) NULL}; - char *stringRep, *destName; - int async = 0; - int i, index, firstArg; - RegisteredInterp *riPtr; - Tcl_Obj *resultPtr, *listObjPtr; - int result; - - for (i = 1; i < (objc - 1); ) { - stringRep = Tcl_GetStringFromObj(objv[i], NULL); - if (stringRep[0] == '-') { - if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - if (index == 0) { - async = 1; - i++; - } else if (index == 1) { - i += 2; - } else { - i++; - } - } else { - break; - } - } - - if (objc < (i + 2)) { - Tcl_WrongNumArgs(interp, 1, objv, - "?options? interpName arg ?arg ...?"); - return TCL_ERROR; - } - - destName = Tcl_GetStringFromObj(objv[i], NULL); - firstArg = i + 1; - - resultPtr = Tcl_GetObjResult(interp); - - /* - * See if the target interpreter is local. If so, execute - * the command directly without going through the DDE 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 = interpListPtr; (riPtr != NULL) - && (strcmp(destName, riPtr->name)); riPtr = riPtr->nextPtr) { - /* - * Empty loop body. - */ - - } - - if (riPtr != NULL) { - /* - * This command is to a local interp. No need to go through - * the server. - */ - - Tcl_Interp *localInterp; - - Tcl_Preserve((ClientData) riPtr); - localInterp = riPtr->interp; - Tcl_Preserve((ClientData) localInterp); - if (firstArg == (objc - 1)) { - /* - * This might be one of those cases where the new - * parser is faster. - */ - - result = Tcl_EvalObjEx(localInterp, objv[firstArg], TCL_EVAL_DIRECT); - } else { - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (i = firstArg; i < objc; i++) { - Tcl_ListObjAppendList(interp, listObjPtr, objv[i]); - } - Tcl_IncrRefCount(listObjPtr); - result = Tcl_EvalObjEx(localInterp, listObjPtr, TCL_EVAL_DIRECT); - Tcl_DecrRefCount(listObjPtr); - } - 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", (char *) NULL, TCL_GLOBAL_ONLY)); - /* errorObjPtr = Tcl_GetObjVar2(localInterp, "errorCode", NULL, - TCL_GLOBAL_ONLY); - Tcl_SetObjErrorCode(interp, errorObjPtr); */ - } - Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp)); - } - Tcl_Release((ClientData) riPtr); - Tcl_Release((ClientData) localInterp); - } else { - /* - * This is a non-local request. Send the script to the server and poll - * it for a result. TODO!!! - */ - } - -done: - return result; -} - -/* - *---------------------------------------------------------------------- - * - * 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( - Tcl_Interp *interp, /* Interpreter for returning a result. */ - Tk_Window tkwin) /* Window whose display is to be used - * for the lookup. */ -{ - Tcl_Obj *listObjPtr; - RegisteredInterp *riPtr; - - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - riPtr = interpListPtr; - while (riPtr != NULL) { - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(riPtr->name, -1)); - riPtr = riPtr->nextPtr; - } - - Tcl_SetObjResult(interp, listObjPtr); - 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( - Tcl_Interp *interp) /* Interpreter to use for error reporting - * (no errors are ever returned, but the - * interpreter is needed anyway). */ -{ - return TCL_OK; -} |