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