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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25