diff options
Diffstat (limited to 'macosx/tkMacOSXSend.c')
| -rw-r--r-- | macosx/tkMacOSXSend.c | 552 |
1 files changed, 552 insertions, 0 deletions
diff --git a/macosx/tkMacOSXSend.c b/macosx/tkMacOSXSend.c new file mode 100644 index 0000000..1647f75 --- /dev/null +++ b/macosx/tkMacOSXSend.c @@ -0,0 +1,552 @@ +/* + * tkMacOSXSend.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. + * Copyright 2001, Apple Computer, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tkMacOSXSend.c,v 1.2 2002/08/31 06:12:30 das Exp $ + */ + +#include <Carbon/Carbon.h> +/* +#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 int 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 SendInit _ANSI_ARGS_((Tcl_Interp *interp)); +/* +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 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; + 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 */ +{ + 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 = TCL_OK; + + 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!!! + */ + } + + 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; +} |