1/*
2 * tkMacOSXSend.c --
3 *
4 *	This file provides procedures that implement the "send" command,
5 *	allowing commands to be passed from interpreter to interpreter. This
6 *	current implementation for the Mac has most functionality stubed out.
7 *
8 *	The current plan, which we have not had time to implement, is for the
9 *	first Wish app to create a gestalt of type 'WIsH'. This gestalt will
10 *	point to a table, in system memory, of Tk apps. Each Tk app, when it
11 *	starts up, will register their name, and process ID, in this table.
12 *	This will allow us to implement "tk appname".
13 *
14 *	Then the send command will look up the process id of the target app in
15 *	this table, and send an AppleEvent to that process. The AppleEvent
16 *	handler is much like the do script handler, except that you have to
17 *	specify the name of the tk app as well, since there may be many
18 *	interps in one wish app, and you need to send it to the right one.
19 *
20 *	Implementing this has been on our list of things to do, but what with
21 *	the demise of Tcl at Sun, and the lack of resources at Scriptics it
22 *	may not get done for awhile. So this sketch is offered for the brave
23 *	to attempt if they need the functionality...
24 *
25 * Copyright (c) 1989-1994 The Regents of the University of California.
26 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
27 * Copyright 2001-2009, Apple Inc.
28 * Copyright (c) 2005-2009 Daniel A. Steffen <das@users.sourceforge.net>
29 *
30 * See the file "license.terms" for information on usage and redistribution
31 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
32 *
33 * RCS: @(#) $Id$
34 */
35
36#include "tkMacOSXInt.h"
37
38/*
39 * The following structure is used to keep track of the interpreters
40 * registered by this process.
41 */
42
43typedef struct RegisteredInterp {
44    char *name;			/* Interpreter's name (malloc-ed). */
45    Tcl_Interp *interp;		/* Interpreter associated with name. */
46    struct RegisteredInterp *nextPtr;
47				/* Next in list of names associated with
48				 * interps in this process. NULL means end of
49				 * list. */
50} RegisteredInterp;
51
52/*
53 * A registry of all interpreters for a display is kept in a property
54 * "InterpRegistry" on the root window of the display. It is organized as a
55 * series of zero or more concatenated strings (in no particular order), each
56 * of the form
57 *	window space name '\0'
58 * where "window" is the hex id of the comm. window to use to talk to an
59 * interpreter named "name".
60 *
61 * When the registry is being manipulated by an application (e.g. to add or
62 * remove an entry), it is loaded into memory using a structure of the
63 * following type:
64 */
65
66typedef struct NameRegistry {
67    TkDisplay *dispPtr;		/* Display from which the registry was
68				 * read. */
69    int locked;			/* Non-zero means that the display was locked
70				 * when the property was read in. */
71    int modified;		/* Non-zero means that the property has been
72				 * modified, so it needs to be written out
73				 * when the NameRegistry is closed. */
74    unsigned long propLength;	/* Length of the property, in bytes. */
75    char *property;		/* The contents of the property, or NULL if
76				 * none. See format description above; this is
77				 * *not* terminated by the first null
78				 * character. Dynamically allocated. */
79    int allocedByX;		/* Non-zero means must free property with
80				 * XFree; zero means use ckfree. */
81} NameRegistry;
82
83static int initialized = 0; /* A flag to denote if we have initialized
84				 * yet. */
85
86static RegisteredInterp *interpListPtr = NULL;
87				/* List of all interpreters registered by this
88				 * process. */
89
90/*
91 * The information below is used for communication between processes during
92 * "send" commands. Each process keeps a private window, never even mapped,
93 * with one property, "Comm". When a command is sent to an interpreter, the
94 * command is appended to the comm property of the communication window
95 * associated with the interp's process. Similarly, when a result is returned
96 * from a sent command, it is also appended to the comm property.
97 *
98 * Each command and each result takes the form of ASCII text. For a command,
99 * the text consists of a zero character followed by several null-terminated
100 * ASCII strings. The first string consists of the single letter "c".
101 * Subsequent strings have the form "option value" where the following options
102 * are supported:
103 *
104 * -r commWindow serial
105 *
106 *	This option means that a response should be sent to the window whose X
107 *	identifier is "commWindow" (in hex), and the response should be
108 *	identified with the serial number given by "serial" (in decimal). If
109 *	this option isn't specified then the send is asynchronous and no
110 *	response is sent.
111 *
112 * -n name
113 *
114 *	"Name" gives the name of the application for which the command is
115 *	intended. This option must be present.
116 *
117 * -s script
118 *
119 *	"Script" is the script to be executed. This option must be present.
120 *
121 * The options may appear in any order. The -n and -s options must be present,
122 * but -r may be omitted for asynchronous RPCs. For compatibility with future
123 * releases that may add new features, there may be additional options
124 * present; as long as they start with a "-" character, they will be ignored.
125 *
126 *
127 * A result also consists of a zero character followed by several null-
128 * terminated ASCII strings. The first string consists of the single letter
129 * "r". Subsequent strings have the form "option value" where the following
130 * options are supported:
131 *
132 * -s serial
133 *
134 *	Identifies the command for which this is the result. It is the same as
135 *	the "serial" field from the -s option in the command. This option must
136 *	be present.
137 *
138 * -c code
139 *
140 *	"Code" is the completion code for the script, in decimal. If the code
141 *	is omitted it defaults to TCL_OK.
142 *
143 * -r result
144 *
145 *	"Result" is the result string for the script, which may be either a
146 *	result or an error message. If this field is omitted then it defaults
147 *	to an empty string.
148 *
149 * -i errorInfo
150 *
151 *	"ErrorInfo" gives a string with which to initialize the errorInfo
152 *	variable. This option may be omitted; it is ignored unless the
153 *	completion code is TCL_ERROR.
154 *
155 * -e errorCode
156 *
157 *	"ErrorCode" gives a string with with to initialize the errorCode
158 *	variable. This option may be omitted; it is ignored unless the
159 *	completion code is TCL_ERROR.
160 *
161 * Options may appear in any order, and only the -s option must be present. As
162 * with commands, there may be additional options besides these; unknown
163 * options are ignored.
164 */
165
166/*
167 * Maximum size property that can be read at one time by this module:
168 */
169
170#define MAX_PROP_WORDS 100000
171
172/*
173 * Forward declarations for procedures defined later in this file:
174 */
175
176static int SendInit(Tcl_Interp *interp);
177
178/*
179 *--------------------------------------------------------------
180 *
181 * Tk_SetAppName --
182 *
183 *	This procedure is called to associate an ASCII name with a Tk
184 *	application. If the application has already been named, the name
185 *	replaces the old one.
186 *
187 * Results:
188 *	The return value is the name actually given to the application. This
189 *	will normally be the same as name, but if name was already in use for
190 *	an application then a name of the form "name #2" will be chosen, with
191 *	a high enough number to make the name unique.
192 *
193 * Side effects:
194 *	Registration info is saved, thereby allowing the "send" command to be
195 *	used later to invoke commands in the application. In addition, the
196 *	"send" command is created in the application's interpreter. The
197 *	registration will be removed automatically if the interpreter is
198 *	deleted or the "send" command is removed.
199 *
200 *--------------------------------------------------------------
201 */
202
203const char *
204Tk_SetAppName(
205    Tk_Window tkwin,		/* Token for any window in the application to
206				 * be named: it is just used to identify the
207				 * application and the display. */
208    const char *name)		/* The name that will be used to refer to the
209				 * interpreter in later "send" commands. Must
210				 * be globally unique. */
211{
212    TkWindow *winPtr = (TkWindow *) tkwin;
213    Tcl_Interp *interp = winPtr->mainPtr->interp;
214    int i, suffix, offset, result;
215    RegisteredInterp *riPtr, *prevPtr;
216    const char *actualName;
217    Tcl_DString dString;
218    Tcl_Obj *resultObjPtr, *interpNamePtr;
219    char *interpName;
220
221    if (!initialized) {
222	SendInit(interp);
223    }
224
225    /*
226     * See if the application is already registered; if so, remove its current
227     * name from the registry. The deletion of the command will take care of
228     * disposing of this entry.
229     */
230
231    for (riPtr = interpListPtr, prevPtr = NULL; riPtr != NULL;
232	    prevPtr = riPtr, riPtr = riPtr->nextPtr) {
233	if (riPtr->interp == interp) {
234	    if (prevPtr == NULL) {
235		interpListPtr = interpListPtr->nextPtr;
236	    } else {
237		prevPtr->nextPtr = riPtr->nextPtr;
238	    }
239	    break;
240	}
241    }
242
243    /*
244     * Pick a name to use for the application. Use "name" if it's not already
245     * in use. Otherwise add a suffix such as " #2", trying larger and larger
246     * numbers until we eventually find one that is unique.
247     */
248
249    actualName = name;
250    suffix = 1;
251    offset = 0;
252    Tcl_DStringInit(&dString);
253
254    TkGetInterpNames(interp, tkwin);
255    resultObjPtr = Tcl_GetObjResult(interp);
256    Tcl_IncrRefCount(resultObjPtr);
257    for (i = 0; ; ) {
258	result = Tcl_ListObjIndex(NULL, resultObjPtr, i, &interpNamePtr);
259	if (result != TCL_OK || interpNamePtr == NULL) {
260	    break;
261	}
262	interpName = Tcl_GetString(interpNamePtr);
263	if (strcmp(actualName, interpName) == 0) {
264	    if (suffix == 1) {
265		Tcl_DStringAppend(&dString, name, -1);
266		Tcl_DStringAppend(&dString, " #", 2);
267		offset = Tcl_DStringLength(&dString);
268		Tcl_DStringSetLength(&dString, offset + 10);
269		actualName = Tcl_DStringValue(&dString);
270	    }
271	    suffix++;
272	    sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix);
273	    i = 0;
274	} else {
275	    i++;
276	}
277    }
278
279    Tcl_DecrRefCount(resultObjPtr);
280    Tcl_ResetResult(interp);
281
282    /*
283     * We have found a unique name. Now add it to the registry.
284     */
285
286    riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
287    riPtr->interp = interp;
288    riPtr->name = ckalloc(strlen(actualName) + 1);
289    riPtr->nextPtr = interpListPtr;
290    interpListPtr = riPtr;
291    strcpy(riPtr->name, actualName);
292
293    /*
294     * TODO: DeleteProc
295     */
296
297    Tcl_CreateObjCommand(interp, "send", Tk_SendObjCmd, riPtr, NULL);
298    if (Tcl_IsSafe(interp)) {
299	Tcl_HideCommand(interp, "send", "send");
300    }
301    Tcl_DStringFree(&dString);
302
303    return riPtr->name;
304}
305
306/*
307 *--------------------------------------------------------------
308 *
309 * Tk_SendObjCmd --
310 *
311 *	This procedure is invoked to process the "send" Tcl command. See the
312 *	user documentation for details on what it does.
313 *
314 * Results:
315 *	A standard Tcl result.
316 *
317 * Side effects:
318 *	See the user documentation.
319 *
320 *--------------------------------------------------------------
321 */
322
323int
324Tk_SendObjCmd(
325    ClientData clientData,	/* Used only for deletion */
326    Tcl_Interp *interp,		/* The interp we are sending from */
327    int objc,			/* Number of arguments */
328    Tcl_Obj *const objv[])	/* The arguments */
329{
330    const char *sendOptions[] = {"-async", "-displayof", "-", NULL};
331    char *stringRep, *destName;
332    /*int async = 0;*/
333    int i, index, firstArg;
334    RegisteredInterp *riPtr;
335    Tcl_Obj *listObjPtr;
336    int result = TCL_OK;
337
338    for (i = 1; i < (objc - 1); ) {
339	stringRep = Tcl_GetString(objv[i]);
340	if (stringRep[0] == '-') {
341	    if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions, "option", 0,
342		    &index) != TCL_OK) {
343		return TCL_ERROR;
344	    }
345	    if (index == 0) {
346		/*async = 1;*/
347		i++;
348	    } else if (index == 1) {
349		i += 2;
350	    } else {
351		i++;
352	    }
353	} else {
354	    break;
355	}
356    }
357
358    if (objc < (i + 2)) {
359	Tcl_WrongNumArgs(interp, 1, objv,
360		"?-option value ...? interpName arg ?arg ...?");
361	return TCL_ERROR;
362    }
363
364    destName = Tcl_GetString(objv[i]);
365    firstArg = i + 1;
366
367    /*
368     * See if the target interpreter is local. If so, execute the command
369     * directly without going through the DDE server. The only tricky thing is
370     * passing the result from the target interpreter to the invoking
371     * interpreter. Watch out: they could be the same!
372     */
373
374    for (riPtr = interpListPtr; (riPtr != NULL)
375	    && (strcmp(destName, riPtr->name)); riPtr = riPtr->nextPtr) {
376	/*
377	 * Empty loop body.
378	 */
379    }
380
381    if (riPtr != NULL) {
382	/*
383	 * This command is to a local interp. No need to go through the
384	 * server.
385	 */
386
387	Tcl_Interp *localInterp;
388
389	Tcl_Preserve(riPtr);
390	localInterp = riPtr->interp;
391	Tcl_Preserve(localInterp);
392	if (firstArg == (objc - 1)) {
393	    /*
394	     * This might be one of those cases where the new parser is
395	     * faster.
396	     */
397
398	    result = Tcl_EvalObjEx(localInterp, objv[firstArg],
399		    TCL_EVAL_DIRECT);
400	} else {
401	    listObjPtr = Tcl_NewListObj(0, NULL);
402	    for (i = firstArg; i < objc; i++) {
403		Tcl_ListObjAppendList(interp, listObjPtr, objv[i]);
404	    }
405	    Tcl_IncrRefCount(listObjPtr);
406	    result = Tcl_EvalObjEx(localInterp, listObjPtr, TCL_EVAL_DIRECT);
407	    Tcl_DecrRefCount(listObjPtr);
408	}
409	if (interp != localInterp) {
410	    if (result == TCL_ERROR) {
411		/* Tcl_Obj *errorObjPtr; */
412
413		/*
414		 * An error occurred, so transfer error information from the
415		 * destination interpreter back to our interpreter. Must clear
416		 * interp's result before calling Tcl_AddErrorInfo, since
417		 * Tcl_AddErrorInfo will store the interp's result in
418		 * errorInfo before appending riPtr's $errorInfo; we've
419		 * already got everything we need in riPtr's $errorInfo.
420		 */
421
422		Tcl_ResetResult(interp);
423		Tcl_AddErrorInfo(interp, Tcl_GetVar2(localInterp,
424			"errorInfo", NULL, TCL_GLOBAL_ONLY));
425		/* errorObjPtr = Tcl_GetObjVar2(localInterp, "errorCode", NULL,
426			TCL_GLOBAL_ONLY);
427		Tcl_SetObjErrorCode(interp, errorObjPtr); */
428	    }
429	    Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp));
430	}
431	Tcl_Release(riPtr);
432	Tcl_Release(localInterp);
433    } else {
434	/*
435	 * TODO: This is a non-local request. Send the script to the server
436	 * and poll it for a result.
437	 */
438    }
439
440    return result;
441}
442
443/*
444 *----------------------------------------------------------------------
445 *
446 * TkGetInterpNames --
447 *
448 *	This procedure is invoked to fetch a list of all the interpreter names
449 *	currently registered for the display of a particular window.
450 *
451 * Results:
452 *	A standard Tcl return value. Interp->result will be set to hold a list
453 *	of all the interpreter names defined for tkwin's display. If an error
454 *	occurs, then TCL_ERROR is returned and interp->result will hold an
455 *	error message.
456 *
457 * Side effects:
458 *	None.
459 *
460 *----------------------------------------------------------------------
461 */
462
463int
464TkGetInterpNames(
465    Tcl_Interp *interp,		/* Interpreter for returning a result. */
466    Tk_Window tkwin)		/* Window whose display is to be used for the
467				 * lookup. */
468{
469    Tcl_Obj *listObjPtr;
470    RegisteredInterp *riPtr;
471
472    listObjPtr = Tcl_NewListObj(0, NULL);
473    riPtr = interpListPtr;
474    while (riPtr != NULL) {
475	Tcl_ListObjAppendElement(interp, listObjPtr,
476		Tcl_NewStringObj(riPtr->name, -1));
477	riPtr = riPtr->nextPtr;
478    }
479
480    Tcl_SetObjResult(interp, listObjPtr);
481    return TCL_OK;
482}
483
484/*
485 *--------------------------------------------------------------
486 *
487 * SendInit --
488 *
489 *	This procedure is called to initialize the communication channels for
490 *	sending commands and receiving results.
491 *
492 * Results:
493 *	None.
494 *
495 * Side effects:
496 *	Sets up various data structures and windows.
497 *
498 *--------------------------------------------------------------
499 */
500
501static int
502SendInit(
503    Tcl_Interp *interp)		/* Interpreter to use for error reporting (no
504				 * errors are ever returned, but the
505				 * interpreter is needed anyway). */
506{
507    return TCL_OK;
508}
509
510/*
511 * Local Variables:
512 * mode: c
513 * c-basic-offset: 4
514 * fill-column: 79
515 * coding: utf-8
516 * End:
517 */
518