summaryrefslogtreecommitdiffstats
path: root/mac/tkMacSend.c
diff options
context:
space:
mode:
Diffstat (limited to 'mac/tkMacSend.c')
-rw-r--r--mac/tkMacSend.c330
1 files changed, 260 insertions, 70 deletions
diff --git a/mac/tkMacSend.c b/mac/tkMacSend.c
index 45a63bd..1bc27a4 100644
--- a/mac/tkMacSend.c
+++ b/mac/tkMacSend.c
@@ -6,18 +6,41 @@
* 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-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tkMacSend.c,v 1.2 1998/09/14 18:23:39 stanton Exp $
+ * RCS: @(#) $Id: tkMacSend.c,v 1.3 1999/04/16 01:51:32 stanton Exp $
*/
+#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.
@@ -27,17 +50,12 @@ typedef struct RegisteredInterp {
char *name; /* Interpreter's name (malloc-ed). */
Tcl_Interp *interp; /* Interpreter associated with
* name. */
- TkWindow *winPtr; /* Main window for the application. */
struct RegisteredInterp *nextPtr;
/* Next in list of names associated
* with interps in this process.
* NULL means end of list. */
} RegisteredInterp;
-static RegisteredInterp *registry = NULL;
-/* List of all interpreters
- * registered by this process. */
-
/*
* A registry of all interpreters for a display is kept in a
* property "InterpRegistry" on the root window of the display.
@@ -61,54 +79,19 @@ typedef struct NameRegistry {
* 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. See format
- * above; this is *not* terminated by the
- * first null character. Dynamically
- * allocated. */
+ 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;
- /*
- * When a result is being awaited from a sent command, one of
- * the following structures is present on a list of all outstanding
- * sent commands. The information in the structure is used to
- * process the result when it arrives. You're probably wondering
- * how there could ever be multiple outstanding sent commands.
- * This could happen if interpreters invoke each other recursively.
- * It's unlikely, but possible.
- */
+static initialized = false; /* A flag to denote if we have initialized yet. */
-typedef struct PendingCommand {
- int serial; /* Serial number expected in
- * result. */
- TkDisplay *dispPtr; /* Display being used for communication. */
- char *target; /* Name of interpreter command is
- * being sent to. */
- Window commWindow; /* Target's communication window. */
- Tk_TimerToken timeout; /* Token for timer handler used to check
- * up on target during long sends. */
- Tcl_Interp *interp; /* Interpreter from which the send
- * was invoked. */
- int code; /* Tcl return code for command
- * will be stored here. */
- char *result; /* String result for command (malloc'ed),
- * or NULL. */
- char *errorInfo; /* Information for "errorInfo" variable,
- * or NULL (malloc'ed). */
- char *errorCode; /* Information for "errorCode" variable,
- * or NULL (malloc'ed). */
- int gotResponse; /* 1 means a response has been received,
- * 0 means the command is still outstanding. */
- struct PendingCommand *nextPtr;
- /* Next in list of all outstanding
- * commands. NULL means end of
- * list. */
-} PendingCommand;
-
-static PendingCommand *pendingCommands = NULL;
-/* List of all commands currently
- * being waited for. */
+static RegisteredInterp *interpListPtr = NULL;
+/* List of all interpreters
+ * registered by this process. */
/*
* The information below is used for communication between processes
@@ -206,9 +189,6 @@ int tkSendSerial = 0;
static int AppendErrorProc _ANSI_ARGS_((ClientData clientData,
XErrorEvent *errorPtr));
-static void AppendPropCarefully _ANSI_ARGS_((Display *display,
- Window window, Atom property, char *value,
- int length, PendingCommand *pendingPtr));
static void DeleteProc _ANSI_ARGS_((ClientData clientData));
static void RegAddName _ANSI_ARGS_((NameRegistry *regPtr,
char *name, Window commWindow));
@@ -221,8 +201,7 @@ static NameRegistry * RegOpen _ANSI_ARGS_((Tcl_Interp *interp,
TkWindow *winPtr, int lock));
static void SendEventProc _ANSI_ARGS_((ClientData clientData,
XEvent *eventPtr));
-static int SendInit _ANSI_ARGS_((Tcl_Interp *interp,
- TkWindow *winPtr));
+static int SendInit _ANSI_ARGS_((Tcl_Interp *interp));
static Bool SendRestrictProc _ANSI_ARGS_((Display *display,
XEvent *eventPtr, char *arg));
static int ServerSecure _ANSI_ARGS_((TkDisplay *dispPtr));
@@ -265,13 +244,103 @@ Tk_SetAppName(
* "send" commands. Must be globally
* unique. */
{
- return name;
+ TkWindow *winPtr = (TkWindow *) tkwin;
+ Tcl_Interp *interp = winPtr->mainPtr->interp;
+ int i, suffix, offset, result;
+ int createCommand = 0;
+ RegisteredInterp *riPtr, *prevPtr;
+ 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(actualName + 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_SendCmd --
+ * Tk_SendObjCmd --
*
* This procedure is invoked to process the "send" Tcl command.
* See the user documentation for details on what it does.
@@ -286,15 +355,127 @@ Tk_SetAppName(
*/
int
-Tk_SendCmd(
- ClientData clientData, /* Information about sender (only
- * dispPtr field is used). */
- Tcl_Interp *interp, /* Current interpreter. */
- int argc, /* Number of arguments. */
- char **argv) /* Argument strings. */
+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 */
{
- Tcl_SetResult(interp, "Send not yet implemented", TCL_STATIC);
- return TCL_ERROR;
+ static char *sendOptions[] = {"-async", "-displayof", "-", (char *) NULL};
+ char *stringRep, *destName;
+ int async = 0;
+ int i, index, firstArg;
+ RegisteredInterp *riPtr;
+ Tcl_Obj *resultPtr, *listObjPtr;
+ int result;
+
+ 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_EvalObj(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_EvalObj(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!!!
+ */
+ }
+
+done:
+ return result;
}
/*
@@ -324,8 +505,19 @@ TkGetInterpNames(
Tk_Window tkwin) /* Window whose display is to be used
* for the lookup. */
{
- Tcl_SetResult(interp, "Send not yet implemented", TCL_STATIC);
- return TCL_ERROR;
+ 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;
}
/*
@@ -348,11 +540,9 @@ TkGetInterpNames(
static int
SendInit(
- Tcl_Interp *interp, /* Interpreter to use for error reporting
+ Tcl_Interp *interp) /* Interpreter to use for error reporting
* (no errors are ever returned, but the
* interpreter is needed anyway). */
- TkWindow *winPtr) /* Window that identifies the display to
- * initialize. */
{
return TCL_OK;
}