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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (show annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 11 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 /*$Header$ */
2 /*
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 /* End of tclinterp.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25