path: root/macosx/tkMacOSXSend.c

/*
 * 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.
 *
 * RCS: @(#) $Id: tkMacOSXSend.c,v 1.2.2.3 2007/04/29 02:26:50 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);

    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", "-", 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((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", 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;
}