diff options
Diffstat (limited to 'carbon/tkMacOSXSend.c')
| -rw-r--r-- | carbon/tkMacOSXSend.c | 506 |
1 files changed, 0 insertions, 506 deletions
diff --git a/carbon/tkMacOSXSend.c b/carbon/tkMacOSXSend.c deleted file mode 100644 index df6b2af..0000000 --- a/carbon/tkMacOSXSend.c +++ /dev/null @@ -1,506 +0,0 @@ -/* - * 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; -} |