/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclinterp.c
ViewVC logotype

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclinterp.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (hide annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 7 months ago) by dashley
File MIME type: text/plain
File size: 71022 byte(s)
Adjust line endings to Windows style.
Set properties to expand the "Header" keyword.
Change header and footer.
1 dashley 64 /*$Header$ */
2 dashley 25 /*
3     * tclInterp.c --
4     *
5     * This file implements the "interp" command which allows creation
6     * and manipulation of Tcl interpreters from within Tcl scripts.
7     *
8     * Copyright (c) 1995-1997 Sun Microsystems, Inc.
9     *
10     * See the file "license.terms" for information on usage and redistribution
11     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12     *
13     * RCS: @(#) $Id: tclinterp.c,v 1.1.1.1 2001/06/13 04:40:36 dtashley Exp $
14     */
15    
16     #include <stdio.h>
17     #include "tclInt.h"
18     #include "tclPort.h"
19    
20     /*
21     * Counter for how many aliases were created (global)
22     */
23    
24     static int aliasCounter = 0;
25     TCL_DECLARE_MUTEX(cntMutex)
26    
27     /*
28     * struct Alias:
29     *
30     * Stores information about an alias. Is stored in the slave interpreter
31     * and used by the source command to find the target command in the master
32     * when the source command is invoked.
33     */
34    
35     typedef struct Alias {
36     Tcl_Obj *namePtr; /* Name of alias command in slave interp. */
37     Tcl_Interp *targetInterp; /* Interp in which target command will be
38     * invoked. */
39     Tcl_Obj *prefixPtr; /* Tcl list making up the prefix of the
40     * target command to be invoked in the target
41     * interpreter. Additional arguments
42     * specified when calling the alias in the
43     * slave interp will be appended to the prefix
44     * before the command is invoked. */
45     Tcl_Command slaveCmd; /* Source command in slave interpreter,
46     * bound to command that invokes the target
47     * command in the target interpreter. */
48     Tcl_HashEntry *aliasEntryPtr;
49     /* Entry for the alias hash table in slave.
50     * This is used by alias deletion to remove
51     * the alias from the slave interpreter
52     * alias table. */
53     Tcl_HashEntry *targetEntryPtr;
54     /* Entry for target command in master.
55     * This is used in the master interpreter to
56     * map back from the target command to aliases
57     * redirecting to it. Random access to this
58     * hash table is never required - we are using
59     * a hash table only for convenience. */
60     } Alias;
61    
62     /*
63     *
64     * struct Slave:
65     *
66     * Used by the "interp" command to record and find information about slave
67     * interpreters. Maps from a command name in the master to information about
68     * a slave interpreter, e.g. what aliases are defined in it.
69     */
70    
71     typedef struct Slave {
72     Tcl_Interp *masterInterp; /* Master interpreter for this slave. */
73     Tcl_HashEntry *slaveEntryPtr;
74     /* Hash entry in masters slave table for
75     * this slave interpreter. Used to find
76     * this record, and used when deleting the
77     * slave interpreter to delete it from the
78     * master's table. */
79     Tcl_Interp *slaveInterp; /* The slave interpreter. */
80     Tcl_Command interpCmd; /* Interpreter object command. */
81     Tcl_HashTable aliasTable; /* Table which maps from names of commands
82     * in slave interpreter to struct Alias
83     * defined below. */
84     } Slave;
85    
86     /*
87     * struct Target:
88     *
89     * Maps from master interpreter commands back to the source commands in slave
90     * interpreters. This is needed because aliases can be created between sibling
91     * interpreters and must be deleted when the target interpreter is deleted. In
92     * case they would not be deleted the source interpreter would be left with a
93     * "dangling pointer". One such record is stored in the Master record of the
94     * master interpreter (in the targetTable hashtable, see below) with the
95     * master for each alias which directs to a command in the master. These
96     * records are used to remove the source command for an from a slave if/when
97     * the master is deleted.
98     */
99    
100     typedef struct Target {
101     Tcl_Command slaveCmd; /* Command for alias in slave interp. */
102     Tcl_Interp *slaveInterp; /* Slave Interpreter. */
103     } Target;
104    
105     /*
106     * struct Master:
107     *
108     * This record is used for two purposes: First, slaveTable (a hashtable)
109     * maps from names of commands to slave interpreters. This hashtable is
110     * used to store information about slave interpreters of this interpreter,
111     * to map over all slaves, etc. The second purpose is to store information
112     * about all aliases in slaves (or siblings) which direct to target commands
113     * in this interpreter (using the targetTable hashtable).
114     *
115     * NB: the flags field in the interp structure, used with SAFE_INTERP
116     * mask denotes whether the interpreter is safe or not. Safe
117     * interpreters have restricted functionality, can only create safe slave
118     * interpreters and can only load safe extensions.
119     */
120    
121     typedef struct Master {
122     Tcl_HashTable slaveTable; /* Hash table for slave interpreters.
123     * Maps from command names to Slave records. */
124     Tcl_HashTable targetTable; /* Hash table for Target Records. Contains
125     * all Target records which denote aliases
126     * from slaves or sibling interpreters that
127     * direct to commands in this interpreter. This
128     * table is used to remove dangling pointers
129     * from the slave (or sibling) interpreters
130     * when this interpreter is deleted. */
131     } Master;
132    
133     /*
134     * The following structure keeps track of all the Master and Slave information
135     * on a per-interp basis.
136     */
137    
138     typedef struct InterpInfo {
139     Master master; /* Keeps track of all interps for which this
140     * interp is the Master. */
141     Slave slave; /* Information necessary for this interp to
142     * function as a slave. */
143     } InterpInfo;
144    
145     /*
146     * Prototypes for local static procedures:
147     */
148    
149     static int AliasCreate _ANSI_ARGS_((Tcl_Interp *interp,
150     Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp,
151     Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc,
152     Tcl_Obj *CONST objv[]));
153     static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp,
154     Tcl_Interp *slaveInterp, Tcl_Obj *namePtr));
155     static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp,
156     Tcl_Interp *slaveInterp, Tcl_Obj *objPtr));
157     static int AliasList _ANSI_ARGS_((Tcl_Interp *interp,
158     Tcl_Interp *slaveInterp));
159     static int AliasObjCmd _ANSI_ARGS_((ClientData dummy,
160     Tcl_Interp *currentInterp, int objc,
161     Tcl_Obj *CONST objv[]));
162     static void AliasObjCmdDeleteProc _ANSI_ARGS_((
163     ClientData clientData));
164    
165     static Tcl_Interp * GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
166     Tcl_Obj *pathPtr));
167     static Tcl_Interp * GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc,
168     Tcl_Obj *CONST objv[]));
169     static void InterpInfoDeleteProc _ANSI_ARGS_((
170     ClientData clientData, Tcl_Interp *interp));
171     static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp,
172     Tcl_Obj *pathPtr, int safe));
173     static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp,
174     Tcl_Interp *slaveInterp, int objc,
175     Tcl_Obj *CONST objv[]));
176     static int SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp,
177     Tcl_Interp *slaveInterp, int objc,
178     Tcl_Obj *CONST objv[]));
179     static int SlaveHide _ANSI_ARGS_((Tcl_Interp *interp,
180     Tcl_Interp *slaveInterp, int objc,
181     Tcl_Obj *CONST objv[]));
182     static int SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp,
183     Tcl_Interp *slaveInterp));
184     static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp,
185     Tcl_Interp *slaveInterp, int global, int objc,
186     Tcl_Obj *CONST objv[]));
187     static int SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp,
188     Tcl_Interp *slaveInterp));
189     static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy,
190     Tcl_Interp *interp, int objc,
191     Tcl_Obj *CONST objv[]));
192     static void SlaveObjCmdDeleteProc _ANSI_ARGS_((
193     ClientData clientData));
194    
195     /*
196     *---------------------------------------------------------------------------
197     *
198     * TclInterpInit --
199     *
200     * Initializes the invoking interpreter for using the master, slave
201     * and safe interp facilities. This is called from inside
202     * Tcl_CreateInterp().
203     *
204     * Results:
205     * Always returns TCL_OK for backwards compatibility.
206     *
207     * Side effects:
208     * Adds the "interp" command to an interpreter and initializes the
209     * interpInfoPtr field of the invoking interpreter.
210     *
211     *---------------------------------------------------------------------------
212     */
213    
214     int
215     TclInterpInit(interp)
216     Tcl_Interp *interp; /* Interpreter to initialize. */
217     {
218     InterpInfo *interpInfoPtr;
219     Master *masterPtr;
220     Slave *slavePtr;
221    
222     interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
223     ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr;
224    
225     masterPtr = &interpInfoPtr->master;
226     Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
227     Tcl_InitHashTable(&masterPtr->targetTable, TCL_ONE_WORD_KEYS);
228    
229     slavePtr = &interpInfoPtr->slave;
230     slavePtr->masterInterp = NULL;
231     slavePtr->slaveEntryPtr = NULL;
232     slavePtr->slaveInterp = interp;
233     slavePtr->interpCmd = NULL;
234     Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
235    
236     Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL);
237    
238     Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
239     return TCL_OK;
240     }
241    
242     /*
243     *---------------------------------------------------------------------------
244     *
245     * InterpInfoDeleteProc --
246     *
247     * Invoked when an interpreter is being deleted. It releases all
248     * storage used by the master/slave/safe interpreter facilities.
249     *
250     * Results:
251     * None.
252     *
253     * Side effects:
254     * Cleans up storage. Sets the interpInfoPtr field of the interp
255     * to NULL.
256     *
257     *---------------------------------------------------------------------------
258     */
259    
260     static void
261     InterpInfoDeleteProc(clientData, interp)
262     ClientData clientData; /* Ignored. */
263     Tcl_Interp *interp; /* Interp being deleted. All commands for
264     * slave interps should already be deleted. */
265     {
266     InterpInfo *interpInfoPtr;
267     Slave *slavePtr;
268     Master *masterPtr;
269     Tcl_HashSearch hSearch;
270     Tcl_HashEntry *hPtr;
271     Target *targetPtr;
272    
273     interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
274    
275     /*
276     * There shouldn't be any commands left.
277     */
278    
279     masterPtr = &interpInfoPtr->master;
280     if (masterPtr->slaveTable.numEntries != 0) {
281     panic("InterpInfoDeleteProc: still exist commands");
282     }
283     Tcl_DeleteHashTable(&masterPtr->slaveTable);
284    
285     /*
286     * Tell any interps that have aliases to this interp that they should
287     * delete those aliases. If the other interp was already dead, it
288     * would have removed the target record already.
289     */
290    
291     hPtr = Tcl_FirstHashEntry(&masterPtr->targetTable, &hSearch);
292     while (hPtr != NULL) {
293     targetPtr = (Target *) Tcl_GetHashValue(hPtr);
294     Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
295     targetPtr->slaveCmd);
296     hPtr = Tcl_NextHashEntry(&hSearch);
297     }
298     Tcl_DeleteHashTable(&masterPtr->targetTable);
299    
300     slavePtr = &interpInfoPtr->slave;
301     if (slavePtr->interpCmd != NULL) {
302     /*
303     * Tcl_DeleteInterp() was called on this interpreter, rather
304     * "interp delete" or the equivalent deletion of the command in the
305     * master. First ensure that the cleanup callback doesn't try to
306     * delete the interp again.
307     */
308    
309     slavePtr->slaveInterp = NULL;
310     Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
311     slavePtr->interpCmd);
312     }
313    
314     /*
315     * There shouldn't be any aliases left.
316     */
317    
318     if (slavePtr->aliasTable.numEntries != 0) {
319     panic("InterpInfoDeleteProc: still exist aliases");
320     }
321     Tcl_DeleteHashTable(&slavePtr->aliasTable);
322    
323     ckfree((char *) interpInfoPtr);
324     }
325    
326     /*
327     *----------------------------------------------------------------------
328     *
329     * Tcl_InterpObjCmd --
330     *
331     * This procedure is invoked to process the "interp" Tcl command.
332     * See the user documentation for details on what it does.
333     *
334     * Results:
335     * A standard Tcl result.
336     *
337     * Side effects:
338     * See the user documentation.
339     *
340     *----------------------------------------------------------------------
341     */
342     /* ARGSUSED */
343     int
344     Tcl_InterpObjCmd(clientData, interp, objc, objv)
345     ClientData clientData; /* Unused. */
346     Tcl_Interp *interp; /* Current interpreter. */
347     int objc; /* Number of arguments. */
348     Tcl_Obj *CONST objv[]; /* Argument objects. */
349     {
350     int index;
351     static char *options[] = {
352     "alias", "aliases", "create", "delete",
353     "eval", "exists", "expose", "hide",
354     "hidden", "issafe", "invokehidden", "marktrusted",
355     "slaves", "share", "target", "transfer",
356     NULL
357     };
358     enum option {
359     OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE,
360     OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
361     OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_MARKTRUSTED,
362     OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER
363     };
364    
365    
366     if (objc < 2) {
367     Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
368     return TCL_ERROR;
369     }
370     if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
371     &index) != TCL_OK) {
372     return TCL_ERROR;
373     }
374     switch ((enum option) index) {
375     case OPT_ALIAS: {
376     Tcl_Interp *slaveInterp, *masterInterp;
377    
378     if (objc < 4) {
379     aliasArgs:
380     Tcl_WrongNumArgs(interp, 2, objv,
381     "slavePath slaveCmd ?masterPath masterCmd? ?args ..?");
382     return TCL_ERROR;
383     }
384     slaveInterp = GetInterp(interp, objv[2]);
385     if (slaveInterp == (Tcl_Interp *) NULL) {
386     return TCL_ERROR;
387     }
388     if (objc == 4) {
389     return AliasDescribe(interp, slaveInterp, objv[3]);
390     }
391     if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) {
392     return AliasDelete(interp, slaveInterp, objv[3]);
393     }
394     if (objc > 5) {
395     masterInterp = GetInterp(interp, objv[4]);
396     if (masterInterp == (Tcl_Interp *) NULL) {
397     return TCL_ERROR;
398     }
399     if (Tcl_GetString(objv[5])[0] == '\0') {
400     if (objc == 6) {
401     return AliasDelete(interp, slaveInterp, objv[3]);
402     }
403     } else {
404     return AliasCreate(interp, slaveInterp, masterInterp,
405     objv[3], objv[5], objc - 6, objv + 6);
406     }
407     }
408     goto aliasArgs;
409     }
410     case OPT_ALIASES: {
411     Tcl_Interp *slaveInterp;
412    
413     slaveInterp = GetInterp2(interp, objc, objv);
414     if (slaveInterp == NULL) {
415     return TCL_ERROR;
416     }
417     return AliasList(interp, slaveInterp);
418     }
419     case OPT_CREATE: {
420     int i, last, safe;
421     Tcl_Obj *slavePtr;
422     char buf[16 + TCL_INTEGER_SPACE];
423     static char *options[] = {
424     "-safe", "--", NULL
425     };
426     enum option {
427     OPT_SAFE, OPT_LAST
428     };
429    
430     safe = Tcl_IsSafe(interp);
431    
432     /*
433     * Weird historical rules: "-safe" is accepted at the end, too.
434     */
435    
436     slavePtr = NULL;
437     last = 0;
438     for (i = 2; i < objc; i++) {
439     if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
440     if (Tcl_GetIndexFromObj(interp, objv[i], options, "option",
441     0, &index) != TCL_OK) {
442     return TCL_ERROR;
443     }
444     if (index == OPT_SAFE) {
445     safe = 1;
446     continue;
447     }
448     i++;
449     last = 1;
450     }
451     if (slavePtr != NULL) {
452     Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
453     return TCL_ERROR;
454     }
455     slavePtr = objv[i];
456     }
457     buf[0] = '\0';
458     if (slavePtr == NULL) {
459     /*
460     * Create an anonymous interpreter -- we choose its name and
461     * the name of the command. We check that the command name
462     * that we use for the interpreter does not collide with an
463     * existing command in the master interpreter.
464     */
465    
466     for (i = 0; ; i++) {
467     Tcl_CmdInfo cmdInfo;
468    
469     sprintf(buf, "interp%d", i);
470     if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
471     break;
472     }
473     }
474     slavePtr = Tcl_NewStringObj(buf, -1);
475     }
476     if (SlaveCreate(interp, slavePtr, safe) == NULL) {
477     if (buf[0] != '\0') {
478     Tcl_DecrRefCount(slavePtr);
479     }
480     return TCL_ERROR;
481     }
482     Tcl_SetObjResult(interp, slavePtr);
483     return TCL_OK;
484     }
485     case OPT_DELETE: {
486     int i;
487     InterpInfo *iiPtr;
488     Tcl_Interp *slaveInterp;
489    
490     for (i = 2; i < objc; i++) {
491     slaveInterp = GetInterp(interp, objv[i]);
492     if (slaveInterp == NULL) {
493     return TCL_ERROR;
494     } else if (slaveInterp == interp) {
495     Tcl_ResetResult(interp);
496     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
497     "cannot delete the current interpreter",
498     (char *) NULL);
499     return TCL_ERROR;
500     }
501     iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
502     Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
503     iiPtr->slave.interpCmd);
504     }
505     return TCL_OK;
506     }
507     case OPT_EVAL: {
508     Tcl_Interp *slaveInterp;
509    
510     if (objc < 4) {
511     Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
512     return TCL_ERROR;
513     }
514     slaveInterp = GetInterp(interp, objv[2]);
515     if (slaveInterp == NULL) {
516     return TCL_ERROR;
517     }
518     return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
519     }
520     case OPT_EXISTS: {
521     int exists;
522     Tcl_Interp *slaveInterp;
523    
524     exists = 1;
525     slaveInterp = GetInterp2(interp, objc, objv);
526     if (slaveInterp == NULL) {
527     if (objc > 3) {
528     return TCL_ERROR;
529     }
530     Tcl_ResetResult(interp);
531     exists = 0;
532     }
533     Tcl_SetIntObj(Tcl_GetObjResult(interp), exists);
534     return TCL_OK;
535     }
536     case OPT_EXPOSE: {
537     Tcl_Interp *slaveInterp;
538    
539     if ((objc < 4) || (objc > 5)) {
540     Tcl_WrongNumArgs(interp, 2, objv,
541     "path hiddenCmdName ?cmdName?");
542     return TCL_ERROR;
543     }
544     slaveInterp = GetInterp(interp, objv[2]);
545     if (slaveInterp == NULL) {
546     return TCL_ERROR;
547     }
548     return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
549     }
550     case OPT_HIDE: {
551     Tcl_Interp *slaveInterp; /* A slave. */
552    
553     if ((objc < 4) || (objc > 5)) {
554     Tcl_WrongNumArgs(interp, 2, objv,
555     "path cmdName ?hiddenCmdName?");
556     return TCL_ERROR;
557     }
558     slaveInterp = GetInterp(interp, objv[2]);
559     if (slaveInterp == (Tcl_Interp *) NULL) {
560     return TCL_ERROR;
561     }
562     return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
563     }
564     case OPT_HIDDEN: {
565     Tcl_Interp *slaveInterp; /* A slave. */
566    
567     slaveInterp = GetInterp2(interp, objc, objv);
568     if (slaveInterp == NULL) {
569     return TCL_ERROR;
570     }
571     return SlaveHidden(interp, slaveInterp);
572     }
573     case OPT_ISSAFE: {
574     Tcl_Interp *slaveInterp;
575    
576     slaveInterp = GetInterp2(interp, objc, objv);
577     if (slaveInterp == NULL) {
578     return TCL_ERROR;
579     }
580     Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
581     return TCL_OK;
582     }
583     case OPT_INVOKEHID: {
584     int i, index, global;
585     Tcl_Interp *slaveInterp;
586     static char *hiddenOptions[] = {
587     "-global", "--", NULL
588     };
589     enum hiddenOption {
590     OPT_GLOBAL, OPT_LAST
591     };
592    
593     global = 0;
594     for (i = 3; i < objc; i++) {
595     if (Tcl_GetString(objv[i])[0] != '-') {
596     break;
597     }
598     if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
599     "option", 0, &index) != TCL_OK) {
600     return TCL_ERROR;
601     }
602     if (index == OPT_GLOBAL) {
603     global = 1;
604     } else {
605     i++;
606     break;
607     }
608     }
609     if (objc - i < 1) {
610     Tcl_WrongNumArgs(interp, 2, objv,
611     "path ?-global? ?--? cmd ?arg ..?");
612     return TCL_ERROR;
613     }
614     slaveInterp = GetInterp(interp, objv[2]);
615     if (slaveInterp == (Tcl_Interp *) NULL) {
616     return TCL_ERROR;
617     }
618     return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
619     objv + i);
620     }
621     case OPT_MARKTRUSTED: {
622     Tcl_Interp *slaveInterp;
623    
624     if (objc != 3) {
625     Tcl_WrongNumArgs(interp, 2, objv, "path");
626     return TCL_ERROR;
627     }
628     slaveInterp = GetInterp(interp, objv[2]);
629     if (slaveInterp == NULL) {
630     return TCL_ERROR;
631     }
632     return SlaveMarkTrusted(interp, slaveInterp);
633     }
634     case OPT_SLAVES: {
635     Tcl_Interp *slaveInterp;
636     InterpInfo *iiPtr;
637     Tcl_Obj *resultPtr;
638     Tcl_HashEntry *hPtr;
639     Tcl_HashSearch hashSearch;
640     char *string;
641    
642     slaveInterp = GetInterp2(interp, objc, objv);
643     if (slaveInterp == NULL) {
644     return TCL_ERROR;
645     }
646     iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
647     resultPtr = Tcl_GetObjResult(interp);
648     hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
649     for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
650     string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
651     Tcl_ListObjAppendElement(NULL, resultPtr,
652     Tcl_NewStringObj(string, -1));
653     }
654     return TCL_OK;
655     }
656     case OPT_SHARE: {
657     Tcl_Interp *slaveInterp; /* A slave. */
658     Tcl_Interp *masterInterp; /* Its master. */
659     Tcl_Channel chan;
660    
661     if (objc != 5) {
662     Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
663     return TCL_ERROR;
664     }
665     masterInterp = GetInterp(interp, objv[2]);
666     if (masterInterp == NULL) {
667     return TCL_ERROR;
668     }
669     chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]),
670     NULL);
671     if (chan == NULL) {
672     TclTransferResult(masterInterp, TCL_OK, interp);
673     return TCL_ERROR;
674     }
675     slaveInterp = GetInterp(interp, objv[4]);
676     if (slaveInterp == NULL) {
677     return TCL_ERROR;
678     }
679     Tcl_RegisterChannel(slaveInterp, chan);
680     return TCL_OK;
681     }
682     case OPT_TARGET: {
683     Tcl_Interp *slaveInterp;
684     InterpInfo *iiPtr;
685     Tcl_HashEntry *hPtr;
686     Alias *aliasPtr;
687     char *aliasName;
688    
689     if (objc != 4) {
690     Tcl_WrongNumArgs(interp, 2, objv, "path alias");
691     return TCL_ERROR;
692     }
693    
694     slaveInterp = GetInterp(interp, objv[2]);
695     if (slaveInterp == NULL) {
696     return TCL_ERROR;
697     }
698    
699     aliasName = Tcl_GetString(objv[3]);
700    
701     iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
702     hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
703     if (hPtr == NULL) {
704     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
705     "alias \"", aliasName, "\" in path \"",
706     Tcl_GetString(objv[2]), "\" not found",
707     (char *) NULL);
708     return TCL_ERROR;
709     }
710     aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
711     if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
712     Tcl_ResetResult(interp);
713     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
714     "target interpreter for alias \"", aliasName,
715     "\" in path \"", Tcl_GetString(objv[2]),
716     "\" is not my descendant", (char *) NULL);
717     return TCL_ERROR;
718     }
719     return TCL_OK;
720     }
721     case OPT_TRANSFER: {
722     Tcl_Interp *slaveInterp; /* A slave. */
723     Tcl_Interp *masterInterp; /* Its master. */
724     Tcl_Channel chan;
725    
726     if (objc != 5) {
727     Tcl_WrongNumArgs(interp, 2, objv,
728     "srcPath channelId destPath");
729     return TCL_ERROR;
730     }
731     masterInterp = GetInterp(interp, objv[2]);
732     if (masterInterp == NULL) {
733     return TCL_ERROR;
734     }
735     chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
736     if (chan == NULL) {
737     TclTransferResult(masterInterp, TCL_OK, interp);
738     return TCL_ERROR;
739     }
740     slaveInterp = GetInterp(interp, objv[4]);
741     if (slaveInterp == NULL) {
742     return TCL_ERROR;
743     }
744     Tcl_RegisterChannel(slaveInterp, chan);
745     if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
746     TclTransferResult(masterInterp, TCL_OK, interp);
747     return TCL_ERROR;
748     }
749     return TCL_OK;
750     }
751     }
752     return TCL_OK;
753     }
754    
755     /*
756     *---------------------------------------------------------------------------
757     *
758     * GetInterp2 --
759     *
760     * Helper function for Tcl_InterpObjCmd() to convert the interp name
761     * potentially specified on the command line to an Tcl_Interp.
762     *
763     * Results:
764     * The return value is the interp specified on the command line,
765     * or the interp argument itself if no interp was specified on the
766     * command line. If the interp could not be found or the wrong
767     * number of arguments was specified on the command line, the return
768     * value is NULL and an error message is left in the interp's result.
769     *
770     * Side effects:
771     * None.
772     *
773     *---------------------------------------------------------------------------
774     */
775    
776     static Tcl_Interp *
777     GetInterp2(interp, objc, objv)
778     Tcl_Interp *interp; /* Default interp if no interp was specified
779     * on the command line. */
780     int objc; /* Number of arguments. */
781     Tcl_Obj *CONST objv[]; /* Argument objects. */
782     {
783     if (objc == 2) {
784     return interp;
785     } else if (objc == 3) {
786     return GetInterp(interp, objv[2]);
787     } else {
788     Tcl_WrongNumArgs(interp, 2, objv, "?path?");
789     return NULL;
790     }
791     }
792    
793     /*
794     *----------------------------------------------------------------------
795     *
796     * Tcl_CreateAlias --
797     *
798     * Creates an alias between two interpreters.
799     *
800     * Results:
801     * A standard Tcl result.
802     *
803     * Side effects:
804     * Creates a new alias, manipulates the result field of slaveInterp.
805     *
806     *----------------------------------------------------------------------
807     */
808    
809     int
810     Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
811     Tcl_Interp *slaveInterp; /* Interpreter for source command. */
812     char *slaveCmd; /* Command to install in slave. */
813     Tcl_Interp *targetInterp; /* Interpreter for target command. */
814     char *targetCmd; /* Name of target command. */
815     int argc; /* How many additional arguments? */
816     char **argv; /* These are the additional args. */
817     {
818     Tcl_Obj *slaveObjPtr, *targetObjPtr;
819     Tcl_Obj **objv;
820     int i;
821     int result;
822    
823     objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
824     for (i = 0; i < argc; i++) {
825     objv[i] = Tcl_NewStringObj(argv[i], -1);
826     Tcl_IncrRefCount(objv[i]);
827     }
828    
829     slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
830     Tcl_IncrRefCount(slaveObjPtr);
831    
832     targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
833     Tcl_IncrRefCount(targetObjPtr);
834    
835     result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
836     targetObjPtr, argc, objv);
837    
838     for (i = 0; i < argc; i++) {
839     Tcl_DecrRefCount(objv[i]);
840     }
841     ckfree((char *) objv);
842     Tcl_DecrRefCount(targetObjPtr);
843     Tcl_DecrRefCount(slaveObjPtr);
844    
845     return result;
846     }
847    
848     /*
849     *----------------------------------------------------------------------
850     *
851     * Tcl_CreateAliasObj --
852     *
853     * Object version: Creates an alias between two interpreters.
854     *
855     * Results:
856     * A standard Tcl result.
857     *
858     * Side effects:
859     * Creates a new alias.
860     *
861     *----------------------------------------------------------------------
862     */
863    
864     int
865     Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
866     Tcl_Interp *slaveInterp; /* Interpreter for source command. */
867     char *slaveCmd; /* Command to install in slave. */
868     Tcl_Interp *targetInterp; /* Interpreter for target command. */
869     char *targetCmd; /* Name of target command. */
870     int objc; /* How many additional arguments? */
871     Tcl_Obj *CONST objv[]; /* Argument vector. */
872     {
873     Tcl_Obj *slaveObjPtr, *targetObjPtr;
874     int result;
875    
876     slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
877     Tcl_IncrRefCount(slaveObjPtr);
878    
879     targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
880     Tcl_IncrRefCount(targetObjPtr);
881    
882     result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
883     targetObjPtr, objc, objv);
884    
885     Tcl_DecrRefCount(slaveObjPtr);
886     Tcl_DecrRefCount(targetObjPtr);
887     return result;
888     }
889    
890     /*
891     *----------------------------------------------------------------------
892     *
893     * Tcl_GetAlias --
894     *
895     * Gets information about an alias.
896     *
897     * Results:
898     * A standard Tcl result.
899     *
900     * Side effects:
901     * None.
902     *
903     *----------------------------------------------------------------------
904     */
905    
906     int
907     Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
908     argvPtr)
909     Tcl_Interp *interp; /* Interp to start search from. */
910     char *aliasName; /* Name of alias to find. */
911     Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
912     char **targetNamePtr; /* (Return) name of target command. */
913     int *argcPtr; /* (Return) count of addnl args. */
914     char ***argvPtr; /* (Return) additional arguments. */
915     {
916     InterpInfo *iiPtr;
917     Tcl_HashEntry *hPtr;
918     Alias *aliasPtr;
919     int i, objc;
920     Tcl_Obj **objv;
921    
922     iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
923     hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
924     if (hPtr == NULL) {
925     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
926     "alias \"", aliasName, "\" not found", (char *) NULL);
927     return TCL_ERROR;
928     }
929     aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
930     Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);
931    
932     if (targetInterpPtr != NULL) {
933     *targetInterpPtr = aliasPtr->targetInterp;
934     }
935     if (targetNamePtr != NULL) {
936     *targetNamePtr = Tcl_GetString(objv[0]);
937     }
938     if (argcPtr != NULL) {
939     *argcPtr = objc - 1;
940     }
941     if (argvPtr != NULL) {
942     *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) * (objc - 1));
943     for (i = 1; i < objc; i++) {
944     *argvPtr[i - 1] = Tcl_GetString(objv[i]);
945     }
946     }
947     return TCL_OK;
948     }
949    
950     /*
951     *----------------------------------------------------------------------
952     *
953     * Tcl_ObjGetAlias --
954     *
955     * Object version: Gets information about an alias.
956     *
957     * Results:
958     * A standard Tcl result.
959     *
960     * Side effects:
961     * None.
962     *
963     *----------------------------------------------------------------------
964     */
965    
966     int
967     Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
968     objvPtr)
969     Tcl_Interp *interp; /* Interp to start search from. */
970     char *aliasName; /* Name of alias to find. */
971     Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
972     char **targetNamePtr; /* (Return) name of target command. */
973     int *objcPtr; /* (Return) count of addnl args. */
974     Tcl_Obj ***objvPtr; /* (Return) additional args. */
975     {
976     InterpInfo *iiPtr;
977     Tcl_HashEntry *hPtr;
978     Alias *aliasPtr;
979     int objc;
980     Tcl_Obj **objv;
981    
982     iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
983     hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
984     if (hPtr == (Tcl_HashEntry *) NULL) {
985     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
986     "alias \"", aliasName, "\" not found", (char *) NULL);
987     return TCL_ERROR;
988     }
989     aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
990     Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);
991    
992     if (targetInterpPtr != (Tcl_Interp **) NULL) {
993     *targetInterpPtr = aliasPtr->targetInterp;
994     }
995     if (targetNamePtr != (char **) NULL) {
996     *targetNamePtr = Tcl_GetString(objv[0]);
997     }
998     if (objcPtr != (int *) NULL) {
999     *objcPtr = objc - 1;
1000     }
1001     if (objvPtr != (Tcl_Obj ***) NULL) {
1002     *objvPtr = objv + 1;
1003     }
1004     return TCL_OK;
1005     }
1006    
1007     /*
1008     *----------------------------------------------------------------------
1009     *
1010     * TclPreventAliasLoop --
1011     *
1012     * When defining an alias or renaming a command, prevent an alias
1013     * loop from being formed.
1014     *
1015     * Results:
1016     * A standard Tcl object result.
1017     *
1018     * Side effects:
1019     * If TCL_ERROR is returned, the function also stores an error message
1020     * in the interpreter's result object.
1021     *
1022     * NOTE:
1023     * This function is public internal (instead of being static to
1024     * this file) because it is also used from TclRenameCommand.
1025     *
1026     *----------------------------------------------------------------------
1027     */
1028    
1029     int
1030     TclPreventAliasLoop(interp, cmdInterp, cmd)
1031     Tcl_Interp *interp; /* Interp in which to report errors. */
1032     Tcl_Interp *cmdInterp; /* Interp in which the command is
1033     * being defined. */
1034     Tcl_Command cmd; /* Tcl command we are attempting
1035     * to define. */
1036     {
1037     Command *cmdPtr = (Command *) cmd;
1038     Alias *aliasPtr, *nextAliasPtr;
1039     Tcl_Command aliasCmd;
1040     Command *aliasCmdPtr;
1041    
1042     /*
1043     * If we are not creating or renaming an alias, then it is
1044     * always OK to create or rename the command.
1045     */
1046    
1047     if (cmdPtr->objProc != AliasObjCmd) {
1048     return TCL_OK;
1049     }
1050    
1051     /*
1052     * OK, we are dealing with an alias, so traverse the chain of aliases.
1053     * If we encounter the alias we are defining (or renaming to) any in
1054     * the chain then we have a loop.
1055     */
1056    
1057     aliasPtr = (Alias *) cmdPtr->objClientData;
1058     nextAliasPtr = aliasPtr;
1059     while (1) {
1060     int objc;
1061     Tcl_Obj **objv;
1062    
1063     /*
1064     * If the target of the next alias in the chain is the same as
1065     * the source alias, we have a loop.
1066     */
1067    
1068     Tcl_ListObjGetElements(NULL, nextAliasPtr->prefixPtr, &objc, &objv);
1069     aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
1070     Tcl_GetString(objv[0]),
1071     Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
1072     /*flags*/ 0);
1073     if (aliasCmd == (Tcl_Command) NULL) {
1074     return TCL_OK;
1075     }
1076     aliasCmdPtr = (Command *) aliasCmd;
1077     if (aliasCmdPtr == cmdPtr) {
1078     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1079     "cannot define or rename alias \"",
1080     Tcl_GetString(aliasPtr->namePtr),
1081     "\": would create a loop", (char *) NULL);
1082     return TCL_ERROR;
1083     }
1084    
1085     /*
1086     * Otherwise, follow the chain one step further. See if the target
1087     * command is an alias - if so, follow the loop to its target
1088     * command. Otherwise we do not have a loop.
1089     */
1090    
1091     if (aliasCmdPtr->objProc != AliasObjCmd) {
1092     return TCL_OK;
1093     }
1094     nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
1095     }
1096    
1097     /* NOTREACHED */
1098     }
1099    
1100     /*
1101     *----------------------------------------------------------------------
1102     *
1103     * AliasCreate --
1104     *
1105     * Helper function to do the work to actually create an alias.
1106     *
1107     * Results:
1108     * A standard Tcl result.
1109     *
1110     * Side effects:
1111     * An alias command is created and entered into the alias table
1112     * for the slave interpreter.
1113     *
1114     *----------------------------------------------------------------------
1115     */
1116    
1117     static int
1118     AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
1119     objc, objv)
1120     Tcl_Interp *interp; /* Interp for error reporting. */
1121     Tcl_Interp *slaveInterp; /* Interp where alias cmd will live or from
1122     * which alias will be deleted. */
1123     Tcl_Interp *masterInterp; /* Interp in which target command will be
1124     * invoked. */
1125     Tcl_Obj *namePtr; /* Name of alias cmd. */
1126     Tcl_Obj *targetNamePtr; /* Name of target cmd. */
1127     int objc; /* Additional arguments to store */
1128     Tcl_Obj *CONST objv[]; /* with alias. */
1129     {
1130     Alias *aliasPtr;
1131     Tcl_HashEntry *hPtr;
1132     int new;
1133     Target *targetPtr;
1134     Slave *slavePtr;
1135     Master *masterPtr;
1136    
1137     aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias));
1138     aliasPtr->namePtr = namePtr;
1139     Tcl_IncrRefCount(aliasPtr->namePtr);
1140     aliasPtr->targetInterp = masterInterp;
1141     aliasPtr->prefixPtr = Tcl_NewListObj(1, &targetNamePtr);
1142     Tcl_ListObjReplace(NULL, aliasPtr->prefixPtr, 1, 0, objc, objv);
1143     Tcl_IncrRefCount(aliasPtr->prefixPtr);
1144    
1145     aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
1146     Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
1147     AliasObjCmdDeleteProc);
1148    
1149     if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) {
1150     /*
1151     * Found an alias loop! The last call to Tcl_CreateObjCommand made
1152     * the alias point to itself. Delete the command and its alias
1153     * record. Be careful to wipe out its client data first, so the
1154     * command doesn't try to delete itself.
1155     */
1156    
1157     Command *cmdPtr;
1158    
1159     Tcl_DecrRefCount(aliasPtr->namePtr);
1160     Tcl_DecrRefCount(aliasPtr->prefixPtr);
1161    
1162     cmdPtr = (Command *) aliasPtr->slaveCmd;
1163     cmdPtr->clientData = NULL;
1164     cmdPtr->deleteProc = NULL;
1165     cmdPtr->deleteData = NULL;
1166     Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
1167    
1168     ckfree((char *) aliasPtr);
1169    
1170     /*
1171     * The result was already set by TclPreventAliasLoop.
1172     */
1173    
1174     return TCL_ERROR;
1175     }
1176    
1177     /*
1178     * Make an entry in the alias table. If it already exists delete
1179     * the alias command. Then retry.
1180     */
1181    
1182     slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1183     while (1) {
1184     Alias *oldAliasPtr;
1185     char *string;
1186    
1187     string = Tcl_GetString(namePtr);
1188     hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new);
1189     if (new != 0) {
1190     break;
1191     }
1192    
1193     oldAliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
1194     Tcl_DeleteCommandFromToken(slaveInterp, oldAliasPtr->slaveCmd);
1195     }
1196    
1197     aliasPtr->aliasEntryPtr = hPtr;
1198     Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);
1199    
1200     /*
1201     * Create the new command. We must do it after deleting any old command,
1202     * because the alias may be pointing at a renamed alias, as in:
1203     *
1204     * interp alias {} foo {} bar # Create an alias "foo"
1205     * rename foo zop # Now rename the alias
1206     * interp alias {} foo {} zop # Now recreate "foo"...
1207     */
1208    
1209     targetPtr = (Target *) ckalloc((unsigned) sizeof(Target));
1210     targetPtr->slaveCmd = aliasPtr->slaveCmd;
1211     targetPtr->slaveInterp = slaveInterp;
1212    
1213     Tcl_MutexLock(&cntMutex);
1214     masterPtr = &((InterpInfo *) ((Interp *) masterInterp)->interpInfo)->master;
1215     do {
1216     hPtr = Tcl_CreateHashEntry(&masterPtr->targetTable,
1217     (char *) aliasCounter, &new);
1218     aliasCounter++;
1219     } while (new == 0);
1220     Tcl_MutexUnlock(&cntMutex);
1221    
1222     Tcl_SetHashValue(hPtr, (ClientData) targetPtr);
1223     aliasPtr->targetEntryPtr = hPtr;
1224    
1225     Tcl_SetObjResult(interp, namePtr);
1226     return TCL_OK;
1227     }
1228    
1229     /*
1230     *----------------------------------------------------------------------
1231     *
1232     * AliasDelete --
1233     *
1234     * Deletes the given alias from the slave interpreter given.
1235     *
1236     * Results:
1237     * A standard Tcl result.
1238     *
1239     * Side effects:
1240     * Deletes the alias from the slave interpreter.
1241     *
1242     *----------------------------------------------------------------------
1243     */
1244    
1245     static int
1246     AliasDelete(interp, slaveInterp, namePtr)
1247     Tcl_Interp *interp; /* Interpreter for result & errors. */
1248     Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
1249     Tcl_Obj *namePtr; /* Name of alias to describe. */
1250     {
1251     Slave *slavePtr;
1252     Alias *aliasPtr;
1253     Tcl_HashEntry *hPtr;
1254    
1255     /*
1256     * If the alias has been renamed in the slave, the master can still use
1257     * the original name (with which it was created) to find the alias to
1258     * delete it.
1259     */
1260    
1261     slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1262     hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
1263     if (hPtr == NULL) {
1264     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "alias \"",
1265     Tcl_GetString(namePtr), "\" not found", NULL);
1266     return TCL_ERROR;
1267     }
1268     aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
1269     Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
1270     return TCL_OK;
1271     }
1272    
1273     /*
1274     *----------------------------------------------------------------------
1275     *
1276     * AliasDescribe --
1277     *
1278     * Sets the interpreter's result object to a Tcl list describing
1279     * the given alias in the given interpreter: its target command
1280     * and the additional arguments to prepend to any invocation
1281     * of the alias.
1282     *
1283     * Results:
1284     * A standard Tcl result.
1285     *
1286     * Side effects:
1287     * None.
1288     *
1289     *----------------------------------------------------------------------
1290     */
1291    
1292     static int
1293     AliasDescribe(interp, slaveInterp, namePtr)
1294     Tcl_Interp *interp; /* Interpreter for result & errors. */
1295     Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
1296     Tcl_Obj *namePtr; /* Name of alias to describe. */
1297     {
1298     Slave *slavePtr;
1299     Tcl_HashEntry *hPtr;
1300     Alias *aliasPtr;
1301    
1302     /*
1303     * If the alias has been renamed in the slave, the master can still use
1304     * the original name (with which it was created) to find the alias to
1305     * describe it.
1306     */
1307    
1308     slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1309     hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
1310     if (hPtr == NULL) {
1311     return TCL_OK;
1312     }
1313     aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
1314     Tcl_SetObjResult(interp, aliasPtr->prefixPtr);
1315     return TCL_OK;
1316     }
1317    
1318     /*
1319     *----------------------------------------------------------------------
1320     *
1321     * AliasList --
1322     *
1323     * Computes a list of aliases defined in a slave interpreter.
1324     *
1325     * Results:
1326     * A standard Tcl result.
1327     *
1328     * Side effects:
1329     * None.
1330     *
1331     *----------------------------------------------------------------------
1332     */
1333    
1334     static int
1335     AliasList(interp, slaveInterp)
1336     Tcl_Interp *interp; /* Interp for data return. */
1337     Tcl_Interp *slaveInterp; /* Interp whose aliases to compute. */
1338     {
1339     Tcl_HashEntry *entryPtr;
1340     Tcl_HashSearch hashSearch;
1341     Tcl_Obj *resultPtr;
1342     Alias *aliasPtr;
1343     Slave *slavePtr;
1344    
1345     slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1346     resultPtr = Tcl_GetObjResult(interp);
1347    
1348     entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
1349     for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
1350     aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
1351     Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->namePtr);
1352     }
1353     return TCL_OK;
1354     }
1355    
1356     /*
1357     *----------------------------------------------------------------------
1358     *
1359     * AliasObjCmd --
1360     *
1361     * This is the procedure that services invocations of aliases in a
1362     * slave interpreter. One such command exists for each alias. When
1363     * invoked, this procedure redirects the invocation to the target
1364     * command in the master interpreter as designated by the Alias
1365     * record associated with this command.
1366     *
1367     * Results:
1368     * A standard Tcl result.
1369     *
1370     * Side effects:
1371     * Causes forwarding of the invocation; all possible side effects
1372     * may occur as a result of invoking the command to which the
1373     * invocation is forwarded.
1374     *
1375     *----------------------------------------------------------------------
1376     */
1377    
1378     static int
1379     AliasObjCmd(clientData, interp, objc, objv)
1380     ClientData clientData; /* Alias record. */
1381     Tcl_Interp *interp; /* Current interpreter. */
1382     int objc; /* Number of arguments. */
1383     Tcl_Obj *CONST objv[]; /* Argument vector. */
1384     {
1385     Tcl_Interp *targetInterp;
1386     Alias *aliasPtr;
1387     int result, prefc, cmdc;
1388     Tcl_Obj *cmdPtr;
1389     Tcl_Obj **prefv, **cmdv;
1390    
1391     aliasPtr = (Alias *) clientData;
1392     targetInterp = aliasPtr->targetInterp;
1393    
1394     Tcl_Preserve((ClientData) targetInterp);
1395    
1396     ((Interp *) targetInterp)->numLevels++;
1397    
1398     Tcl_ResetResult(targetInterp);
1399     Tcl_AllowExceptions(targetInterp);
1400    
1401     /*
1402     * Append the arguments to the command prefix and invoke the command
1403     * in the target interp's global namespace.
1404     */
1405    
1406     Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &prefc, &prefv);
1407     cmdPtr = Tcl_NewListObj(prefc, prefv);
1408     Tcl_ListObjReplace(NULL, cmdPtr, prefc, 0, objc - 1, objv + 1);
1409     Tcl_ListObjGetElements(NULL, cmdPtr, &cmdc, &cmdv);
1410     result = TclObjInvoke(targetInterp, cmdc, cmdv,
1411     TCL_INVOKE_NO_TRACEBACK);
1412     Tcl_DecrRefCount(cmdPtr);
1413    
1414     ((Interp *) targetInterp)->numLevels--;
1415    
1416     /*
1417     * Check if we are at the bottom of the stack for the target interpreter.
1418     * If so, check for special return codes.
1419     */
1420    
1421     if (((Interp *) targetInterp)->numLevels == 0) {
1422     if (result == TCL_RETURN) {
1423     result = TclUpdateReturnInfo((Interp *) targetInterp);
1424     }
1425     if ((result != TCL_OK) && (result != TCL_ERROR)) {
1426     Tcl_ResetResult(targetInterp);
1427     if (result == TCL_BREAK) {
1428     Tcl_SetObjResult(targetInterp,
1429     Tcl_NewStringObj("invoked \"break\" outside of a loop",
1430     -1));
1431     } else if (result == TCL_CONTINUE) {
1432     Tcl_SetObjResult(targetInterp,
1433     Tcl_NewStringObj(
1434     "invoked \"continue\" outside of a loop",
1435     -1));
1436     } else {
1437     char buf[32 + TCL_INTEGER_SPACE];
1438    
1439     sprintf(buf, "command returned bad code: %d", result);
1440     Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1));
1441     }
1442     result = TCL_ERROR;
1443     }
1444     }
1445    
1446     TclTransferResult(targetInterp, result, interp);
1447    
1448     Tcl_Release((ClientData) targetInterp);
1449     return result;
1450     }
1451    
1452     /*
1453     *----------------------------------------------------------------------
1454     *
1455     * AliasObjCmdDeleteProc --
1456     *
1457     * Is invoked when an alias command is deleted in a slave. Cleans up
1458     * all storage associated with this alias.
1459     *
1460     * Results:
1461     * None.
1462     *
1463     * Side effects:
1464     * Deletes the alias record and its entry in the alias table for
1465     * the interpreter.
1466     *
1467     *----------------------------------------------------------------------
1468     */
1469    
1470     static void
1471     AliasObjCmdDeleteProc(clientData)
1472     ClientData clientData; /* The alias record for this alias. */
1473     {
1474     Alias *aliasPtr;
1475     Target *targetPtr;
1476    
1477     aliasPtr = (Alias *) clientData;
1478    
1479     Tcl_DecrRefCount(aliasPtr->namePtr);
1480     Tcl_DecrRefCount(aliasPtr->prefixPtr);
1481     Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
1482    
1483     targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
1484     ckfree((char *) targetPtr);
1485     Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr);
1486    
1487     ckfree((char *) aliasPtr);
1488     }
1489    
1490     /*
1491     *----------------------------------------------------------------------
1492     *
1493     * Tcl_CreateSlave --
1494     *
1495     * Creates a slave interpreter. The slavePath argument denotes the
1496     * name of the new slave relative to the current interpreter; the
1497     * slave is a direct descendant of the one-before-last component of
1498     * the path, e.g. it is a descendant of the current interpreter if
1499     * the slavePath argument contains only one component. Optionally makes
1500     * the slave interpreter safe.
1501     *
1502     * Results:
1503     * Returns the interpreter structure created, or NULL if an error
1504     * occurred.
1505     *
1506     * Side effects:
1507     * Creates a new interpreter and a new interpreter object command in
1508     * the interpreter indicated by the slavePath argument.
1509     *
1510     *----------------------------------------------------------------------
1511     */
1512    
1513     Tcl_Interp *
1514     Tcl_CreateSlave(interp, slavePath, isSafe)
1515     Tcl_Interp *interp; /* Interpreter to start search at. */
1516     char *slavePath; /* Name of slave to create. */
1517     int isSafe; /* Should new slave be "safe" ? */
1518     {
1519     Tcl_Obj *pathPtr;
1520     Tcl_Interp *slaveInterp;
1521    
1522     pathPtr = Tcl_NewStringObj(slavePath, -1);
1523     slaveInterp = SlaveCreate(interp, pathPtr, isSafe);
1524     Tcl_DecrRefCount(pathPtr);
1525    
1526     return slaveInterp;
1527     }
1528    
1529     /*
1530     *----------------------------------------------------------------------
1531     *
1532     * Tcl_GetSlave --
1533     *
1534     * Finds a slave interpreter by its path name.
1535     *
1536     * Results:
1537     * Returns a Tcl_Interp * for the named interpreter or NULL if not
1538     * found.
1539     *
1540     * Side effects:
1541     * None.
1542     *
1543     *----------------------------------------------------------------------
1544     */
1545    
1546     Tcl_Interp *
1547     Tcl_GetSlave(interp, slavePath)
1548     Tcl_Interp *interp; /* Interpreter to start search from. */
1549     char *slavePath; /* Path of slave to find. */
1550     {
1551     Tcl_Obj *pathPtr;
1552     Tcl_Interp *slaveInterp;
1553    
1554     pathPtr = Tcl_NewStringObj(slavePath, -1);
1555     slaveInterp = GetInterp(interp, pathPtr);
1556     Tcl_DecrRefCount(pathPtr);
1557    
1558     return slaveInterp;
1559     }
1560    
1561     /*
1562     *----------------------------------------------------------------------
1563     *
1564     * Tcl_GetMaster --
1565     *
1566     * Finds the master interpreter of a slave interpreter.
1567     *
1568     * Results:
1569     * Returns a Tcl_Interp * for the master interpreter or NULL if none.
1570     *
1571     * Side effects:
1572     * None.
1573     *
1574     *----------------------------------------------------------------------
1575     */
1576    
1577     Tcl_Interp *
1578     Tcl_GetMaster(interp)
1579     Tcl_Interp *interp; /* Get the master of this interpreter. */
1580     {
1581     Slave *slavePtr; /* Slave record of this interpreter. */
1582    
1583     if (interp == (Tcl_Interp *) NULL) {
1584     return NULL;
1585     }
1586     slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
1587     return slavePtr->masterInterp;
1588     }
1589    
1590     /*
1591     *----------------------------------------------------------------------
1592     *
1593     * Tcl_GetInterpPath --
1594     *
1595     * Sets the result of the asking interpreter to a proper Tcl list
1596     * containing the names of interpreters between the asking and
1597     * target interpreters. The target interpreter must be either the
1598     * same as the asking interpreter or one of its slaves (including
1599     * recursively).
1600     *
1601     * Results:
1602     * TCL_OK if the target interpreter is the same as, or a descendant
1603     * of, the asking interpreter; TCL_ERROR else. This way one can
1604     * distinguish between the case where the asking and target interps
1605     * are the same (an empty list is the result, and TCL_OK is returned)
1606     * and when the target is not a descendant of the asking interpreter
1607     * (in which case the Tcl result is an error message and the function
1608     * returns TCL_ERROR).
1609     *
1610     * Side effects:
1611     * None.
1612     *
1613     *----------------------------------------------------------------------
1614     */
1615    
1616     int
1617     Tcl_GetInterpPath(askingInterp, targetInterp)
1618     Tcl_Interp *askingInterp; /* Interpreter to start search from. */
1619     Tcl_Interp *targetInterp; /* Interpreter to find. */
1620     {
1621     InterpInfo *iiPtr;
1622    
1623     if (targetInterp == askingInterp) {
1624     return TCL_OK;
1625     }
1626     if (targetInterp == NULL) {
1627     return TCL_ERROR;
1628     }
1629     iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
1630     if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
1631     return TCL_ERROR;
1632     }
1633     Tcl_AppendElement(askingInterp,
1634     Tcl_GetHashKey(&iiPtr->master.slaveTable,
1635     iiPtr->slave.slaveEntryPtr));
1636     return TCL_OK;
1637     }
1638    
1639     /*
1640     *----------------------------------------------------------------------
1641     *
1642     * GetInterp --
1643     *
1644     * Helper function to find a slave interpreter given a pathname.
1645     *
1646     * Results:
1647     * Returns the slave interpreter known by that name in the calling
1648     * interpreter, or NULL if no interpreter known by that name exists.
1649     *
1650     * Side effects:
1651     * Assigns to the pointer variable passed in, if not NULL.
1652     *
1653     *----------------------------------------------------------------------
1654     */
1655    
1656     static Tcl_Interp *
1657     GetInterp(interp, pathPtr)
1658     Tcl_Interp *interp; /* Interp. to start search from. */
1659     Tcl_Obj *pathPtr; /* List object containing name of interp. to
1660     * be found. */
1661     {
1662     Tcl_HashEntry *hPtr; /* Search element. */
1663     Slave *slavePtr; /* Interim slave record. */
1664     Tcl_Obj **objv;
1665     int objc, i;
1666     Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
1667     InterpInfo *masterInfoPtr;
1668    
1669     if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
1670     return NULL;
1671     }
1672    
1673     searchInterp = interp;
1674     for (i = 0; i < objc; i++) {
1675     masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
1676     hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
1677     Tcl_GetString(objv[i]));
1678     if (hPtr == NULL) {
1679     searchInterp = NULL;
1680     break;
1681     }
1682     slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
1683     searchInterp = slavePtr->slaveInterp;
1684     if (searchInterp == NULL) {
1685     break;
1686     }
1687     }
1688     if (searchInterp == NULL) {
1689     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1690     "could not find interpreter \"",
1691     Tcl_GetString(pathPtr), "\"", (char *) NULL);
1692     }
1693     return searchInterp;
1694     }
1695    
1696     /*
1697     *----------------------------------------------------------------------
1698     *
1699     * SlaveCreate --
1700     *
1701     * Helper function to do the actual work of creating a slave interp
1702     * and new object command. Also optionally makes the new slave
1703     * interpreter "safe".
1704     *
1705     * Results:
1706     * Returns the new Tcl_Interp * if successful or NULL if not. If failed,
1707     * the result of the invoking interpreter contains an error message.
1708     *
1709     * Side effects:
1710     * Creates a new slave interpreter and a new object command.
1711     *
1712     *----------------------------------------------------------------------
1713     */
1714    
1715     static Tcl_Interp *
1716     SlaveCreate(interp, pathPtr, safe)
1717     Tcl_Interp *interp; /* Interp. to start search from. */
1718     Tcl_Obj *pathPtr; /* Path (name) of slave to create. */
1719     int safe; /* Should we make it "safe"? */
1720     {
1721     Tcl_Interp *masterInterp, *slaveInterp;
1722     Slave *slavePtr;
1723     InterpInfo *masterInfoPtr;
1724     Tcl_HashEntry *hPtr;
1725     char *path;
1726     int new, objc;
1727     Tcl_Obj **objv;
1728    
1729     if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
1730     return NULL;
1731     }
1732     if (objc < 2) {
1733     masterInterp = interp;
1734     path = Tcl_GetString(pathPtr);
1735     } else {
1736     Tcl_Obj *objPtr;
1737    
1738     objPtr = Tcl_NewListObj(objc - 1, objv);
1739     masterInterp = GetInterp(interp, objPtr);
1740     Tcl_DecrRefCount(objPtr);
1741     if (masterInterp == NULL) {
1742     return NULL;
1743     }
1744     path = Tcl_GetString(objv[objc - 1]);
1745     }
1746     if (safe == 0) {
1747     safe = Tcl_IsSafe(masterInterp);
1748     }
1749    
1750     masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
1751     hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new);
1752     if (new == 0) {
1753     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1754     "interpreter named \"", path,
1755     "\" already exists, cannot create", (char *) NULL);
1756     return NULL;
1757     }
1758    
1759     slaveInterp = Tcl_CreateInterp();
1760     slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1761     slavePtr->masterInterp = masterInterp;
1762     slavePtr->slaveEntryPtr = hPtr;
1763     slavePtr->slaveInterp = slaveInterp;
1764     slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
1765     SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc);
1766     Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
1767     Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
1768     Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
1769    
1770     /*
1771     * Inherit the recursion limit.
1772     */
1773     ((Interp *) slaveInterp)->maxNestingDepth =
1774     ((Interp *) masterInterp)->maxNestingDepth ;
1775    
1776     if (safe) {
1777     if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
1778     goto error;
1779     }
1780     } else {
1781     if (Tcl_Init(slaveInterp) == TCL_ERROR) {
1782     goto error;
1783     }
1784     }
1785     return slaveInterp;
1786    
1787     error:
1788     TclTransferResult(slaveInterp, TCL_ERROR, interp);
1789     Tcl_DeleteInterp(slaveInterp);
1790    
1791     return NULL;
1792     }
1793    
1794     /*
1795     *----------------------------------------------------------------------
1796     *
1797     * SlaveObjCmd --
1798     *
1799     * Command to manipulate an interpreter, e.g. to send commands to it
1800     * to be evaluated. One such command exists for each slave interpreter.
1801     *
1802     * Results:
1803     * A standard Tcl result.
1804     *
1805     * Side effects:
1806     * See user documentation for details.
1807     *
1808     *----------------------------------------------------------------------
1809     */
1810    
1811     static int
1812     SlaveObjCmd(clientData, interp, objc, objv)
1813     ClientData clientData; /* Slave interpreter. */
1814     Tcl_Interp *interp; /* Current interpreter. */
1815     int objc; /* Number of arguments. */
1816     Tcl_Obj *CONST objv[]; /* Argument objects. */
1817     {
1818     Tcl_Interp *slaveInterp;
1819     int index;
1820     static char *options[] = {
1821     "alias", "aliases", "eval", "expose",
1822     "hide", "hidden", "issafe", "invokehidden",
1823     "marktrusted", NULL
1824     };
1825     enum options {
1826     OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE,
1827     OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN,
1828     OPT_MARKTRUSTED
1829     };
1830    
1831     slaveInterp = (Tcl_Interp *) clientData;
1832     if (slaveInterp == NULL) {
1833     panic("SlaveObjCmd: interpreter has been deleted");
1834     }
1835    
1836     if (objc < 2) {
1837     Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
1838     return TCL_ERROR;
1839     }
1840     if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
1841     &index) != TCL_OK) {
1842     return TCL_ERROR;
1843     }
1844    
1845     switch ((enum options) index) {
1846     case OPT_ALIAS: {
1847     if (objc == 3) {
1848     return AliasDescribe(interp, slaveInterp, objv[2]);
1849     }
1850     if (Tcl_GetString(objv[3])[0] == '\0') {
1851     if (objc == 4) {
1852     return AliasDelete(interp, slaveInterp, objv[2]);
1853     }
1854     } else {
1855     return AliasCreate(interp, slaveInterp, interp, objv[2],
1856     objv[3], objc - 4, objv + 4);
1857     }
1858     Tcl_WrongNumArgs(interp, 2, objv,
1859     "aliasName ?targetName? ?args..?");
1860     return TCL_ERROR;
1861     }
1862     case OPT_ALIASES: {
1863     return AliasList(interp, slaveInterp);
1864     }
1865     case OPT_EVAL: {
1866     if (objc < 3) {
1867     Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
1868     return TCL_ERROR;
1869     }
1870     return SlaveEval(interp, slaveInterp, objc - 2, objv + 2);
1871     }
1872     case OPT_EXPOSE: {
1873     if ((objc < 3) || (objc > 4)) {
1874     Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
1875     return TCL_ERROR;
1876     }
1877     return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2);
1878     }
1879     case OPT_HIDE: {
1880     if ((objc < 3) || (objc > 4)) {
1881     Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
1882     return TCL_ERROR;
1883     }
1884     return SlaveHide(interp, slaveInterp, objc - 2, objv + 2);
1885     }
1886     case OPT_HIDDEN: {
1887     if (objc != 2) {
1888     Tcl_WrongNumArgs(interp, 2, objv, NULL);
1889     return TCL_ERROR;
1890     }
1891     return SlaveHidden(interp, slaveInterp);
1892     }
1893     case OPT_ISSAFE: {
1894     Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
1895     return TCL_OK;
1896     }
1897     case OPT_INVOKEHIDDEN: {
1898     int global, i, index;
1899     static char *hiddenOptions[] = {
1900     "-global", "--", NULL
1901     };
1902     enum hiddenOption {
1903     OPT_GLOBAL, OPT_LAST
1904     };
1905     global = 0;
1906     for (i = 2; i < objc; i++) {
1907     if (Tcl_GetString(objv[i])[0] != '-') {
1908     break;
1909     }
1910     if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
1911     "option", 0, &index) != TCL_OK) {
1912     return TCL_ERROR;
1913     }
1914     if (index == OPT_GLOBAL) {
1915     global = 1;
1916     } else {
1917     i++;
1918     break;
1919     }
1920     }
1921     if (objc - i < 1) {
1922     Tcl_WrongNumArgs(interp, 2, objv,
1923     "?-global? ?--? cmd ?arg ..?");
1924     return TCL_ERROR;
1925     }
1926     return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
1927     objv + i);
1928     }
1929     case OPT_MARKTRUSTED: {
1930     if (objc != 2) {
1931     Tcl_WrongNumArgs(interp, 2, objv, NULL);
1932     return TCL_ERROR;
1933     }
1934     return SlaveMarkTrusted(interp, slaveInterp);
1935     }
1936     }
1937    
1938     return TCL_ERROR;
1939     }
1940    
1941     /*
1942     *----------------------------------------------------------------------
1943     *
1944     * SlaveObjCmdDeleteProc --
1945     *
1946     * Invoked when an object command for a slave interpreter is deleted;
1947     * cleans up all state associated with the slave interpreter and destroys
1948     * the slave interpreter.
1949     *
1950     * Results:
1951     * None.
1952     *
1953     * Side effects:
1954     * Cleans up all state associated with the slave interpreter and
1955     * destroys the slave interpreter.
1956     *
1957     *----------------------------------------------------------------------
1958     */
1959    
1960     static void
1961     SlaveObjCmdDeleteProc(clientData)
1962     ClientData clientData; /* The SlaveRecord for the command. */
1963     {
1964     Slave *slavePtr; /* Interim storage for Slave record. */
1965     Tcl_Interp *slaveInterp; /* And for a slave interp. */
1966    
1967     slaveInterp = (Tcl_Interp *) clientData;
1968     slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
1969    
1970     /*
1971     * Unlink the slave from its master interpreter.
1972     */
1973    
1974     Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr);
1975    
1976     /*
1977     * Set to NULL so that when the InterpInfo is cleaned up in the slave
1978     * it does not try to delete the command causing all sorts of grief.
1979     * See SlaveRecordDeleteProc().
1980     */
1981    
1982     slavePtr->interpCmd = NULL;
1983    
1984     if (slavePtr->slaveInterp != NULL) {
1985     Tcl_DeleteInterp(slavePtr->slaveInterp);
1986     }
1987     }
1988    
1989     /*
1990     *----------------------------------------------------------------------
1991     *
1992     * SlaveEval --
1993     *
1994     * Helper function to evaluate a command in a slave interpreter.
1995     *
1996     * Results:
1997     * A standard Tcl result.
1998     *
1999     * Side effects:
2000     * Whatever the command does.
2001     *
2002     *----------------------------------------------------------------------
2003     */
2004    
2005     static int
2006     SlaveEval(interp, slaveInterp, objc, objv)
2007     Tcl_Interp *interp; /* Interp for error return. */
2008     Tcl_Interp *slaveInterp; /* The slave interpreter in which command
2009     * will be evaluated. */
2010     int objc; /* Number of arguments. */
2011     Tcl_Obj *CONST objv[]; /* Argument objects. */
2012     {
2013     int result;
2014     Tcl_Obj *objPtr;
2015    
2016     Tcl_Preserve((ClientData) slaveInterp);
2017     Tcl_AllowExceptions(slaveInterp);
2018    
2019     if (objc == 1) {
2020     result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
2021     } else {
2022     objPtr = Tcl_ConcatObj(objc, objv);
2023     Tcl_IncrRefCount(objPtr);
2024     result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
2025     Tcl_DecrRefCount(objPtr);
2026     }
2027     TclTransferResult(slaveInterp, result, interp);
2028    
2029     Tcl_Release((ClientData) slaveInterp);
2030     return result;
2031     }
2032    
2033     /*
2034     *----------------------------------------------------------------------
2035     *
2036     * SlaveExpose --
2037     *
2038     * Helper function to expose a command in a slave interpreter.
2039     *
2040     * Results:
2041     * A standard Tcl result.
2042     *
2043     * Side effects:
2044     * After this call scripts in the slave will be able to invoke
2045     * the newly exposed command.
2046     *
2047     *----------------------------------------------------------------------
2048     */
2049    
2050     static int
2051     SlaveExpose(interp, slaveInterp, objc, objv)
2052     Tcl_Interp *interp; /* Interp for error return. */
2053     Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */
2054     int objc; /* Number of arguments. */
2055     Tcl_Obj *CONST objv[]; /* Argument strings. */
2056     {
2057     char *name;
2058    
2059     if (Tcl_IsSafe(interp)) {
2060     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2061     "permission denied: safe interpreter cannot expose commands",
2062     (char *) NULL);
2063     return TCL_ERROR;
2064     }
2065    
2066     name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
2067     if (Tcl_ExposeCommand(slaveInterp, Tcl_GetString(objv[0]),
2068     name) != TCL_OK) {
2069     TclTransferResult(slaveInterp, TCL_ERROR, interp);
2070     return TCL_ERROR;
2071     }
2072     return TCL_OK;
2073     }
2074    
2075     /*
2076     *----------------------------------------------------------------------
2077     *
2078     * SlaveHide --
2079     *
2080     * Helper function to hide a command in a slave interpreter.
2081     *
2082     * Results:
2083     * A standard Tcl result.
2084     *
2085     * Side effects:
2086     * After this call scripts in the slave will no longer be able
2087     * to invoke the named command.
2088     *
2089     *----------------------------------------------------------------------
2090     */
2091    
2092     static int
2093     SlaveHide(interp, slaveInterp, objc, objv)
2094     Tcl_Interp *interp; /* Interp for error return. */
2095     Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */
2096     int objc; /* Number of arguments. */
2097     Tcl_Obj *CONST objv[]; /* Argument strings. */
2098     {
2099     char *name;
2100    
2101     if (Tcl_IsSafe(interp)) {
2102     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2103     "permission denied: safe interpreter cannot hide commands",
2104     (char *) NULL);
2105     return TCL_ERROR;
2106     }
2107    
2108     name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
2109     if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]),
2110     name) != TCL_OK) {
2111     TclTransferResult(slaveInterp, TCL_ERROR, interp);
2112     return TCL_ERROR;
2113     }
2114     return TCL_OK;
2115     }
2116    
2117     /*
2118     *----------------------------------------------------------------------
2119     *
2120     * SlaveHidden --
2121     *
2122     * Helper function to compute list of hidden commands in a slave
2123     * interpreter.
2124     *
2125     * Results:
2126     * A standard Tcl result.
2127     *
2128     * Side effects:
2129     * None.
2130     *
2131     *----------------------------------------------------------------------
2132     */
2133    
2134     static int
2135     SlaveHidden(interp, slaveInterp)
2136     Tcl_Interp *interp; /* Interp for data return. */
2137     Tcl_Interp *slaveInterp; /* Interp whose hidden commands to query. */
2138     {
2139     Tcl_Obj *listObjPtr; /* Local object pointer. */
2140     Tcl_HashTable *hTblPtr; /* For local searches. */
2141     Tcl_HashEntry *hPtr; /* For local searches. */
2142     Tcl_HashSearch hSearch; /* For local searches. */
2143    
2144     listObjPtr = Tcl_GetObjResult(interp);
2145     hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr;
2146     if (hTblPtr != (Tcl_HashTable *) NULL) {
2147     for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
2148     hPtr != (Tcl_HashEntry *) NULL;
2149     hPtr = Tcl_NextHashEntry(&hSearch)) {
2150    
2151     Tcl_ListObjAppendElement(NULL, listObjPtr,
2152     Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
2153     }
2154     }
2155     return TCL_OK;
2156     }
2157    
2158     /*
2159     *----------------------------------------------------------------------
2160     *
2161     * SlaveInvokeHidden --
2162     *
2163     * Helper function to invoke a hidden command in a slave interpreter.
2164     *
2165     * Results:
2166     * A standard Tcl result.
2167     *
2168     * Side effects:
2169     * Whatever the hidden command does.
2170     *
2171     *----------------------------------------------------------------------
2172     */
2173    
2174     static int
2175     SlaveInvokeHidden(interp, slaveInterp, global, objc, objv)
2176     Tcl_Interp *interp; /* Interp for error return. */
2177     Tcl_Interp *slaveInterp; /* The slave interpreter in which command
2178     * will be invoked. */
2179     int global; /* Non-zero to invoke in global namespace. */
2180     int objc; /* Number of arguments. */
2181     Tcl_Obj *CONST objv[]; /* Argument objects. */
2182     {
2183     int result;
2184    
2185     if (Tcl_IsSafe(interp)) {
2186     Tcl_SetStringObj(Tcl_GetObjResult(interp),
2187     "not allowed to invoke hidden commands from safe interpreter",
2188     -1);
2189     return TCL_ERROR;
2190     }
2191    
2192     Tcl_Preserve((ClientData) slaveInterp);
2193     Tcl_AllowExceptions(slaveInterp);
2194    
2195     if (global) {
2196     result = TclObjInvokeGlobal(slaveInterp, objc, objv,
2197     TCL_INVOKE_HIDDEN);
2198     } else {
2199     result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
2200     }
2201    
2202     TclTransferResult(slaveInterp, result, interp);
2203    
2204     Tcl_Release((ClientData) slaveInterp);
2205     return result;
2206     }
2207    
2208     /*
2209     *----------------------------------------------------------------------
2210     *
2211     * SlaveMarkTrusted --
2212     *
2213     * Helper function to mark a slave interpreter as trusted (unsafe).
2214     *
2215     * Results:
2216     * A standard Tcl result.
2217     *
2218     * Side effects:
2219     * After this call the hard-wired security checks in the core no
2220     * longer prevent the slave from performing certain operations.
2221     *
2222     *----------------------------------------------------------------------
2223     */
2224    
2225     static int
2226     SlaveMarkTrusted(interp, slaveInterp)
2227     Tcl_Interp *interp; /* Interp for error return. */
2228     Tcl_Interp *slaveInterp; /* The slave interpreter which will be
2229     * marked trusted. */
2230     {
2231     if (Tcl_IsSafe(interp)) {
2232     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2233     "permission denied: safe interpreter cannot mark trusted",
2234     (char *) NULL);
2235     return TCL_ERROR;
2236     }
2237     ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP;
2238     return TCL_OK;
2239     }
2240    
2241     /*
2242     *----------------------------------------------------------------------
2243     *
2244     * Tcl_IsSafe --
2245     *
2246     * Determines whether an interpreter is safe
2247     *
2248     * Results:
2249     * 1 if it is safe, 0 if it is not.
2250     *
2251     * Side effects:
2252     * None.
2253     *
2254     *----------------------------------------------------------------------
2255     */
2256    
2257     int
2258     Tcl_IsSafe(interp)
2259     Tcl_Interp *interp; /* Is this interpreter "safe" ? */
2260     {
2261     Interp *iPtr;
2262    
2263     if (interp == (Tcl_Interp *) NULL) {
2264     return 0;
2265     }
2266     iPtr = (Interp *) interp;
2267    
2268     return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
2269     }
2270    
2271     /*
2272     *----------------------------------------------------------------------
2273     *
2274     * Tcl_MakeSafe --
2275     *
2276     * Makes its argument interpreter contain only functionality that is
2277     * defined to be part of Safe Tcl. Unsafe commands are hidden, the
2278     * env array is unset, and the standard channels are removed.
2279     *
2280     * Results:
2281     * None.
2282     *
2283     * Side effects:
2284     * Hides commands in its argument interpreter, and removes settings
2285     * and channels.
2286     *
2287     *----------------------------------------------------------------------
2288     */
2289    
2290     int
2291     Tcl_MakeSafe(interp)
2292     Tcl_Interp *interp; /* Interpreter to be made safe. */
2293     {
2294     Tcl_Channel chan; /* Channel to remove from
2295     * safe interpreter. */
2296     Interp *iPtr = (Interp *) interp;
2297    
2298     TclHideUnsafeCommands(interp);
2299    
2300     iPtr->flags |= SAFE_INTERP;
2301    
2302     /*
2303     * Unsetting variables : (which should not have been set
2304     * in the first place, but...)
2305     */
2306    
2307     /*
2308     * No env array in a safe slave.
2309     */
2310    
2311     Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
2312    
2313     /*
2314     * Remove unsafe parts of tcl_platform
2315     */
2316    
2317     Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
2318     Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
2319     Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
2320     Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);
2321    
2322     /*
2323     * Unset path informations variables
2324     * (the only one remaining is [info nameofexecutable])
2325     */
2326    
2327     Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
2328     Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
2329     Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
2330    
2331     /*
2332     * Remove the standard channels from the interpreter; safe interpreters
2333     * do not ordinarily have access to stdin, stdout and stderr.
2334     *
2335     * NOTE: These channels are not added to the interpreter by the
2336     * Tcl_CreateInterp call, but may be added later, by another I/O
2337     * operation. We want to ensure that the interpreter does not have
2338     * these channels even if it is being made safe after being used for
2339     * some time..
2340     */
2341    
2342     chan = Tcl_GetStdChannel(TCL_STDIN);
2343     if (chan != (Tcl_Channel) NULL) {
2344     Tcl_UnregisterChannel(interp, chan);
2345     }
2346     chan = Tcl_GetStdChannel(TCL_STDOUT);
2347     if (chan != (Tcl_Channel) NULL) {
2348     Tcl_UnregisterChannel(interp, chan);
2349     }
2350     chan = Tcl_GetStdChannel(TCL_STDERR);
2351     if (chan != (Tcl_Channel) NULL) {
2352     Tcl_UnregisterChannel(interp, chan);
2353     }
2354    
2355     return TCL_OK;
2356     }
2357    
2358 dashley 64 /* End of tclinterp.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25