summaryrefslogtreecommitdiffstats
path: root/tk8.6/macosx/tkMacOSXSend.c
diff options
context:
space:
mode:
Diffstat (limited to 'tk8.6/macosx/tkMacOSXSend.c')
-rw-r--r--tk8.6/macosx/tkMacOSXSend.c515
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..8b65532
--- /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:
+ */
generated by cgit v0.12 at 2024-11-18 21:06:36 (GMT)