backout tcl/tk 8.6.9

1 files changed, 515 insertions, 0 deletions

diff --git a/tk8.6/macosx/tkMacOSXSend.c b/tk8.6/macosx/tkMacOSXSend.c
new file mode 100644
index 0000000..3b24a56
--- /dev/null
+++ b/tk8.6/macosx/tkMacOSXSend.c
@@ -0,0 +1,515 @@
+/*
+ * 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-2009, Apple Inc.
+ * Copyright (c) 2005-2009 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 = 0; /* 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_GetIndexFromObjStruct(interp, objv[i], sendOptions,
+		    sizeof(char *), "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;
+}
+
+/*
+ * Local Variables:
+ * mode: objc
+ * c-basic-offset: 4
+ * fill-column: 79
+ * coding: utf-8
+ * End:
+ */