diff options
Diffstat (limited to 'carbon/tkMacOSXSend.c')
| -rw-r--r-- | carbon/tkMacOSXSend.c | 506 |
1 files changed, 506 insertions, 0 deletions
diff --git a/carbon/tkMacOSXSend.c b/carbon/tkMacOSXSend.c new file mode 100644 index 0000000..df6b2af --- /dev/null +++ b/carbon/tkMacOSXSend.c @@ -0,0 +1,506 @@ +/* + * 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. + * Copyright (c) 2005-2007 Daniel A. Steffen <das@users.sourceforge.net> + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tkMacOSXInt.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. */ + 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. + */ + +/* + * 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(Tcl_Interp *interp); + +/* + *-------------------------------------------------------------- + * + * 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 (result != TCL_OK || interpNamePtr == NULL) { + break; + } + interpName = Tcl_GetString(interpNamePtr); + 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 = ckalloc(sizeof(RegisteredInterp)); + riPtr->interp = interp; + riPtr->name = ckalloc(strlen(actualName) + 1); + riPtr->nextPtr = interpListPtr; + interpListPtr = riPtr; + strcpy(riPtr->name, actualName); + + /* + * TODO: DeleteProc + */ + + Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr, NULL); + 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 *const sendOptions[] = {"-async", "-displayof", "-", NULL}; + char *stringRep, *destName; + /*int async = 0;*/ + int i, index, firstArg; + RegisteredInterp *riPtr; + Tcl_Obj *listObjPtr; + int result = TCL_OK; + + for (i = 1; i < (objc - 1); ) { + stringRep = Tcl_GetString(objv[i]); + 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, + "?-option value ...? interpName arg ?arg ...?"); + return TCL_ERROR; + } + + destName = Tcl_GetString(objv[i]); + firstArg = i + 1; + + /* + * 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(riPtr); + localInterp = riPtr->interp; + Tcl_Preserve(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, 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", 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(riPtr); + Tcl_Release(localInterp); + } else { + /* + * TODO: This is a non-local request. Send the script to the server + * and poll it for a result. + */ + } + + 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, 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; +} |