/*
* 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;
}