/[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 25 - (show annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (8 years, 2 months ago) by dashley
Original Path: sf_code/esrgpcpj/shared/tcl_base/tclinterp.c
File MIME type: text/plain
File size: 71352 byte(s)
Initial commit.
1 /* $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