/* * 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 * * 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.8.2.1 2008/05/03 21:09:16 das Exp $ */ #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 (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 = (RegisteredInterp *) 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 *sendOptions[] = {"-async", "-displayof", "-", 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_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, "?options? interpName arg ?arg ...?"); return TCL_ERROR; } destName = Tcl_GetString(objv[i]); 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(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; }