1/* 2 * tclInterp.c -- 3 * 4 * This file implements the "interp" command which allows creation and 5 * manipulation of Tcl interpreters from within Tcl scripts. 6 * 7 * Copyright (c) 1995-1997 Sun Microsystems, Inc. 8 * Copyright (c) 2004 Donal K. Fellows 9 * 10 * See the file "license.terms" for information on usage and redistribution 11 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 * 13 * RCS: @(#) $Id: tclInterp.c,v 1.83.2.4 2009/12/29 13:13:18 dkf Exp $ 14 */ 15 16#include "tclInt.h" 17 18/* 19 * A pointer to a string that holds an initialization script that if non-NULL 20 * is evaluated in Tcl_Init() prior to the built-in initialization script 21 * above. This variable can be modified by the function below. 22 */ 23 24static char *tclPreInitScript = NULL; 25 26/* Forward declaration */ 27struct Target; 28 29/* 30 * struct Alias: 31 * 32 * Stores information about an alias. Is stored in the slave interpreter and 33 * used by the source command to find the target command in the master when 34 * the source command is invoked. 35 */ 36 37typedef struct Alias { 38 Tcl_Obj *token; /* Token for the alias command in the slave 39 * interp. This used to be the command name in 40 * the slave when the alias was first 41 * created. */ 42 Tcl_Interp *targetInterp; /* Interp in which target command will be 43 * invoked. */ 44 Tcl_Command slaveCmd; /* Source command in slave interpreter, bound 45 * to command that invokes the target command 46 * in the target interpreter. */ 47 Tcl_HashEntry *aliasEntryPtr; 48 /* Entry for the alias hash table in slave. 49 * This is used by alias deletion to remove 50 * the alias from the slave interpreter alias 51 * table. */ 52 struct Target *targetPtr; /* Entry for target command in master. This is 53 * used in the master interpreter to map back 54 * from the target command to aliases 55 * redirecting to it. */ 56 int objc; /* Count of Tcl_Obj in the prefix of the 57 * target command to be invoked in the target 58 * interpreter. Additional arguments specified 59 * when calling the alias in the slave interp 60 * will be appended to the prefix before the 61 * command is invoked. */ 62 Tcl_Obj *objPtr; /* The first actual prefix object - the target 63 * command name; this has to be at the end of 64 * the structure, which will be extended to 65 * accomodate the remaining objects in the 66 * prefix. */ 67} Alias; 68 69/* 70 * 71 * struct Slave: 72 * 73 * Used by the "interp" command to record and find information about slave 74 * interpreters. Maps from a command name in the master to information about a 75 * slave interpreter, e.g. what aliases are defined in it. 76 */ 77 78typedef struct Slave { 79 Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ 80 Tcl_HashEntry *slaveEntryPtr; 81 /* Hash entry in masters slave table for this 82 * slave interpreter. Used to find this 83 * record, and used when deleting the slave 84 * interpreter to delete it from the master's 85 * table. */ 86 Tcl_Interp *slaveInterp; /* The slave interpreter. */ 87 Tcl_Command interpCmd; /* Interpreter object command. */ 88 Tcl_HashTable aliasTable; /* Table which maps from names of commands in 89 * slave interpreter to struct Alias defined 90 * below. */ 91} Slave; 92 93/* 94 * struct Target: 95 * 96 * Maps from master interpreter commands back to the source commands in slave 97 * interpreters. This is needed because aliases can be created between sibling 98 * interpreters and must be deleted when the target interpreter is deleted. In 99 * case they would not be deleted the source interpreter would be left with a 100 * "dangling pointer". One such record is stored in the Master record of the 101 * master interpreter with the master for each alias which directs to a 102 * command in the master. These records are used to remove the source command 103 * for an from a slave if/when the master is deleted. They are organized in a 104 * doubly-linked list attached to the master interpreter. 105 */ 106 107typedef struct Target { 108 Tcl_Command slaveCmd; /* Command for alias in slave interp. */ 109 Tcl_Interp *slaveInterp; /* Slave Interpreter. */ 110 struct Target *nextPtr; /* Next in list of target records, or NULL if 111 * at the end of the list of targets. */ 112 struct Target *prevPtr; /* Previous in list of target records, or NULL 113 * if at the start of the list of targets. */ 114} Target; 115 116/* 117 * struct Master: 118 * 119 * This record is used for two purposes: First, slaveTable (a hashtable) maps 120 * from names of commands to slave interpreters. This hashtable is used to 121 * store information about slave interpreters of this interpreter, to map over 122 * all slaves, etc. The second purpose is to store information about all 123 * aliases in slaves (or siblings) which direct to target commands in this 124 * interpreter (using the targetsPtr doubly-linked list). 125 * 126 * NB: the flags field in the interp structure, used with SAFE_INTERP mask 127 * denotes whether the interpreter is safe or not. Safe interpreters have 128 * restricted functionality, can only create safe slave interpreters and can 129 * only load safe extensions. 130 */ 131 132typedef struct Master { 133 Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps 134 * from command names to Slave records. */ 135 Target *targetsPtr; /* The head of a doubly-linked list of all the 136 * target records which denote aliases from 137 * slaves or sibling interpreters that direct 138 * to commands in this interpreter. This list 139 * is used to remove dangling pointers from 140 * the slave (or sibling) interpreters when 141 * this interpreter is deleted. */ 142} Master; 143 144/* 145 * The following structure keeps track of all the Master and Slave information 146 * on a per-interp basis. 147 */ 148 149typedef struct InterpInfo { 150 Master master; /* Keeps track of all interps for which this 151 * interp is the Master. */ 152 Slave slave; /* Information necessary for this interp to 153 * function as a slave. */ 154} InterpInfo; 155 156/* 157 * Limit callbacks handled by scripts are modelled as structures which are 158 * stored in hashes indexed by a two-word key. Note that the type of the 159 * 'type' field in the key is not int; this is to make sure that things are 160 * likely to work properly on 64-bit architectures. 161 */ 162 163typedef struct ScriptLimitCallback { 164 Tcl_Interp *interp; /* The interpreter in which to execute the 165 * callback. */ 166 Tcl_Obj *scriptObj; /* The script to execute to perform the 167 * user-defined part of the callback. */ 168 int type; /* What kind of callback is this. */ 169 Tcl_HashEntry *entryPtr; /* The entry in the hash table maintained by 170 * the target interpreter that refers to this 171 * callback record, or NULL if the entry has 172 * already been deleted from that hash 173 * table. */ 174} ScriptLimitCallback; 175 176typedef struct ScriptLimitCallbackKey { 177 Tcl_Interp *interp; /* The interpreter that the limit callback was 178 * attached to. This is not the interpreter 179 * that the callback runs in! */ 180 long type; /* The type of callback that this is. */ 181} ScriptLimitCallbackKey; 182 183/* 184 * Prototypes for local static functions: 185 */ 186 187static int AliasCreate(Tcl_Interp *interp, 188 Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, 189 Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, 190 Tcl_Obj *const objv[]); 191static int AliasDelete(Tcl_Interp *interp, 192 Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); 193static int AliasDescribe(Tcl_Interp *interp, 194 Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); 195static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); 196static int AliasObjCmd(ClientData dummy, 197 Tcl_Interp *currentInterp, int objc, 198 Tcl_Obj *const objv[]); 199static void AliasObjCmdDeleteProc(ClientData clientData); 200static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr); 201static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc, 202 Tcl_Obj *const objv[]); 203static void InterpInfoDeleteProc(ClientData clientData, 204 Tcl_Interp *interp); 205static int SlaveBgerror(Tcl_Interp *interp, 206 Tcl_Interp *slaveInterp, int objc, 207 Tcl_Obj *const objv[]); 208static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, 209 int safe); 210static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp, 211 int objc, Tcl_Obj *const objv[]); 212static int SlaveExpose(Tcl_Interp *interp, 213 Tcl_Interp *slaveInterp, int objc, 214 Tcl_Obj *const objv[]); 215static int SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp, 216 int objc, Tcl_Obj *const objv[]); 217static int SlaveHidden(Tcl_Interp *interp, 218 Tcl_Interp *slaveInterp); 219static int SlaveInvokeHidden(Tcl_Interp *interp, 220 Tcl_Interp *slaveInterp, 221 const char *namespaceName, 222 int objc, Tcl_Obj *const objv[]); 223static int SlaveMarkTrusted(Tcl_Interp *interp, 224 Tcl_Interp *slaveInterp); 225static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp, 226 int objc, Tcl_Obj *const objv[]); 227static void SlaveObjCmdDeleteProc(ClientData clientData); 228static int SlaveRecursionLimit(Tcl_Interp *interp, 229 Tcl_Interp *slaveInterp, int objc, 230 Tcl_Obj *const objv[]); 231static int SlaveCommandLimitCmd(Tcl_Interp *interp, 232 Tcl_Interp *slaveInterp, int consumedObjc, 233 int objc, Tcl_Obj *const objv[]); 234static int SlaveTimeLimitCmd(Tcl_Interp *interp, 235 Tcl_Interp *slaveInterp, int consumedObjc, 236 int objc, Tcl_Obj *const objv[]); 237static void InheritLimitsFromMaster(Tcl_Interp *slaveInterp, 238 Tcl_Interp *masterInterp); 239static void SetScriptLimitCallback(Tcl_Interp *interp, int type, 240 Tcl_Interp *targetInterp, Tcl_Obj *scriptObj); 241static void CallScriptLimitCallback(ClientData clientData, 242 Tcl_Interp *interp); 243static void DeleteScriptLimitCallback(ClientData clientData); 244static void RunLimitHandlers(LimitHandler *handlerPtr, 245 Tcl_Interp *interp); 246static void TimeLimitCallback(ClientData clientData); 247 248/* 249 *---------------------------------------------------------------------- 250 * 251 * TclSetPreInitScript -- 252 * 253 * This routine is used to change the value of the internal variable, 254 * tclPreInitScript. 255 * 256 * Results: 257 * Returns the current value of tclPreInitScript. 258 * 259 * Side effects: 260 * Changes the way Tcl_Init() routine behaves. 261 * 262 *---------------------------------------------------------------------- 263 */ 264 265char * 266TclSetPreInitScript( 267 char *string) /* Pointer to a script. */ 268{ 269 char *prevString = tclPreInitScript; 270 tclPreInitScript = string; 271 return(prevString); 272} 273 274/* 275 *---------------------------------------------------------------------- 276 * 277 * Tcl_Init -- 278 * 279 * This function is typically invoked by Tcl_AppInit functions to find 280 * and source the "init.tcl" script, which should exist somewhere on the 281 * Tcl library path. 282 * 283 * Results: 284 * Returns a standard Tcl completion code and sets the interp's result if 285 * there is an error. 286 * 287 * Side effects: 288 * Depends on what's in the init.tcl script. 289 * 290 *---------------------------------------------------------------------- 291 */ 292 293int 294Tcl_Init( 295 Tcl_Interp *interp) /* Interpreter to initialize. */ 296{ 297 if (tclPreInitScript != NULL) { 298 if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { 299 return (TCL_ERROR); 300 }; 301 } 302 303 /* 304 * In order to find init.tcl during initialization, the following script 305 * is invoked by Tcl_Init(). It looks in several different directories: 306 * 307 * $tcl_library - can specify a primary location, if set, no 308 * other locations will be checked. This is the 309 * recommended way for a program that embeds 310 * Tcl to specifically tell Tcl where to find 311 * an init.tcl file. 312 * 313 * $env(TCL_LIBRARY) - highest priority so user can always override 314 * the search path unless the application has 315 * specified an exact directory above 316 * 317 * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl on 318 * those platforms where it can determine at 319 * runtime the directory where it expects the 320 * init.tcl file to be. After [tclInit] reads 321 * and uses this value, it [unset]s it. 322 * External users of Tcl should not make use of 323 * the variable to customize [tclInit]. 324 * 325 * $tcl_libPath - OBSOLETE: This variable is no longer set by 326 * Tcl itself, but [tclInit] examines it in 327 * case some program that embeds Tcl is 328 * customizing [tclInit] by setting this 329 * variable to a list of directories in which 330 * to search. 331 * 332 * [tcl::pkgconfig get scriptdir,runtime] 333 * - the directory determined by configure to be 334 * the place where Tcl's script library is to 335 * be installed. 336 * 337 * The first directory on this path that contains a valid init.tcl script 338 * will be set as the value of tcl_library. 339 * 340 * Note that this entire search mechanism can be bypassed by defining an 341 * alternate tclInit command before calling Tcl_Init(). 342 */ 343 344 return Tcl_Eval(interp, 345"if {[namespace which -command tclInit] eq \"\"} {\n" 346" proc tclInit {} {\n" 347" global tcl_libPath tcl_library env tclDefaultLibrary\n" 348" rename tclInit {}\n" 349" if {[info exists tcl_library]} {\n" 350" set scripts {{set tcl_library}}\n" 351" } else {\n" 352" set scripts {}\n" 353" if {[info exists env(TCL_LIBRARY)] && ($env(TCL_LIBRARY) ne {})} {\n" 354" lappend scripts {set env(TCL_LIBRARY)}\n" 355" lappend scripts {\n" 356"if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail] == 0} continue\n" 357"if {$tail eq [info tclversion]} continue\n" 358"file join [file dirname $env(TCL_LIBRARY)] tcl[info tclversion]}\n" 359" }\n" 360" if {[info exists tclDefaultLibrary]} {\n" 361" lappend scripts {set tclDefaultLibrary}\n" 362" } else {\n" 363" lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n" 364" }\n" 365" lappend scripts {\n" 366"set parentDir [file dirname [file dirname [info nameofexecutable]]]\n" 367"set grandParentDir [file dirname $parentDir]\n" 368"file join $parentDir lib tcl[info tclversion]} \\\n" 369" {file join $grandParentDir lib tcl[info tclversion]} \\\n" 370" {file join $parentDir library} \\\n" 371" {file join $grandParentDir library} \\\n" 372" {file join $grandParentDir tcl[info patchlevel] library} \\\n" 373" {\n" 374"file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n" 375" if {[info exists tcl_libPath]\n" 376" && [catch {llength $tcl_libPath} len] == 0} {\n" 377" for {set i 0} {$i < $len} {incr i} {\n" 378" lappend scripts [list lindex \\$tcl_libPath $i]\n" 379" }\n" 380" }\n" 381" }\n" 382" set dirs {}\n" 383" set errors {}\n" 384" foreach script $scripts {\n" 385" lappend dirs [eval $script]\n" 386" set tcl_library [lindex $dirs end]\n" 387" set tclfile [file join $tcl_library init.tcl]\n" 388" if {[file exists $tclfile]} {\n" 389" if {[catch {uplevel #0 [list source $tclfile]} msg opts]} {\n" 390" append errors \"$tclfile: $msg\n\"\n" 391" append errors \"[dict get $opts -errorinfo]\n\"\n" 392" continue\n" 393" }\n" 394" unset -nocomplain tclDefaultLibrary\n" 395" return\n" 396" }\n" 397" }\n" 398" unset -nocomplain tclDefaultLibrary\n" 399" set msg \"Can't find a usable init.tcl in the following directories: \n\"\n" 400" append msg \" $dirs\n\n\"\n" 401" append msg \"$errors\n\n\"\n" 402" append msg \"This probably means that Tcl wasn't installed properly.\n\"\n" 403" error $msg\n" 404" }\n" 405"}\n" 406"tclInit"); 407} 408 409/* 410 *--------------------------------------------------------------------------- 411 * 412 * TclInterpInit -- 413 * 414 * Initializes the invoking interpreter for using the master, slave and 415 * safe interp facilities. This is called from inside Tcl_CreateInterp(). 416 * 417 * Results: 418 * Always returns TCL_OK for backwards compatibility. 419 * 420 * Side effects: 421 * Adds the "interp" command to an interpreter and initializes the 422 * interpInfoPtr field of the invoking interpreter. 423 * 424 *--------------------------------------------------------------------------- 425 */ 426 427int 428TclInterpInit( 429 Tcl_Interp *interp) /* Interpreter to initialize. */ 430{ 431 InterpInfo *interpInfoPtr; 432 Master *masterPtr; 433 Slave *slavePtr; 434 435 interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); 436 ((Interp *) interp)->interpInfo = interpInfoPtr; 437 438 masterPtr = &interpInfoPtr->master; 439 Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS); 440 masterPtr->targetsPtr = NULL; 441 442 slavePtr = &interpInfoPtr->slave; 443 slavePtr->masterInterp = NULL; 444 slavePtr->slaveEntryPtr = NULL; 445 slavePtr->slaveInterp = interp; 446 slavePtr->interpCmd = NULL; 447 Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); 448 449 Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); 450 451 Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); 452 return TCL_OK; 453} 454 455/* 456 *--------------------------------------------------------------------------- 457 * 458 * InterpInfoDeleteProc -- 459 * 460 * Invoked when an interpreter is being deleted. It releases all storage 461 * used by the master/slave/safe interpreter facilities. 462 * 463 * Results: 464 * None. 465 * 466 * Side effects: 467 * Cleans up storage. Sets the interpInfoPtr field of the interp to NULL. 468 * 469 *--------------------------------------------------------------------------- 470 */ 471 472static void 473InterpInfoDeleteProc( 474 ClientData clientData, /* Ignored. */ 475 Tcl_Interp *interp) /* Interp being deleted. All commands for 476 * slave interps should already be deleted. */ 477{ 478 InterpInfo *interpInfoPtr; 479 Slave *slavePtr; 480 Master *masterPtr; 481 Target *targetPtr; 482 483 interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; 484 485 /* 486 * There shouldn't be any commands left. 487 */ 488 489 masterPtr = &interpInfoPtr->master; 490 if (masterPtr->slaveTable.numEntries != 0) { 491 Tcl_Panic("InterpInfoDeleteProc: still exist commands"); 492 } 493 Tcl_DeleteHashTable(&masterPtr->slaveTable); 494 495 /* 496 * Tell any interps that have aliases to this interp that they should 497 * delete those aliases. If the other interp was already dead, it would 498 * have removed the target record already. 499 */ 500 501 for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) { 502 Target *tmpPtr = targetPtr->nextPtr; 503 Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, 504 targetPtr->slaveCmd); 505 targetPtr = tmpPtr; 506 } 507 508 slavePtr = &interpInfoPtr->slave; 509 if (slavePtr->interpCmd != NULL) { 510 /* 511 * Tcl_DeleteInterp() was called on this interpreter, rather "interp 512 * delete" or the equivalent deletion of the command in the master. 513 * First ensure that the cleanup callback doesn't try to delete the 514 * interp again. 515 */ 516 517 slavePtr->slaveInterp = NULL; 518 Tcl_DeleteCommandFromToken(slavePtr->masterInterp, 519 slavePtr->interpCmd); 520 } 521 522 /* 523 * There shouldn't be any aliases left. 524 */ 525 526 if (slavePtr->aliasTable.numEntries != 0) { 527 Tcl_Panic("InterpInfoDeleteProc: still exist aliases"); 528 } 529 Tcl_DeleteHashTable(&slavePtr->aliasTable); 530 531 ckfree((char *) interpInfoPtr); 532} 533 534/* 535 *---------------------------------------------------------------------- 536 * 537 * Tcl_InterpObjCmd -- 538 * 539 * This function is invoked to process the "interp" Tcl command. See the 540 * user documentation for details on what it does. 541 * 542 * Results: 543 * A standard Tcl result. 544 * 545 * Side effects: 546 * See the user documentation. 547 * 548 *---------------------------------------------------------------------- 549 */ 550 /* ARGSUSED */ 551int 552Tcl_InterpObjCmd( 553 ClientData clientData, /* Unused. */ 554 Tcl_Interp *interp, /* Current interpreter. */ 555 int objc, /* Number of arguments. */ 556 Tcl_Obj *const objv[]) /* Argument objects. */ 557{ 558 int index; 559 static const char *options[] = { 560 "alias", "aliases", "bgerror", "create", 561 "delete", "eval", "exists", "expose", 562 "hide", "hidden", "issafe", "invokehidden", 563 "limit", "marktrusted", "recursionlimit","slaves", 564 "share", "target", "transfer", 565 NULL 566 }; 567 enum option { 568 OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE, 569 OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, 570 OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, 571 OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, 572 OPT_SHARE, OPT_TARGET, OPT_TRANSFER 573 }; 574 575 if (objc < 2) { 576 Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); 577 return TCL_ERROR; 578 } 579 if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, 580 &index) != TCL_OK) { 581 return TCL_ERROR; 582 } 583 switch ((enum option) index) { 584 case OPT_ALIAS: { 585 Tcl_Interp *slaveInterp, *masterInterp; 586 587 if (objc < 4) { 588 aliasArgs: 589 Tcl_WrongNumArgs(interp, 2, objv, 590 "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); 591 return TCL_ERROR; 592 } 593 slaveInterp = GetInterp(interp, objv[2]); 594 if (slaveInterp == NULL) { 595 return TCL_ERROR; 596 } 597 if (objc == 4) { 598 return AliasDescribe(interp, slaveInterp, objv[3]); 599 } 600 if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) { 601 return AliasDelete(interp, slaveInterp, objv[3]); 602 } 603 if (objc > 5) { 604 masterInterp = GetInterp(interp, objv[4]); 605 if (masterInterp == NULL) { 606 return TCL_ERROR; 607 } 608 if (TclGetString(objv[5])[0] == '\0') { 609 if (objc == 6) { 610 return AliasDelete(interp, slaveInterp, objv[3]); 611 } 612 } else { 613 return AliasCreate(interp, slaveInterp, masterInterp, objv[3], 614 objv[5], objc - 6, objv + 6); 615 } 616 } 617 goto aliasArgs; 618 } 619 case OPT_ALIASES: { 620 Tcl_Interp *slaveInterp; 621 622 slaveInterp = GetInterp2(interp, objc, objv); 623 if (slaveInterp == NULL) { 624 return TCL_ERROR; 625 } 626 return AliasList(interp, slaveInterp); 627 } 628 case OPT_BGERROR: { 629 Tcl_Interp *slaveInterp; 630 631 if (objc != 3 && objc != 4) { 632 Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); 633 return TCL_ERROR; 634 } 635 slaveInterp = GetInterp(interp, objv[2]); 636 if (slaveInterp == NULL) { 637 return TCL_ERROR; 638 } 639 return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); 640 } 641 case OPT_CREATE: { 642 int i, last, safe; 643 Tcl_Obj *slavePtr; 644 char buf[16 + TCL_INTEGER_SPACE]; 645 static const char *options[] = { 646 "-safe", "--", NULL 647 }; 648 enum option { 649 OPT_SAFE, OPT_LAST 650 }; 651 652 safe = Tcl_IsSafe(interp); 653 654 /* 655 * Weird historical rules: "-safe" is accepted at the end, too. 656 */ 657 658 slavePtr = NULL; 659 last = 0; 660 for (i = 2; i < objc; i++) { 661 if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { 662 if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, 663 &index) != TCL_OK) { 664 return TCL_ERROR; 665 } 666 if (index == OPT_SAFE) { 667 safe = 1; 668 continue; 669 } 670 i++; 671 last = 1; 672 } 673 if (slavePtr != NULL) { 674 Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); 675 return TCL_ERROR; 676 } 677 if (i < objc) { 678 slavePtr = objv[i]; 679 } 680 } 681 buf[0] = '\0'; 682 if (slavePtr == NULL) { 683 /* 684 * Create an anonymous interpreter -- we choose its name and the 685 * name of the command. We check that the command name that we use 686 * for the interpreter does not collide with an existing command 687 * in the master interpreter. 688 */ 689 690 for (i = 0; ; i++) { 691 Tcl_CmdInfo cmdInfo; 692 693 sprintf(buf, "interp%d", i); 694 if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { 695 break; 696 } 697 } 698 slavePtr = Tcl_NewStringObj(buf, -1); 699 } 700 if (SlaveCreate(interp, slavePtr, safe) == NULL) { 701 if (buf[0] != '\0') { 702 Tcl_DecrRefCount(slavePtr); 703 } 704 return TCL_ERROR; 705 } 706 Tcl_SetObjResult(interp, slavePtr); 707 return TCL_OK; 708 } 709 case OPT_DELETE: { 710 int i; 711 InterpInfo *iiPtr; 712 Tcl_Interp *slaveInterp; 713 714 for (i = 2; i < objc; i++) { 715 slaveInterp = GetInterp(interp, objv[i]); 716 if (slaveInterp == NULL) { 717 return TCL_ERROR; 718 } else if (slaveInterp == interp) { 719 Tcl_SetObjResult(interp, Tcl_NewStringObj( 720 "cannot delete the current interpreter", -1)); 721 return TCL_ERROR; 722 } 723 iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; 724 Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, 725 iiPtr->slave.interpCmd); 726 } 727 return TCL_OK; 728 } 729 case OPT_EVAL: { 730 Tcl_Interp *slaveInterp; 731 732 if (objc < 4) { 733 Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); 734 return TCL_ERROR; 735 } 736 slaveInterp = GetInterp(interp, objv[2]); 737 if (slaveInterp == NULL) { 738 return TCL_ERROR; 739 } 740 return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); 741 } 742 case OPT_EXISTS: { 743 int exists; 744 Tcl_Interp *slaveInterp; 745 746 exists = 1; 747 slaveInterp = GetInterp2(interp, objc, objv); 748 if (slaveInterp == NULL) { 749 if (objc > 3) { 750 return TCL_ERROR; 751 } 752 Tcl_ResetResult(interp); 753 exists = 0; 754 } 755 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); 756 return TCL_OK; 757 } 758 case OPT_EXPOSE: { 759 Tcl_Interp *slaveInterp; 760 761 if ((objc < 4) || (objc > 5)) { 762 Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); 763 return TCL_ERROR; 764 } 765 slaveInterp = GetInterp(interp, objv[2]); 766 if (slaveInterp == NULL) { 767 return TCL_ERROR; 768 } 769 return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); 770 } 771 case OPT_HIDE: { 772 Tcl_Interp *slaveInterp; /* A slave. */ 773 774 if ((objc < 4) || (objc > 5)) { 775 Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); 776 return TCL_ERROR; 777 } 778 slaveInterp = GetInterp(interp, objv[2]); 779 if (slaveInterp == NULL) { 780 return TCL_ERROR; 781 } 782 return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); 783 } 784 case OPT_HIDDEN: { 785 Tcl_Interp *slaveInterp; /* A slave. */ 786 787 slaveInterp = GetInterp2(interp, objc, objv); 788 if (slaveInterp == NULL) { 789 return TCL_ERROR; 790 } 791 return SlaveHidden(interp, slaveInterp); 792 } 793 case OPT_ISSAFE: { 794 Tcl_Interp *slaveInterp; 795 796 slaveInterp = GetInterp2(interp, objc, objv); 797 if (slaveInterp == NULL) { 798 return TCL_ERROR; 799 } 800 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); 801 return TCL_OK; 802 } 803 case OPT_INVOKEHID: { 804 int i, index; 805 const char *namespaceName; 806 Tcl_Interp *slaveInterp; 807 static const char *hiddenOptions[] = { 808 "-global", "-namespace", "--", NULL 809 }; 810 enum hiddenOption { 811 OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST 812 }; 813 814 namespaceName = NULL; 815 for (i = 3; i < objc; i++) { 816 if (TclGetString(objv[i])[0] != '-') { 817 break; 818 } 819 if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", 820 0, &index) != TCL_OK) { 821 return TCL_ERROR; 822 } 823 if (index == OPT_GLOBAL) { 824 namespaceName = "::"; 825 } else if (index == OPT_NAMESPACE) { 826 if (++i == objc) { /* There must be more arguments. */ 827 break; 828 } else { 829 namespaceName = TclGetString(objv[i]); 830 } 831 } else { 832 i++; 833 break; 834 } 835 } 836 if (objc - i < 1) { 837 Tcl_WrongNumArgs(interp, 2, objv, 838 "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); 839 return TCL_ERROR; 840 } 841 slaveInterp = GetInterp(interp, objv[2]); 842 if (slaveInterp == NULL) { 843 return TCL_ERROR; 844 } 845 return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, 846 objv + i); 847 } 848 case OPT_LIMIT: { 849 Tcl_Interp *slaveInterp; 850 static const char *limitTypes[] = { 851 "commands", "time", NULL 852 }; 853 enum LimitTypes { 854 LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME 855 }; 856 int limitType; 857 858 if (objc < 4) { 859 Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?"); 860 return TCL_ERROR; 861 } 862 slaveInterp = GetInterp(interp, objv[2]); 863 if (slaveInterp == NULL) { 864 return TCL_ERROR; 865 } 866 if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, 867 &limitType) != TCL_OK) { 868 return TCL_ERROR; 869 } 870 switch ((enum LimitTypes) limitType) { 871 case LIMIT_TYPE_COMMANDS: 872 return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); 873 case LIMIT_TYPE_TIME: 874 return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); 875 } 876 } 877 case OPT_MARKTRUSTED: { 878 Tcl_Interp *slaveInterp; 879 880 if (objc != 3) { 881 Tcl_WrongNumArgs(interp, 2, objv, "path"); 882 return TCL_ERROR; 883 } 884 slaveInterp = GetInterp(interp, objv[2]); 885 if (slaveInterp == NULL) { 886 return TCL_ERROR; 887 } 888 return SlaveMarkTrusted(interp, slaveInterp); 889 } 890 case OPT_RECLIMIT: { 891 Tcl_Interp *slaveInterp; 892 893 if (objc != 3 && objc != 4) { 894 Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); 895 return TCL_ERROR; 896 } 897 slaveInterp = GetInterp(interp, objv[2]); 898 if (slaveInterp == NULL) { 899 return TCL_ERROR; 900 } 901 return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); 902 } 903 case OPT_SLAVES: { 904 Tcl_Interp *slaveInterp; 905 InterpInfo *iiPtr; 906 Tcl_Obj *resultPtr; 907 Tcl_HashEntry *hPtr; 908 Tcl_HashSearch hashSearch; 909 char *string; 910 911 slaveInterp = GetInterp2(interp, objc, objv); 912 if (slaveInterp == NULL) { 913 return TCL_ERROR; 914 } 915 iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; 916 resultPtr = Tcl_NewObj(); 917 hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); 918 for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { 919 string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); 920 Tcl_ListObjAppendElement(NULL, resultPtr, 921 Tcl_NewStringObj(string, -1)); 922 } 923 Tcl_SetObjResult(interp, resultPtr); 924 return TCL_OK; 925 } 926 case OPT_TRANSFER: 927 case OPT_SHARE: { 928 Tcl_Interp *slaveInterp; /* A slave. */ 929 Tcl_Interp *masterInterp; /* Its master. */ 930 Tcl_Channel chan; 931 932 if (objc != 5) { 933 Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); 934 return TCL_ERROR; 935 } 936 masterInterp = GetInterp(interp, objv[2]); 937 if (masterInterp == NULL) { 938 return TCL_ERROR; 939 } 940 chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL); 941 if (chan == NULL) { 942 TclTransferResult(masterInterp, TCL_OK, interp); 943 return TCL_ERROR; 944 } 945 slaveInterp = GetInterp(interp, objv[4]); 946 if (slaveInterp == NULL) { 947 return TCL_ERROR; 948 } 949 Tcl_RegisterChannel(slaveInterp, chan); 950 if (index == OPT_TRANSFER) { 951 /* 952 * When transferring, as opposed to sharing, we must unhitch the 953 * channel from the interpreter where it started. 954 */ 955 956 if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { 957 TclTransferResult(masterInterp, TCL_OK, interp); 958 return TCL_ERROR; 959 } 960 } 961 return TCL_OK; 962 } 963 case OPT_TARGET: { 964 Tcl_Interp *slaveInterp; 965 InterpInfo *iiPtr; 966 Tcl_HashEntry *hPtr; 967 Alias *aliasPtr; 968 char *aliasName; 969 970 if (objc != 4) { 971 Tcl_WrongNumArgs(interp, 2, objv, "path alias"); 972 return TCL_ERROR; 973 } 974 975 slaveInterp = GetInterp(interp, objv[2]); 976 if (slaveInterp == NULL) { 977 return TCL_ERROR; 978 } 979 980 aliasName = TclGetString(objv[3]); 981 982 iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; 983 hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); 984 if (hPtr == NULL) { 985 Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", 986 Tcl_GetString(objv[2]), "\" not found", NULL); 987 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, 988 NULL); 989 return TCL_ERROR; 990 } 991 aliasPtr = Tcl_GetHashValue(hPtr); 992 if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { 993 Tcl_ResetResult(interp); 994 Tcl_AppendResult(interp, "target interpreter for alias \"", 995 aliasName, "\" in path \"", Tcl_GetString(objv[2]), 996 "\" is not my descendant", NULL); 997 return TCL_ERROR; 998 } 999 return TCL_OK; 1000 } 1001 } 1002 return TCL_OK; 1003} 1004 1005/* 1006 *--------------------------------------------------------------------------- 1007 * 1008 * GetInterp2 -- 1009 * 1010 * Helper function for Tcl_InterpObjCmd() to convert the interp name 1011 * potentially specified on the command line to an Tcl_Interp. 1012 * 1013 * Results: 1014 * The return value is the interp specified on the command line, or the 1015 * interp argument itself if no interp was specified on the command line. 1016 * If the interp could not be found or the wrong number of arguments was 1017 * specified on the command line, the return value is NULL and an error 1018 * message is left in the interp's result. 1019 * 1020 * Side effects: 1021 * None. 1022 * 1023 *--------------------------------------------------------------------------- 1024 */ 1025 1026static Tcl_Interp * 1027GetInterp2( 1028 Tcl_Interp *interp, /* Default interp if no interp was specified 1029 * on the command line. */ 1030 int objc, /* Number of arguments. */ 1031 Tcl_Obj *const objv[]) /* Argument objects. */ 1032{ 1033 if (objc == 2) { 1034 return interp; 1035 } else if (objc == 3) { 1036 return GetInterp(interp, objv[2]); 1037 } else { 1038 Tcl_WrongNumArgs(interp, 2, objv, "?path?"); 1039 return NULL; 1040 } 1041} 1042 1043/* 1044 *---------------------------------------------------------------------- 1045 * 1046 * Tcl_CreateAlias -- 1047 * 1048 * Creates an alias between two interpreters. 1049 * 1050 * Results: 1051 * A standard Tcl result. 1052 * 1053 * Side effects: 1054 * Creates a new alias, manipulates the result field of slaveInterp. 1055 * 1056 *---------------------------------------------------------------------- 1057 */ 1058 1059int 1060Tcl_CreateAlias( 1061 Tcl_Interp *slaveInterp, /* Interpreter for source command. */ 1062 const char *slaveCmd, /* Command to install in slave. */ 1063 Tcl_Interp *targetInterp, /* Interpreter for target command. */ 1064 const char *targetCmd, /* Name of target command. */ 1065 int argc, /* How many additional arguments? */ 1066 const char *const *argv) /* These are the additional args. */ 1067{ 1068 Tcl_Obj *slaveObjPtr, *targetObjPtr; 1069 Tcl_Obj **objv; 1070 int i; 1071 int result; 1072 1073 objv = (Tcl_Obj **) 1074 TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc); 1075 for (i = 0; i < argc; i++) { 1076 objv[i] = Tcl_NewStringObj(argv[i], -1); 1077 Tcl_IncrRefCount(objv[i]); 1078 } 1079 1080 slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); 1081 Tcl_IncrRefCount(slaveObjPtr); 1082 1083 targetObjPtr = Tcl_NewStringObj(targetCmd, -1); 1084 Tcl_IncrRefCount(targetObjPtr); 1085 1086 result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, 1087 targetObjPtr, argc, objv); 1088 1089 for (i = 0; i < argc; i++) { 1090 Tcl_DecrRefCount(objv[i]); 1091 } 1092 TclStackFree(slaveInterp, objv); 1093 Tcl_DecrRefCount(targetObjPtr); 1094 Tcl_DecrRefCount(slaveObjPtr); 1095 1096 return result; 1097} 1098 1099/* 1100 *---------------------------------------------------------------------- 1101 * 1102 * Tcl_CreateAliasObj -- 1103 * 1104 * Object version: Creates an alias between two interpreters. 1105 * 1106 * Results: 1107 * A standard Tcl result. 1108 * 1109 * Side effects: 1110 * Creates a new alias. 1111 * 1112 *---------------------------------------------------------------------- 1113 */ 1114 1115int 1116Tcl_CreateAliasObj( 1117 Tcl_Interp *slaveInterp, /* Interpreter for source command. */ 1118 const char *slaveCmd, /* Command to install in slave. */ 1119 Tcl_Interp *targetInterp, /* Interpreter for target command. */ 1120 const char *targetCmd, /* Name of target command. */ 1121 int objc, /* How many additional arguments? */ 1122 Tcl_Obj *const objv[]) /* Argument vector. */ 1123{ 1124 Tcl_Obj *slaveObjPtr, *targetObjPtr; 1125 int result; 1126 1127 slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); 1128 Tcl_IncrRefCount(slaveObjPtr); 1129 1130 targetObjPtr = Tcl_NewStringObj(targetCmd, -1); 1131 Tcl_IncrRefCount(targetObjPtr); 1132 1133 result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, 1134 targetObjPtr, objc, objv); 1135 1136 Tcl_DecrRefCount(slaveObjPtr); 1137 Tcl_DecrRefCount(targetObjPtr); 1138 return result; 1139} 1140 1141/* 1142 *---------------------------------------------------------------------- 1143 * 1144 * Tcl_GetAlias -- 1145 * 1146 * Gets information about an alias. 1147 * 1148 * Results: 1149 * A standard Tcl result. 1150 * 1151 * Side effects: 1152 * None. 1153 * 1154 *---------------------------------------------------------------------- 1155 */ 1156 1157int 1158Tcl_GetAlias( 1159 Tcl_Interp *interp, /* Interp to start search from. */ 1160 const char *aliasName, /* Name of alias to find. */ 1161 Tcl_Interp **targetInterpPtr, 1162 /* (Return) target interpreter. */ 1163 const char **targetNamePtr, /* (Return) name of target command. */ 1164 int *argcPtr, /* (Return) count of addnl args. */ 1165 const char ***argvPtr) /* (Return) additional arguments. */ 1166{ 1167 InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; 1168 Tcl_HashEntry *hPtr; 1169 Alias *aliasPtr; 1170 int i, objc; 1171 Tcl_Obj **objv; 1172 1173 hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); 1174 if (hPtr == NULL) { 1175 Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); 1176 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); 1177 return TCL_ERROR; 1178 } 1179 aliasPtr = Tcl_GetHashValue(hPtr); 1180 objc = aliasPtr->objc; 1181 objv = &aliasPtr->objPtr; 1182 1183 if (targetInterpPtr != NULL) { 1184 *targetInterpPtr = aliasPtr->targetInterp; 1185 } 1186 if (targetNamePtr != NULL) { 1187 *targetNamePtr = TclGetString(objv[0]); 1188 } 1189 if (argcPtr != NULL) { 1190 *argcPtr = objc - 1; 1191 } 1192 if (argvPtr != NULL) { 1193 *argvPtr = (const char **) 1194 ckalloc((unsigned) sizeof(const char *) * (objc - 1)); 1195 for (i = 1; i < objc; i++) { 1196 (*argvPtr)[i - 1] = TclGetString(objv[i]); 1197 } 1198 } 1199 return TCL_OK; 1200} 1201 1202/* 1203 *---------------------------------------------------------------------- 1204 * 1205 * Tcl_GetAliasObj -- 1206 * 1207 * Object version: Gets information about an alias. 1208 * 1209 * Results: 1210 * A standard Tcl result. 1211 * 1212 * Side effects: 1213 * None. 1214 * 1215 *---------------------------------------------------------------------- 1216 */ 1217 1218int 1219Tcl_GetAliasObj( 1220 Tcl_Interp *interp, /* Interp to start search from. */ 1221 const char *aliasName, /* Name of alias to find. */ 1222 Tcl_Interp **targetInterpPtr, 1223 /* (Return) target interpreter. */ 1224 const char **targetNamePtr, /* (Return) name of target command. */ 1225 int *objcPtr, /* (Return) count of addnl args. */ 1226 Tcl_Obj ***objvPtr) /* (Return) additional args. */ 1227{ 1228 InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; 1229 Tcl_HashEntry *hPtr; 1230 Alias *aliasPtr; 1231 int objc; 1232 Tcl_Obj **objv; 1233 1234 hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); 1235 if (hPtr == NULL) { 1236 Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); 1237 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); 1238 return TCL_ERROR; 1239 } 1240 aliasPtr = Tcl_GetHashValue(hPtr); 1241 objc = aliasPtr->objc; 1242 objv = &aliasPtr->objPtr; 1243 1244 if (targetInterpPtr != NULL) { 1245 *targetInterpPtr = aliasPtr->targetInterp; 1246 } 1247 if (targetNamePtr != NULL) { 1248 *targetNamePtr = TclGetString(objv[0]); 1249 } 1250 if (objcPtr != NULL) { 1251 *objcPtr = objc - 1; 1252 } 1253 if (objvPtr != NULL) { 1254 *objvPtr = objv + 1; 1255 } 1256 return TCL_OK; 1257} 1258 1259/* 1260 *---------------------------------------------------------------------- 1261 * 1262 * TclPreventAliasLoop -- 1263 * 1264 * When defining an alias or renaming a command, prevent an alias loop 1265 * from being formed. 1266 * 1267 * Results: 1268 * A standard Tcl object result. 1269 * 1270 * Side effects: 1271 * If TCL_ERROR is returned, the function also stores an error message in 1272 * the interpreter's result object. 1273 * 1274 * NOTE: 1275 * This function is public internal (instead of being static to this 1276 * file) because it is also used from TclRenameCommand. 1277 * 1278 *---------------------------------------------------------------------- 1279 */ 1280 1281int 1282TclPreventAliasLoop( 1283 Tcl_Interp *interp, /* Interp in which to report errors. */ 1284 Tcl_Interp *cmdInterp, /* Interp in which the command is being 1285 * defined. */ 1286 Tcl_Command cmd) /* Tcl command we are attempting to define. */ 1287{ 1288 Command *cmdPtr = (Command *) cmd; 1289 Alias *aliasPtr, *nextAliasPtr; 1290 Tcl_Command aliasCmd; 1291 Command *aliasCmdPtr; 1292 1293 /* 1294 * If we are not creating or renaming an alias, then it is always OK to 1295 * create or rename the command. 1296 */ 1297 1298 if (cmdPtr->objProc != AliasObjCmd) { 1299 return TCL_OK; 1300 } 1301 1302 /* 1303 * OK, we are dealing with an alias, so traverse the chain of aliases. If 1304 * we encounter the alias we are defining (or renaming to) any in the 1305 * chain then we have a loop. 1306 */ 1307 1308 aliasPtr = (Alias *) cmdPtr->objClientData; 1309 nextAliasPtr = aliasPtr; 1310 while (1) { 1311 Tcl_Obj *cmdNamePtr; 1312 1313 /* 1314 * If the target of the next alias in the chain is the same as the 1315 * source alias, we have a loop. 1316 */ 1317 1318 if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { 1319 /* 1320 * The slave interpreter can be deleted while creating the alias. 1321 * [Bug #641195] 1322 */ 1323 1324 Tcl_AppendResult(interp, "cannot define or rename alias \"", 1325 Tcl_GetCommandName(cmdInterp, cmd), 1326 "\": interpreter deleted", NULL); 1327 return TCL_ERROR; 1328 } 1329 cmdNamePtr = nextAliasPtr->objPtr; 1330 aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, 1331 TclGetString(cmdNamePtr), 1332 Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), 1333 /*flags*/ 0); 1334 if (aliasCmd == NULL) { 1335 return TCL_OK; 1336 } 1337 aliasCmdPtr = (Command *) aliasCmd; 1338 if (aliasCmdPtr == cmdPtr) { 1339 Tcl_AppendResult(interp, "cannot define or rename alias \"", 1340 Tcl_GetCommandName(cmdInterp, cmd), 1341 "\": would create a loop", NULL); 1342 return TCL_ERROR; 1343 } 1344 1345 /* 1346 * Otherwise, follow the chain one step further. See if the target 1347 * command is an alias - if so, follow the loop to its target command. 1348 * Otherwise we do not have a loop. 1349 */ 1350 1351 if (aliasCmdPtr->objProc != AliasObjCmd) { 1352 return TCL_OK; 1353 } 1354 nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; 1355 } 1356 1357 /* NOTREACHED */ 1358} 1359 1360/* 1361 *---------------------------------------------------------------------- 1362 * 1363 * AliasCreate -- 1364 * 1365 * Helper function to do the work to actually create an alias. 1366 * 1367 * Results: 1368 * A standard Tcl result. 1369 * 1370 * Side effects: 1371 * An alias command is created and entered into the alias table for the 1372 * slave interpreter. 1373 * 1374 *---------------------------------------------------------------------- 1375 */ 1376 1377static int 1378AliasCreate( 1379 Tcl_Interp *interp, /* Interp for error reporting. */ 1380 Tcl_Interp *slaveInterp, /* Interp where alias cmd will live or from 1381 * which alias will be deleted. */ 1382 Tcl_Interp *masterInterp, /* Interp in which target command will be 1383 * invoked. */ 1384 Tcl_Obj *namePtr, /* Name of alias cmd. */ 1385 Tcl_Obj *targetNamePtr, /* Name of target cmd. */ 1386 int objc, /* Additional arguments to store */ 1387 Tcl_Obj *const objv[]) /* with alias. */ 1388{ 1389 Alias *aliasPtr; 1390 Tcl_HashEntry *hPtr; 1391 Target *targetPtr; 1392 Slave *slavePtr; 1393 Master *masterPtr; 1394 Tcl_Obj **prefv; 1395 int isNew, i; 1396 1397 aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) 1398 + objc * sizeof(Tcl_Obj *))); 1399 aliasPtr->token = namePtr; 1400 Tcl_IncrRefCount(aliasPtr->token); 1401 aliasPtr->targetInterp = masterInterp; 1402 1403 aliasPtr->objc = objc + 1; 1404 prefv = &aliasPtr->objPtr; 1405 1406 *prefv = targetNamePtr; 1407 Tcl_IncrRefCount(targetNamePtr); 1408 for (i = 0; i < objc; i++) { 1409 *(++prefv) = objv[i]; 1410 Tcl_IncrRefCount(objv[i]); 1411 } 1412 1413 Tcl_Preserve(slaveInterp); 1414 Tcl_Preserve(masterInterp); 1415 1416 aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, 1417 TclGetString(namePtr), AliasObjCmd, aliasPtr, 1418 AliasObjCmdDeleteProc); 1419 1420 if (TclPreventAliasLoop(interp, slaveInterp, 1421 aliasPtr->slaveCmd) != TCL_OK) { 1422 /* 1423 * Found an alias loop! The last call to Tcl_CreateObjCommand made the 1424 * alias point to itself. Delete the command and its alias record. Be 1425 * careful to wipe out its client data first, so the command doesn't 1426 * try to delete itself. 1427 */ 1428 1429 Command *cmdPtr; 1430 1431 Tcl_DecrRefCount(aliasPtr->token); 1432 Tcl_DecrRefCount(targetNamePtr); 1433 for (i = 0; i < objc; i++) { 1434 Tcl_DecrRefCount(objv[i]); 1435 } 1436 1437 cmdPtr = (Command *) aliasPtr->slaveCmd; 1438 cmdPtr->clientData = NULL; 1439 cmdPtr->deleteProc = NULL; 1440 cmdPtr->deleteData = NULL; 1441 Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); 1442 1443 ckfree((char *) aliasPtr); 1444 1445 /* 1446 * The result was already set by TclPreventAliasLoop. 1447 */ 1448 1449 Tcl_Release(slaveInterp); 1450 Tcl_Release(masterInterp); 1451 return TCL_ERROR; 1452 } 1453 1454 /* 1455 * Make an entry in the alias table. If it already exists, retry. 1456 */ 1457 1458 slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; 1459 while (1) { 1460 Tcl_Obj *newToken; 1461 char *string; 1462 1463 string = TclGetString(aliasPtr->token); 1464 hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew); 1465 if (isNew != 0) { 1466 break; 1467 } 1468 1469 /* 1470 * The alias name cannot be used as unique token, it is already taken. 1471 * We can produce a unique token by prepending "::" repeatedly. This 1472 * algorithm is a stop-gap to try to maintain the command name as 1473 * token for most use cases, fearful of possible backwards compat 1474 * problems. A better algorithm would produce unique tokens that need 1475 * not be related to the command name. 1476 * 1477 * ATTENTION: the tests in interp.test and possibly safe.test depend 1478 * on the precise definition of these tokens. 1479 */ 1480 1481 TclNewLiteralStringObj(newToken, "::"); 1482 Tcl_AppendObjToObj(newToken, aliasPtr->token); 1483 Tcl_DecrRefCount(aliasPtr->token); 1484 aliasPtr->token = newToken; 1485 Tcl_IncrRefCount(aliasPtr->token); 1486 } 1487 1488 aliasPtr->aliasEntryPtr = hPtr; 1489 Tcl_SetHashValue(hPtr, aliasPtr); 1490 1491 /* 1492 * Create the new command. We must do it after deleting any old command, 1493 * because the alias may be pointing at a renamed alias, as in: 1494 * 1495 * interp alias {} foo {} bar # Create an alias "foo" 1496 * rename foo zop # Now rename the alias 1497 * interp alias {} foo {} zop # Now recreate "foo"... 1498 */ 1499 1500 targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); 1501 targetPtr->slaveCmd = aliasPtr->slaveCmd; 1502 targetPtr->slaveInterp = slaveInterp; 1503 1504 masterPtr = &((InterpInfo *) ((Interp*) masterInterp)->interpInfo)->master; 1505 targetPtr->nextPtr = masterPtr->targetsPtr; 1506 targetPtr->prevPtr = NULL; 1507 if (masterPtr->targetsPtr != NULL) { 1508 masterPtr->targetsPtr->prevPtr = targetPtr; 1509 } 1510 masterPtr->targetsPtr = targetPtr; 1511 aliasPtr->targetPtr = targetPtr; 1512 1513 Tcl_SetObjResult(interp, aliasPtr->token); 1514 1515 Tcl_Release(slaveInterp); 1516 Tcl_Release(masterInterp); 1517 return TCL_OK; 1518} 1519 1520/* 1521 *---------------------------------------------------------------------- 1522 * 1523 * AliasDelete -- 1524 * 1525 * Deletes the given alias from the slave interpreter given. 1526 * 1527 * Results: 1528 * A standard Tcl result. 1529 * 1530 * Side effects: 1531 * Deletes the alias from the slave interpreter. 1532 * 1533 *---------------------------------------------------------------------- 1534 */ 1535 1536static int 1537AliasDelete( 1538 Tcl_Interp *interp, /* Interpreter for result & errors. */ 1539 Tcl_Interp *slaveInterp, /* Interpreter containing alias. */ 1540 Tcl_Obj *namePtr) /* Name of alias to delete. */ 1541{ 1542 Slave *slavePtr; 1543 Alias *aliasPtr; 1544 Tcl_HashEntry *hPtr; 1545 1546 /* 1547 * If the alias has been renamed in the slave, the master can still use 1548 * the original name (with which it was created) to find the alias to 1549 * delete it. 1550 */ 1551 1552 slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; 1553 hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); 1554 if (hPtr == NULL) { 1555 Tcl_AppendResult(interp, "alias \"", TclGetString(namePtr), 1556 "\" not found", NULL); 1557 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", 1558 TclGetString(namePtr), NULL); 1559 return TCL_ERROR; 1560 } 1561 aliasPtr = Tcl_GetHashValue(hPtr); 1562 Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); 1563 return TCL_OK; 1564} 1565 1566/* 1567 *---------------------------------------------------------------------- 1568 * 1569 * AliasDescribe -- 1570 * 1571 * Sets the interpreter's result object to a Tcl list describing the 1572 * given alias in the given interpreter: its target command and the 1573 * additional arguments to prepend to any invocation of the alias. 1574 * 1575 * Results: 1576 * A standard Tcl result. 1577 * 1578 * Side effects: 1579 * None. 1580 * 1581 *---------------------------------------------------------------------- 1582 */ 1583 1584static int 1585AliasDescribe( 1586 Tcl_Interp *interp, /* Interpreter for result & errors. */ 1587 Tcl_Interp *slaveInterp, /* Interpreter containing alias. */ 1588 Tcl_Obj *namePtr) /* Name of alias to describe. */ 1589{ 1590 Slave *slavePtr; 1591 Tcl_HashEntry *hPtr; 1592 Alias *aliasPtr; 1593 Tcl_Obj *prefixPtr; 1594 1595 /* 1596 * If the alias has been renamed in the slave, the master can still use 1597 * the original name (with which it was created) to find the alias to 1598 * describe it. 1599 */ 1600 1601 slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; 1602 hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); 1603 if (hPtr == NULL) { 1604 return TCL_OK; 1605 } 1606 aliasPtr = Tcl_GetHashValue(hPtr); 1607 prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr); 1608 Tcl_SetObjResult(interp, prefixPtr); 1609 return TCL_OK; 1610} 1611 1612/* 1613 *---------------------------------------------------------------------- 1614 * 1615 * AliasList -- 1616 * 1617 * Computes a list of aliases defined in a slave interpreter. 1618 * 1619 * Results: 1620 * A standard Tcl result. 1621 * 1622 * Side effects: 1623 * None. 1624 * 1625 *---------------------------------------------------------------------- 1626 */ 1627 1628static int 1629AliasList( 1630 Tcl_Interp *interp, /* Interp for data return. */ 1631 Tcl_Interp *slaveInterp) /* Interp whose aliases to compute. */ 1632{ 1633 Tcl_HashEntry *entryPtr; 1634 Tcl_HashSearch hashSearch; 1635 Tcl_Obj *resultPtr = Tcl_NewObj(); 1636 Alias *aliasPtr; 1637 Slave *slavePtr; 1638 1639 slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; 1640 1641 entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); 1642 for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { 1643 aliasPtr = Tcl_GetHashValue(entryPtr); 1644 Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); 1645 } 1646 Tcl_SetObjResult(interp, resultPtr); 1647 return TCL_OK; 1648} 1649 1650/* 1651 *---------------------------------------------------------------------- 1652 * 1653 * AliasObjCmd -- 1654 * 1655 * This is the function that services invocations of aliases in a slave 1656 * interpreter. One such command exists for each alias. When invoked, 1657 * this function redirects the invocation to the target command in the 1658 * master interpreter as designated by the Alias record associated with 1659 * this command. 1660 * 1661 * Results: 1662 * A standard Tcl result. 1663 * 1664 * Side effects: 1665 * Causes forwarding of the invocation; all possible side effects may 1666 * occur as a result of invoking the command to which the invocation is 1667 * forwarded. 1668 * 1669 *---------------------------------------------------------------------- 1670 */ 1671 1672static int 1673AliasObjCmd( 1674 ClientData clientData, /* Alias record. */ 1675 Tcl_Interp *interp, /* Current interpreter. */ 1676 int objc, /* Number of arguments. */ 1677 Tcl_Obj *const objv[]) /* Argument vector. */ 1678{ 1679#define ALIAS_CMDV_PREALLOC 10 1680 Alias *aliasPtr = clientData; 1681 Tcl_Interp *targetInterp = aliasPtr->targetInterp; 1682 int result, prefc, cmdc, i; 1683 Tcl_Obj **prefv, **cmdv; 1684 Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; 1685 Interp *tPtr = (Interp *) targetInterp; 1686 int isRootEnsemble = (tPtr->ensembleRewrite.sourceObjs == NULL); 1687 1688 /* 1689 * Append the arguments to the command prefix and invoke the command in 1690 * the target interp's global namespace. 1691 */ 1692 1693 prefc = aliasPtr->objc; 1694 prefv = &aliasPtr->objPtr; 1695 cmdc = prefc + objc - 1; 1696 if (cmdc <= ALIAS_CMDV_PREALLOC) { 1697 cmdv = cmdArr; 1698 } else { 1699 cmdv = (Tcl_Obj **) TclStackAlloc(interp, cmdc*(int)sizeof(Tcl_Obj*)); 1700 } 1701 1702 prefv = &aliasPtr->objPtr; 1703 memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); 1704 memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); 1705 1706 Tcl_ResetResult(targetInterp); 1707 1708 for (i=0; i<cmdc; i++) { 1709 Tcl_IncrRefCount(cmdv[i]); 1710 } 1711 1712 /* 1713 * Use the ensemble rewriting machinery to ensure correct error messages: 1714 * only the source command should show, not the full target prefix. 1715 */ 1716 1717 if (isRootEnsemble) { 1718 tPtr->ensembleRewrite.sourceObjs = objv; 1719 tPtr->ensembleRewrite.numRemovedObjs = 1; 1720 tPtr->ensembleRewrite.numInsertedObjs = prefc; 1721 } else { 1722 tPtr->ensembleRewrite.numInsertedObjs += prefc - 1; 1723 } 1724 1725 /* 1726 * Protect the target interpreter if it isn't the same as the source 1727 * interpreter so that we can continue to work with it after the target 1728 * command completes. 1729 */ 1730 1731 if (targetInterp != interp) { 1732 Tcl_Preserve(targetInterp); 1733 } 1734 1735 /* 1736 * Execute the target command in the target interpreter. 1737 */ 1738 1739 result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); 1740 1741 /* 1742 * Clean up the ensemble rewrite info if we set it in the first place. 1743 */ 1744 1745 if (isRootEnsemble) { 1746 tPtr->ensembleRewrite.sourceObjs = NULL; 1747 tPtr->ensembleRewrite.numRemovedObjs = 0; 1748 tPtr->ensembleRewrite.numInsertedObjs = 0; 1749 } 1750 1751 /* 1752 * If it was a cross-interpreter alias, we need to transfer the result 1753 * back to the source interpreter and release the lock we previously set 1754 * on the target interpreter. 1755 */ 1756 1757 if (targetInterp != interp) { 1758 TclTransferResult(targetInterp, result, interp); 1759 Tcl_Release(targetInterp); 1760 } 1761 1762 for (i=0; i<cmdc; i++) { 1763 Tcl_DecrRefCount(cmdv[i]); 1764 } 1765 if (cmdv != cmdArr) { 1766 TclStackFree(interp, cmdv); 1767 } 1768 return result; 1769#undef ALIAS_CMDV_PREALLOC 1770} 1771 1772/* 1773 *---------------------------------------------------------------------- 1774 * 1775 * AliasObjCmdDeleteProc -- 1776 * 1777 * Is invoked when an alias command is deleted in a slave. Cleans up all 1778 * storage associated with this alias. 1779 * 1780 * Results: 1781 * None. 1782 * 1783 * Side effects: 1784 * Deletes the alias record and its entry in the alias table for the 1785 * interpreter. 1786 * 1787 *---------------------------------------------------------------------- 1788 */ 1789 1790static void 1791AliasObjCmdDeleteProc( 1792 ClientData clientData) /* The alias record for this alias. */ 1793{ 1794 Alias *aliasPtr = clientData; 1795 Target *targetPtr; 1796 int i; 1797 Tcl_Obj **objv; 1798 1799 Tcl_DecrRefCount(aliasPtr->token); 1800 objv = &aliasPtr->objPtr; 1801 for (i = 0; i < aliasPtr->objc; i++) { 1802 Tcl_DecrRefCount(objv[i]); 1803 } 1804 Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr); 1805 1806 /* 1807 * Splice the target record out of the target interpreter's master list. 1808 */ 1809 1810 targetPtr = aliasPtr->targetPtr; 1811 if (targetPtr->prevPtr != NULL) { 1812 targetPtr->prevPtr->nextPtr = targetPtr->nextPtr; 1813 } else { 1814 Master *masterPtr = &((InterpInfo *) ((Interp *) 1815 aliasPtr->targetInterp)->interpInfo)->master; 1816 1817 masterPtr->targetsPtr = targetPtr->nextPtr; 1818 } 1819 if (targetPtr->nextPtr != NULL) { 1820 targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; 1821 } 1822 1823 ckfree((char *) targetPtr); 1824 ckfree((char *) aliasPtr); 1825} 1826 1827/* 1828 *---------------------------------------------------------------------- 1829 * 1830 * Tcl_CreateSlave -- 1831 * 1832 * Creates a slave interpreter. The slavePath argument denotes the name 1833 * of the new slave relative to the current interpreter; the slave is a 1834 * direct descendant of the one-before-last component of the path, 1835 * e.g. it is a descendant of the current interpreter if the slavePath 1836 * argument contains only one component. Optionally makes the slave 1837 * interpreter safe. 1838 * 1839 * Results: 1840 * Returns the interpreter structure created, or NULL if an error 1841 * occurred. 1842 * 1843 * Side effects: 1844 * Creates a new interpreter and a new interpreter object command in the 1845 * interpreter indicated by the slavePath argument. 1846 * 1847 *---------------------------------------------------------------------- 1848 */ 1849 1850Tcl_Interp * 1851Tcl_CreateSlave( 1852 Tcl_Interp *interp, /* Interpreter to start search at. */ 1853 const char *slavePath, /* Name of slave to create. */ 1854 int isSafe) /* Should new slave be "safe" ? */ 1855{ 1856 Tcl_Obj *pathPtr; 1857 Tcl_Interp *slaveInterp; 1858 1859 pathPtr = Tcl_NewStringObj(slavePath, -1); 1860 slaveInterp = SlaveCreate(interp, pathPtr, isSafe); 1861 Tcl_DecrRefCount(pathPtr); 1862 1863 return slaveInterp; 1864} 1865 1866/* 1867 *---------------------------------------------------------------------- 1868 * 1869 * Tcl_GetSlave -- 1870 * 1871 * Finds a slave interpreter by its path name. 1872 * 1873 * Results: 1874 * Returns a Tcl_Interp * for the named interpreter or NULL if not found. 1875 * 1876 * Side effects: 1877 * None. 1878 * 1879 *---------------------------------------------------------------------- 1880 */ 1881 1882Tcl_Interp * 1883Tcl_GetSlave( 1884 Tcl_Interp *interp, /* Interpreter to start search from. */ 1885 const char *slavePath) /* Path of slave to find. */ 1886{ 1887 Tcl_Obj *pathPtr; 1888 Tcl_Interp *slaveInterp; 1889 1890 pathPtr = Tcl_NewStringObj(slavePath, -1); 1891 slaveInterp = GetInterp(interp, pathPtr); 1892 Tcl_DecrRefCount(pathPtr); 1893 1894 return slaveInterp; 1895} 1896 1897/* 1898 *---------------------------------------------------------------------- 1899 * 1900 * Tcl_GetMaster -- 1901 * 1902 * Finds the master interpreter of a slave interpreter. 1903 * 1904 * Results: 1905 * Returns a Tcl_Interp * for the master interpreter or NULL if none. 1906 * 1907 * Side effects: 1908 * None. 1909 * 1910 *---------------------------------------------------------------------- 1911 */ 1912 1913Tcl_Interp * 1914Tcl_GetMaster( 1915 Tcl_Interp *interp) /* Get the master of this interpreter. */ 1916{ 1917 Slave *slavePtr; /* Slave record of this interpreter. */ 1918 1919 if (interp == NULL) { 1920 return NULL; 1921 } 1922 slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; 1923 return slavePtr->masterInterp; 1924} 1925 1926/* 1927 *---------------------------------------------------------------------- 1928 * 1929 * Tcl_GetInterpPath -- 1930 * 1931 * Sets the result of the asking interpreter to a proper Tcl list 1932 * containing the names of interpreters between the asking and target 1933 * interpreters. The target interpreter must be either the same as the 1934 * asking interpreter or one of its slaves (including recursively). 1935 * 1936 * Results: 1937 * TCL_OK if the target interpreter is the same as, or a descendant of, 1938 * the asking interpreter; TCL_ERROR else. This way one can distinguish 1939 * between the case where the asking and target interps are the same (an 1940 * empty list is the result, and TCL_OK is returned) and when the target 1941 * is not a descendant of the asking interpreter (in which case the Tcl 1942 * result is an error message and the function returns TCL_ERROR). 1943 * 1944 * Side effects: 1945 * None. 1946 * 1947 *---------------------------------------------------------------------- 1948 */ 1949 1950int 1951Tcl_GetInterpPath( 1952 Tcl_Interp *askingInterp, /* Interpreter to start search from. */ 1953 Tcl_Interp *targetInterp) /* Interpreter to find. */ 1954{ 1955 InterpInfo *iiPtr; 1956 1957 if (targetInterp == askingInterp) { 1958 return TCL_OK; 1959 } 1960 if (targetInterp == NULL) { 1961 return TCL_ERROR; 1962 } 1963 iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; 1964 if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { 1965 return TCL_ERROR; 1966 } 1967 Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable, 1968 iiPtr->slave.slaveEntryPtr)); 1969 return TCL_OK; 1970} 1971 1972/* 1973 *---------------------------------------------------------------------- 1974 * 1975 * GetInterp -- 1976 * 1977 * Helper function to find a slave interpreter given a pathname. 1978 * 1979 * Results: 1980 * Returns the slave interpreter known by that name in the calling 1981 * interpreter, or NULL if no interpreter known by that name exists. 1982 * 1983 * Side effects: 1984 * Assigns to the pointer variable passed in, if not NULL. 1985 * 1986 *---------------------------------------------------------------------- 1987 */ 1988 1989static Tcl_Interp * 1990GetInterp( 1991 Tcl_Interp *interp, /* Interp. to start search from. */ 1992 Tcl_Obj *pathPtr) /* List object containing name of interp. to 1993 * be found. */ 1994{ 1995 Tcl_HashEntry *hPtr; /* Search element. */ 1996 Slave *slavePtr; /* Interim slave record. */ 1997 Tcl_Obj **objv; 1998 int objc, i; 1999 Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ 2000 InterpInfo *masterInfoPtr; 2001 2002 if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { 2003 return NULL; 2004 } 2005 2006 searchInterp = interp; 2007 for (i = 0; i < objc; i++) { 2008 masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; 2009 hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, 2010 TclGetString(objv[i])); 2011 if (hPtr == NULL) { 2012 searchInterp = NULL; 2013 break; 2014 } 2015 slavePtr = Tcl_GetHashValue(hPtr); 2016 searchInterp = slavePtr->slaveInterp; 2017 if (searchInterp == NULL) { 2018 break; 2019 } 2020 } 2021 if (searchInterp == NULL) { 2022 Tcl_AppendResult(interp, "could not find interpreter \"", 2023 TclGetString(pathPtr), "\"", NULL); 2024 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP", 2025 TclGetString(pathPtr), NULL); 2026 } 2027 return searchInterp; 2028} 2029 2030/* 2031 *---------------------------------------------------------------------- 2032 * 2033 * SlaveBgerror -- 2034 * 2035 * Helper function to set/query the background error handling command 2036 * prefix of an interp 2037 * 2038 * Results: 2039 * A standard Tcl result. 2040 * 2041 * Side effects: 2042 * When (objc == 1), slaveInterp will be set to a new background handler 2043 * of objv[0]. 2044 * 2045 *---------------------------------------------------------------------- 2046 */ 2047 2048static int 2049SlaveBgerror( 2050 Tcl_Interp *interp, /* Interp for error return. */ 2051 Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ 2052 int objc, /* Set or Query. */ 2053 Tcl_Obj *const objv[]) /* Argument strings. */ 2054{ 2055 if (objc) { 2056 int length; 2057 2058 if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) 2059 || (length < 1)) { 2060 Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", 2061 NULL); 2062 return TCL_ERROR; 2063 } 2064 TclSetBgErrorHandler(slaveInterp, objv[0]); 2065 } 2066 Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp)); 2067 return TCL_OK; 2068} 2069 2070/* 2071 *---------------------------------------------------------------------- 2072 * 2073 * SlaveCreate -- 2074 * 2075 * Helper function to do the actual work of creating a slave interp and 2076 * new object command. Also optionally makes the new slave interpreter 2077 * "safe". 2078 * 2079 * Results: 2080 * Returns the new Tcl_Interp * if successful or NULL if not. If failed, 2081 * the result of the invoking interpreter contains an error message. 2082 * 2083 * Side effects: 2084 * Creates a new slave interpreter and a new object command. 2085 * 2086 *---------------------------------------------------------------------- 2087 */ 2088 2089static Tcl_Interp * 2090SlaveCreate( 2091 Tcl_Interp *interp, /* Interp. to start search from. */ 2092 Tcl_Obj *pathPtr, /* Path (name) of slave to create. */ 2093 int safe) /* Should we make it "safe"? */ 2094{ 2095 Tcl_Interp *masterInterp, *slaveInterp; 2096 Slave *slavePtr; 2097 InterpInfo *masterInfoPtr; 2098 Tcl_HashEntry *hPtr; 2099 char *path; 2100 int isNew, objc; 2101 Tcl_Obj **objv; 2102 2103 if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { 2104 return NULL; 2105 } 2106 if (objc < 2) { 2107 masterInterp = interp; 2108 path = TclGetString(pathPtr); 2109 } else { 2110 Tcl_Obj *objPtr; 2111 2112 objPtr = Tcl_NewListObj(objc - 1, objv); 2113 masterInterp = GetInterp(interp, objPtr); 2114 Tcl_DecrRefCount(objPtr); 2115 if (masterInterp == NULL) { 2116 return NULL; 2117 } 2118 path = TclGetString(objv[objc - 1]); 2119 } 2120 if (safe == 0) { 2121 safe = Tcl_IsSafe(masterInterp); 2122 } 2123 2124 masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; 2125 hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, 2126 &isNew); 2127 if (isNew == 0) { 2128 Tcl_AppendResult(interp, "interpreter named \"", path, 2129 "\" already exists, cannot create", NULL); 2130 return NULL; 2131 } 2132 2133 slaveInterp = Tcl_CreateInterp(); 2134 slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; 2135 slavePtr->masterInterp = masterInterp; 2136 slavePtr->slaveEntryPtr = hPtr; 2137 slavePtr->slaveInterp = slaveInterp; 2138 slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, 2139 SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); 2140 Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); 2141 Tcl_SetHashValue(hPtr, slavePtr); 2142 Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); 2143 2144 /* 2145 * Inherit the recursion limit. 2146 */ 2147 2148 ((Interp *) slaveInterp)->maxNestingDepth = 2149 ((Interp *) masterInterp)->maxNestingDepth; 2150 2151 if (safe) { 2152 if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { 2153 goto error; 2154 } 2155 } else { 2156 if (Tcl_Init(slaveInterp) == TCL_ERROR) { 2157 goto error; 2158 } 2159 2160 /* 2161 * This will create the "memory" command in slave interpreters if we 2162 * compiled with TCL_MEM_DEBUG, otherwise it does nothing. 2163 */ 2164 2165 Tcl_InitMemory(slaveInterp); 2166 } 2167 2168 /* 2169 * Inherit the TIP#143 limits. 2170 */ 2171 2172 InheritLimitsFromMaster(slaveInterp, masterInterp); 2173 2174 /* 2175 * The [clock] command presents a safe API, but uses unsafe features in 2176 * its implementation. This means it has to be implemented in safe interps 2177 * as an alias to a version in the (trusted) master. 2178 */ 2179 2180 if (safe) { 2181 Tcl_Obj *clockObj; 2182 int status; 2183 2184 TclNewLiteralStringObj(clockObj, "clock"); 2185 Tcl_IncrRefCount(clockObj); 2186 status = AliasCreate(interp, slaveInterp, masterInterp, clockObj, 2187 clockObj, 0, NULL); 2188 Tcl_DecrRefCount(clockObj); 2189 if (status != TCL_OK) { 2190 goto error2; 2191 } 2192 } 2193 2194 return slaveInterp; 2195 2196 error: 2197 TclTransferResult(slaveInterp, TCL_ERROR, interp); 2198 error2: 2199 Tcl_DeleteInterp(slaveInterp); 2200 2201 return NULL; 2202} 2203 2204/* 2205 *---------------------------------------------------------------------- 2206 * 2207 * SlaveObjCmd -- 2208 * 2209 * Command to manipulate an interpreter, e.g. to send commands to it to 2210 * be evaluated. One such command exists for each slave interpreter. 2211 * 2212 * Results: 2213 * A standard Tcl result. 2214 * 2215 * Side effects: 2216 * See user documentation for details. 2217 * 2218 *---------------------------------------------------------------------- 2219 */ 2220 2221static int 2222SlaveObjCmd( 2223 ClientData clientData, /* Slave interpreter. */ 2224 Tcl_Interp *interp, /* Current interpreter. */ 2225 int objc, /* Number of arguments. */ 2226 Tcl_Obj *const objv[]) /* Argument objects. */ 2227{ 2228 Tcl_Interp *slaveInterp = clientData; 2229 int index; 2230 static const char *options[] = { 2231 "alias", "aliases", "bgerror", "eval", 2232 "expose", "hide", "hidden", "issafe", 2233 "invokehidden", "limit", "marktrusted", "recursionlimit", NULL 2234 }; 2235 enum options { 2236 OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_EVAL, 2237 OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, 2238 OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT 2239 }; 2240 2241 if (slaveInterp == NULL) { 2242 Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); 2243 } 2244 2245 if (objc < 2) { 2246 Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); 2247 return TCL_ERROR; 2248 } 2249 if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, 2250 &index) != TCL_OK) { 2251 return TCL_ERROR; 2252 } 2253 2254 switch ((enum options) index) { 2255 case OPT_ALIAS: 2256 if (objc > 2) { 2257 if (objc == 3) { 2258 return AliasDescribe(interp, slaveInterp, objv[2]); 2259 } 2260 if (TclGetString(objv[3])[0] == '\0') { 2261 if (objc == 4) { 2262 return AliasDelete(interp, slaveInterp, objv[2]); 2263 } 2264 } else { 2265 return AliasCreate(interp, slaveInterp, interp, objv[2], 2266 objv[3], objc - 4, objv + 4); 2267 } 2268 } 2269 Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?args..?"); 2270 return TCL_ERROR; 2271 case OPT_ALIASES: 2272 if (objc != 2) { 2273 Tcl_WrongNumArgs(interp, 2, objv, NULL); 2274 return TCL_ERROR; 2275 } 2276 return AliasList(interp, slaveInterp); 2277 case OPT_BGERROR: 2278 if (objc != 2 && objc != 3) { 2279 Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); 2280 return TCL_ERROR; 2281 } 2282 return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); 2283 case OPT_EVAL: 2284 if (objc < 3) { 2285 Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); 2286 return TCL_ERROR; 2287 } 2288 return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); 2289 case OPT_EXPOSE: 2290 if ((objc < 3) || (objc > 4)) { 2291 Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); 2292 return TCL_ERROR; 2293 } 2294 return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); 2295 case OPT_HIDE: 2296 if ((objc < 3) || (objc > 4)) { 2297 Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); 2298 return TCL_ERROR; 2299 } 2300 return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); 2301 case OPT_HIDDEN: 2302 if (objc != 2) { 2303 Tcl_WrongNumArgs(interp, 2, objv, NULL); 2304 return TCL_ERROR; 2305 } 2306 return SlaveHidden(interp, slaveInterp); 2307 case OPT_ISSAFE: 2308 if (objc != 2) { 2309 Tcl_WrongNumArgs(interp, 2, objv, NULL); 2310 return TCL_ERROR; 2311 } 2312 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); 2313 return TCL_OK; 2314 case OPT_INVOKEHIDDEN: { 2315 int i, index; 2316 const char *namespaceName; 2317 static const char *hiddenOptions[] = { 2318 "-global", "-namespace", "--", NULL 2319 }; 2320 enum hiddenOption { 2321 OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST 2322 }; 2323 2324 namespaceName = NULL; 2325 for (i = 2; i < objc; i++) { 2326 if (TclGetString(objv[i])[0] != '-') { 2327 break; 2328 } 2329 if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", 2330 0, &index) != TCL_OK) { 2331 return TCL_ERROR; 2332 } 2333 if (index == OPT_GLOBAL) { 2334 namespaceName = "::"; 2335 } else if (index == OPT_NAMESPACE) { 2336 if (++i == objc) { /* There must be more arguments. */ 2337 break; 2338 } else { 2339 namespaceName = TclGetString(objv[i]); 2340 } 2341 } else { 2342 i++; 2343 break; 2344 } 2345 } 2346 if (objc - i < 1) { 2347 Tcl_WrongNumArgs(interp, 2, objv, 2348 "?-namespace ns? ?-global? ?--? cmd ?arg ..?"); 2349 return TCL_ERROR; 2350 } 2351 return SlaveInvokeHidden(interp, slaveInterp, namespaceName, 2352 objc - i, objv + i); 2353 } 2354 case OPT_LIMIT: { 2355 static const char *limitTypes[] = { 2356 "commands", "time", NULL 2357 }; 2358 enum LimitTypes { 2359 LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME 2360 }; 2361 int limitType; 2362 2363 if (objc < 3) { 2364 Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?"); 2365 return TCL_ERROR; 2366 } 2367 if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, 2368 &limitType) != TCL_OK) { 2369 return TCL_ERROR; 2370 } 2371 switch ((enum LimitTypes) limitType) { 2372 case LIMIT_TYPE_COMMANDS: 2373 return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); 2374 case LIMIT_TYPE_TIME: 2375 return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); 2376 } 2377 } 2378 case OPT_MARKTRUSTED: 2379 if (objc != 2) { 2380 Tcl_WrongNumArgs(interp, 2, objv, NULL); 2381 return TCL_ERROR; 2382 } 2383 return SlaveMarkTrusted(interp, slaveInterp); 2384 case OPT_RECLIMIT: 2385 if (objc != 2 && objc != 3) { 2386 Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); 2387 return TCL_ERROR; 2388 } 2389 return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); 2390 } 2391 2392 return TCL_ERROR; 2393} 2394 2395/* 2396 *---------------------------------------------------------------------- 2397 * 2398 * SlaveObjCmdDeleteProc -- 2399 * 2400 * Invoked when an object command for a slave interpreter is deleted; 2401 * cleans up all state associated with the slave interpreter and destroys 2402 * the slave interpreter. 2403 * 2404 * Results: 2405 * None. 2406 * 2407 * Side effects: 2408 * Cleans up all state associated with the slave interpreter and destroys 2409 * the slave interpreter. 2410 * 2411 *---------------------------------------------------------------------- 2412 */ 2413 2414static void 2415SlaveObjCmdDeleteProc( 2416 ClientData clientData) /* The SlaveRecord for the command. */ 2417{ 2418 Slave *slavePtr; /* Interim storage for Slave record. */ 2419 Tcl_Interp *slaveInterp = clientData; 2420 /* And for a slave interp. */ 2421 2422 slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; 2423 2424 /* 2425 * Unlink the slave from its master interpreter. 2426 */ 2427 2428 Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); 2429 2430 /* 2431 * Set to NULL so that when the InterpInfo is cleaned up in the slave it 2432 * does not try to delete the command causing all sorts of grief. See 2433 * SlaveRecordDeleteProc(). 2434 */ 2435 2436 slavePtr->interpCmd = NULL; 2437 2438 if (slavePtr->slaveInterp != NULL) { 2439 Tcl_DeleteInterp(slavePtr->slaveInterp); 2440 } 2441} 2442 2443/* 2444 *---------------------------------------------------------------------- 2445 * 2446 * SlaveEval -- 2447 * 2448 * Helper function to evaluate a command in a slave interpreter. 2449 * 2450 * Results: 2451 * A standard Tcl result. 2452 * 2453 * Side effects: 2454 * Whatever the command does. 2455 * 2456 *---------------------------------------------------------------------- 2457 */ 2458 2459static int 2460SlaveEval( 2461 Tcl_Interp *interp, /* Interp for error return. */ 2462 Tcl_Interp *slaveInterp, /* The slave interpreter in which command 2463 * will be evaluated. */ 2464 int objc, /* Number of arguments. */ 2465 Tcl_Obj *const objv[]) /* Argument objects. */ 2466{ 2467 int result; 2468 Tcl_Obj *objPtr; 2469 2470 Tcl_Preserve(slaveInterp); 2471 Tcl_AllowExceptions(slaveInterp); 2472 2473 if (objc == 1) { 2474 /* 2475 * TIP #280: Make actual argument location available to eval'd script. 2476 */ 2477 2478 Interp *iPtr = (Interp *) interp; 2479 CmdFrame* invoker = iPtr->cmdFramePtr; 2480 int word = 0; 2481 2482 TclArgumentGet (interp, objv[0], &invoker, &word); 2483 result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word); 2484 } else { 2485 objPtr = Tcl_ConcatObj(objc, objv); 2486 Tcl_IncrRefCount(objPtr); 2487 result = Tcl_EvalObjEx(slaveInterp, objPtr, 0); 2488 Tcl_DecrRefCount(objPtr); 2489 } 2490 TclTransferResult(slaveInterp, result, interp); 2491 2492 Tcl_Release(slaveInterp); 2493 return result; 2494} 2495 2496/* 2497 *---------------------------------------------------------------------- 2498 * 2499 * SlaveExpose -- 2500 * 2501 * Helper function to expose a command in a slave interpreter. 2502 * 2503 * Results: 2504 * A standard Tcl result. 2505 * 2506 * Side effects: 2507 * After this call scripts in the slave will be able to invoke the newly 2508 * exposed command. 2509 * 2510 *---------------------------------------------------------------------- 2511 */ 2512 2513static int 2514SlaveExpose( 2515 Tcl_Interp *interp, /* Interp for error return. */ 2516 Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ 2517 int objc, /* Number of arguments. */ 2518 Tcl_Obj *const objv[]) /* Argument strings. */ 2519{ 2520 char *name; 2521 2522 if (Tcl_IsSafe(interp)) { 2523 Tcl_SetObjResult(interp, Tcl_NewStringObj( 2524 "permission denied: safe interpreter cannot expose commands", 2525 -1)); 2526 return TCL_ERROR; 2527 } 2528 2529 name = TclGetString(objv[(objc == 1) ? 0 : 1]); 2530 if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]), 2531 name) != TCL_OK) { 2532 TclTransferResult(slaveInterp, TCL_ERROR, interp); 2533 return TCL_ERROR; 2534 } 2535 return TCL_OK; 2536} 2537 2538/* 2539 *---------------------------------------------------------------------- 2540 * 2541 * SlaveRecursionLimit -- 2542 * 2543 * Helper function to set/query the Recursion limit of an interp 2544 * 2545 * Results: 2546 * A standard Tcl result. 2547 * 2548 * Side effects: 2549 * When (objc == 1), slaveInterp will be set to a new recursion limit of 2550 * objv[0]. 2551 * 2552 *---------------------------------------------------------------------- 2553 */ 2554 2555static int 2556SlaveRecursionLimit( 2557 Tcl_Interp *interp, /* Interp for error return. */ 2558 Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ 2559 int objc, /* Set or Query. */ 2560 Tcl_Obj *const objv[]) /* Argument strings. */ 2561{ 2562 Interp *iPtr; 2563 int limit; 2564 2565 if (objc) { 2566 if (Tcl_IsSafe(interp)) { 2567 Tcl_AppendResult(interp, "permission denied: " 2568 "safe interpreters cannot change recursion limit", NULL); 2569 return TCL_ERROR; 2570 } 2571 if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { 2572 return TCL_ERROR; 2573 } 2574 if (limit <= 0) { 2575 Tcl_SetObjResult(interp, Tcl_NewStringObj( 2576 "recursion limit must be > 0", -1)); 2577 return TCL_ERROR; 2578 } 2579 Tcl_SetRecursionLimit(slaveInterp, limit); 2580 iPtr = (Interp *) slaveInterp; 2581 if (interp == slaveInterp && iPtr->numLevels > limit) { 2582 Tcl_SetObjResult(interp, Tcl_NewStringObj( 2583 "falling back due to new recursion limit", -1)); 2584 return TCL_ERROR; 2585 } 2586 Tcl_SetObjResult(interp, objv[0]); 2587 return TCL_OK; 2588 } else { 2589 limit = Tcl_SetRecursionLimit(slaveInterp, 0); 2590 Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); 2591 return TCL_OK; 2592 } 2593} 2594 2595/* 2596 *---------------------------------------------------------------------- 2597 * 2598 * SlaveHide -- 2599 * 2600 * Helper function to hide a command in a slave interpreter. 2601 * 2602 * Results: 2603 * A standard Tcl result. 2604 * 2605 * Side effects: 2606 * After this call scripts in the slave will no longer be able to invoke 2607 * the named command. 2608 * 2609 *---------------------------------------------------------------------- 2610 */ 2611 2612static int 2613SlaveHide( 2614 Tcl_Interp *interp, /* Interp for error return. */ 2615 Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ 2616 int objc, /* Number of arguments. */ 2617 Tcl_Obj *const objv[]) /* Argument strings. */ 2618{ 2619 char *name; 2620 2621 if (Tcl_IsSafe(interp)) { 2622 Tcl_SetObjResult(interp, Tcl_NewStringObj( 2623 "permission denied: safe interpreter cannot hide commands", 2624 -1)); 2625 return TCL_ERROR; 2626 } 2627 2628 name = TclGetString(objv[(objc == 1) ? 0 : 1]); 2629 if (Tcl_HideCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) { 2630 TclTransferResult(slaveInterp, TCL_ERROR, interp); 2631 return TCL_ERROR; 2632 } 2633 return TCL_OK; 2634} 2635 2636/* 2637 *---------------------------------------------------------------------- 2638 * 2639 * SlaveHidden -- 2640 * 2641 * Helper function to compute list of hidden commands in a slave 2642 * interpreter. 2643 * 2644 * Results: 2645 * A standard Tcl result. 2646 * 2647 * Side effects: 2648 * None. 2649 * 2650 *---------------------------------------------------------------------- 2651 */ 2652 2653static int 2654SlaveHidden( 2655 Tcl_Interp *interp, /* Interp for data return. */ 2656 Tcl_Interp *slaveInterp) /* Interp whose hidden commands to query. */ 2657{ 2658 Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */ 2659 Tcl_HashTable *hTblPtr; /* For local searches. */ 2660 Tcl_HashEntry *hPtr; /* For local searches. */ 2661 Tcl_HashSearch hSearch; /* For local searches. */ 2662 2663 hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; 2664 if (hTblPtr != NULL) { 2665 for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); 2666 hPtr != NULL; 2667 hPtr = Tcl_NextHashEntry(&hSearch)) { 2668 Tcl_ListObjAppendElement(NULL, listObjPtr, 2669 Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); 2670 } 2671 } 2672 Tcl_SetObjResult(interp, listObjPtr); 2673 return TCL_OK; 2674} 2675 2676/* 2677 *---------------------------------------------------------------------- 2678 * 2679 * SlaveInvokeHidden -- 2680 * 2681 * Helper function to invoke a hidden command in a slave interpreter. 2682 * 2683 * Results: 2684 * A standard Tcl result. 2685 * 2686 * Side effects: 2687 * Whatever the hidden command does. 2688 * 2689 *---------------------------------------------------------------------- 2690 */ 2691 2692static int 2693SlaveInvokeHidden( 2694 Tcl_Interp *interp, /* Interp for error return. */ 2695 Tcl_Interp *slaveInterp, /* The slave interpreter in which command will 2696 * be invoked. */ 2697 const char *namespaceName, /* The namespace to use, if any. */ 2698 int objc, /* Number of arguments. */ 2699 Tcl_Obj *const objv[]) /* Argument objects. */ 2700{ 2701 int result; 2702 2703 if (Tcl_IsSafe(interp)) { 2704 Tcl_SetObjResult(interp, Tcl_NewStringObj( 2705 "not allowed to invoke hidden commands from safe interpreter", 2706 -1)); 2707 return TCL_ERROR; 2708 } 2709 2710 Tcl_Preserve(slaveInterp); 2711 Tcl_AllowExceptions(slaveInterp); 2712 2713 if (namespaceName == NULL) { 2714 result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); 2715 } else { 2716 Namespace *nsPtr, *dummy1, *dummy2; 2717 const char *tail; 2718 2719 result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL, 2720 TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG 2721 | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); 2722 if (result == TCL_OK) { 2723 result = TclObjInvokeNamespace(slaveInterp, objc, objv, 2724 (Tcl_Namespace *)nsPtr, TCL_INVOKE_HIDDEN); 2725 } 2726 } 2727 2728 TclTransferResult(slaveInterp, result, interp); 2729 2730 Tcl_Release(slaveInterp); 2731 return result; 2732} 2733 2734/* 2735 *---------------------------------------------------------------------- 2736 * 2737 * SlaveMarkTrusted -- 2738 * 2739 * Helper function to mark a slave interpreter as trusted (unsafe). 2740 * 2741 * Results: 2742 * A standard Tcl result. 2743 * 2744 * Side effects: 2745 * After this call the hard-wired security checks in the core no longer 2746 * prevent the slave from performing certain operations. 2747 * 2748 *---------------------------------------------------------------------- 2749 */ 2750 2751static int 2752SlaveMarkTrusted( 2753 Tcl_Interp *interp, /* Interp for error return. */ 2754 Tcl_Interp *slaveInterp) /* The slave interpreter which will be marked 2755 * trusted. */ 2756{ 2757 if (Tcl_IsSafe(interp)) { 2758 Tcl_SetObjResult(interp, Tcl_NewStringObj( 2759 "permission denied: safe interpreter cannot mark trusted", 2760 -1)); 2761 return TCL_ERROR; 2762 } 2763 ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; 2764 return TCL_OK; 2765} 2766 2767/* 2768 *---------------------------------------------------------------------- 2769 * 2770 * Tcl_IsSafe -- 2771 * 2772 * Determines whether an interpreter is safe 2773 * 2774 * Results: 2775 * 1 if it is safe, 0 if it is not. 2776 * 2777 * Side effects: 2778 * None. 2779 * 2780 *---------------------------------------------------------------------- 2781 */ 2782 2783int 2784Tcl_IsSafe( 2785 Tcl_Interp *interp) /* Is this interpreter "safe" ? */ 2786{ 2787 Interp *iPtr = (Interp *) interp; 2788 2789 if (iPtr == NULL) { 2790 return 0; 2791 } 2792 return (iPtr->flags & SAFE_INTERP) ? 1 : 0; 2793} 2794 2795/* 2796 *---------------------------------------------------------------------- 2797 * 2798 * Tcl_MakeSafe -- 2799 * 2800 * Makes its argument interpreter contain only functionality that is 2801 * defined to be part of Safe Tcl. Unsafe commands are hidden, the env 2802 * array is unset, and the standard channels are removed. 2803 * 2804 * Results: 2805 * None. 2806 * 2807 * Side effects: 2808 * Hides commands in its argument interpreter, and removes settings and 2809 * channels. 2810 * 2811 *---------------------------------------------------------------------- 2812 */ 2813 2814int 2815Tcl_MakeSafe( 2816 Tcl_Interp *interp) /* Interpreter to be made safe. */ 2817{ 2818 Tcl_Channel chan; /* Channel to remove from safe interpreter. */ 2819 Interp *iPtr = (Interp *) interp; 2820 Tcl_Interp *master = ((InterpInfo*) iPtr->interpInfo)->slave.masterInterp; 2821 2822 TclHideUnsafeCommands(interp); 2823 2824 if (master != NULL) { 2825 /* 2826 * Alias these function implementations in the slave to those in the 2827 * master; the overall implementations are safe, but they're normally 2828 * defined by init.tcl which is not sourced by safe interpreters. 2829 * Assume these functions all work. [Bug 2895741] 2830 */ 2831 2832 (void) Tcl_Eval(interp, 2833 "namespace eval ::tcl {namespace eval mathfunc {}}"); 2834 (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master, 2835 "::tcl::mathfunc::min", 0, NULL); 2836 (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master, 2837 "::tcl::mathfunc::max", 0, NULL); 2838 } 2839 2840 iPtr->flags |= SAFE_INTERP; 2841 2842 /* 2843 * Unsetting variables : (which should not have been set in the first 2844 * place, but...) 2845 */ 2846 2847 /* 2848 * No env array in a safe slave. 2849 */ 2850 2851 Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); 2852 2853 /* 2854 * Remove unsafe parts of tcl_platform 2855 */ 2856 2857 Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY); 2858 Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY); 2859 Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY); 2860 Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY); 2861 2862 /* 2863 * Unset path informations variables (the only one remaining is [info 2864 * nameofexecutable]) 2865 */ 2866 2867 Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); 2868 Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); 2869 Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); 2870 2871 /* 2872 * Remove the standard channels from the interpreter; safe interpreters do 2873 * not ordinarily have access to stdin, stdout and stderr. 2874 * 2875 * NOTE: These channels are not added to the interpreter by the 2876 * Tcl_CreateInterp call, but may be added later, by another I/O 2877 * operation. We want to ensure that the interpreter does not have these 2878 * channels even if it is being made safe after being used for some time.. 2879 */ 2880 2881 chan = Tcl_GetStdChannel(TCL_STDIN); 2882 if (chan != NULL) { 2883 Tcl_UnregisterChannel(interp, chan); 2884 } 2885 chan = Tcl_GetStdChannel(TCL_STDOUT); 2886 if (chan != NULL) { 2887 Tcl_UnregisterChannel(interp, chan); 2888 } 2889 chan = Tcl_GetStdChannel(TCL_STDERR); 2890 if (chan != NULL) { 2891 Tcl_UnregisterChannel(interp, chan); 2892 } 2893 2894 return TCL_OK; 2895} 2896 2897/* 2898 *---------------------------------------------------------------------- 2899 * 2900 * Tcl_LimitExceeded -- 2901 * 2902 * Tests whether any limit has been exceeded in the given interpreter 2903 * (i.e. whether the interpreter is currently unable to process further 2904 * scripts). 2905 * 2906 * Results: 2907 * A boolean value. 2908 * 2909 * Side effects: 2910 * None. 2911 * 2912 * Notes: 2913 * If you change this function, you MUST also update TclLimitExceeded() in 2914 * tclInt.h. 2915 *---------------------------------------------------------------------- 2916 */ 2917 2918int 2919Tcl_LimitExceeded( 2920 Tcl_Interp *interp) 2921{ 2922 register Interp *iPtr = (Interp *) interp; 2923 2924 return iPtr->limit.exceeded != 0; 2925} 2926 2927/* 2928 *---------------------------------------------------------------------- 2929 * 2930 * Tcl_LimitReady -- 2931 * 2932 * Find out whether any limit has been set on the interpreter, and if so 2933 * check whether the granularity of that limit is such that the full 2934 * limit check should be carried out. 2935 * 2936 * Results: 2937 * A boolean value that indicates whether to call Tcl_LimitCheck. 2938 * 2939 * Side effects: 2940 * Increments the limit granularity counter. 2941 * 2942 * Notes: 2943 * If you change this function, you MUST also update TclLimitReady() in 2944 * tclInt.h. 2945 * 2946 *---------------------------------------------------------------------- 2947 */ 2948 2949int 2950Tcl_LimitReady( 2951 Tcl_Interp *interp) 2952{ 2953 register Interp *iPtr = (Interp *) interp; 2954 2955 if (iPtr->limit.active != 0) { 2956 register int ticker = ++iPtr->limit.granularityTicker; 2957 2958 if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && 2959 ((iPtr->limit.cmdGranularity == 1) || 2960 (ticker % iPtr->limit.cmdGranularity == 0))) { 2961 return 1; 2962 } 2963 if ((iPtr->limit.active & TCL_LIMIT_TIME) && 2964 ((iPtr->limit.timeGranularity == 1) || 2965 (ticker % iPtr->limit.timeGranularity == 0))) { 2966 return 1; 2967 } 2968 } 2969 return 0; 2970} 2971 2972/* 2973 *---------------------------------------------------------------------- 2974 * 2975 * Tcl_LimitCheck -- 2976 * 2977 * Check all currently set limits in the interpreter (where permitted by 2978 * granularity). If a limit is exceeded, call its callbacks and, if the 2979 * limit is still exceeded after the callbacks have run, make the 2980 * interpreter generate an error that cannot be caught within the limited 2981 * interpreter. 2982 * 2983 * Results: 2984 * A Tcl result value (TCL_OK if no limit is exceeded, and TCL_ERROR if a 2985 * limit has been exceeded). 2986 * 2987 * Side effects: 2988 * May invoke system calls. May invoke other interpreters. May be 2989 * reentrant. May put the interpreter into a state where it can no longer 2990 * execute commands without outside intervention. 2991 * 2992 *---------------------------------------------------------------------- 2993 */ 2994 2995int 2996Tcl_LimitCheck( 2997 Tcl_Interp *interp) 2998{ 2999 Interp *iPtr = (Interp *) interp; 3000 register int ticker = iPtr->limit.granularityTicker; 3001 3002 if (Tcl_InterpDeleted(interp)) { 3003 return TCL_OK; 3004 } 3005 3006 if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && 3007 ((iPtr->limit.cmdGranularity == 1) || 3008 (ticker % iPtr->limit.cmdGranularity == 0)) && 3009 (iPtr->limit.cmdCount < iPtr->cmdCount)) { 3010 iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS; 3011 Tcl_Preserve(interp); 3012 RunLimitHandlers(iPtr->limit.cmdHandlers, interp); 3013 if (iPtr->limit.cmdCount >= iPtr->cmdCount) { 3014 iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; 3015 } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { 3016 Tcl_ResetResult(interp); 3017 Tcl_AppendResult(interp, "command count limit exceeded", NULL); 3018 Tcl_Release(interp); 3019 return TCL_ERROR; 3020 } 3021 Tcl_Release(interp); 3022 } 3023 3024 if ((iPtr->limit.active & TCL_LIMIT_TIME) && 3025 ((iPtr->limit.timeGranularity == 1) || 3026 (ticker % iPtr->limit.timeGranularity == 0))) { 3027 Tcl_Time now; 3028 3029 Tcl_GetTime(&now); 3030 if (iPtr->limit.time.sec < now.sec || 3031 (iPtr->limit.time.sec == now.sec && 3032 iPtr->limit.time.usec < now.usec)) { 3033 iPtr->limit.exceeded |= TCL_LIMIT_TIME; 3034 Tcl_Preserve(interp); 3035 RunLimitHandlers(iPtr->limit.timeHandlers, interp); 3036 if (iPtr->limit.time.sec > now.sec || 3037 (iPtr->limit.time.sec == now.sec && 3038 iPtr->limit.time.usec >= now.usec)) { 3039 iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; 3040 } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { 3041 Tcl_ResetResult(interp); 3042 Tcl_AppendResult(interp, "time limit exceeded", NULL); 3043 Tcl_Release(interp); 3044 return TCL_ERROR; 3045 } 3046 Tcl_Release(interp); 3047 } 3048 } 3049 3050 return TCL_OK; 3051} 3052 3053/* 3054 *---------------------------------------------------------------------- 3055 * 3056 * RunLimitHandlers -- 3057 * 3058 * Invoke all the limit handlers in a list (for a particular limit). 3059 * Note that no particular limit handler callback will be invoked 3060 * reentrantly. 3061 * 3062 * Results: 3063 * None. 3064 * 3065 * Side effects: 3066 * Depends on the limit handlers. 3067 * 3068 *---------------------------------------------------------------------- 3069 */ 3070 3071static void 3072RunLimitHandlers( 3073 LimitHandler *handlerPtr, 3074 Tcl_Interp *interp) 3075{ 3076 LimitHandler *nextPtr; 3077 for (; handlerPtr!=NULL ; handlerPtr=nextPtr) { 3078 if (handlerPtr->flags & (LIMIT_HANDLER_DELETED|LIMIT_HANDLER_ACTIVE)) { 3079 /* 3080 * Reentrant call or something seriously strange in the delete 3081 * code. 3082 */ 3083 3084 nextPtr = handlerPtr->nextPtr; 3085 continue; 3086 } 3087 3088 /* 3089 * Set the ACTIVE flag while running the limit handler itself so we 3090 * cannot reentrantly call this handler and know to use the alternate 3091 * method of deletion if necessary. 3092 */ 3093 3094 handlerPtr->flags |= LIMIT_HANDLER_ACTIVE; 3095 (handlerPtr->handlerProc)(handlerPtr->clientData, interp); 3096 handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE; 3097 3098 /* 3099 * Rediscover this value; it might have changed during the processing 3100 * of a limit handler. We have to record it here because we might 3101 * delete the structure below, and reading a value out of a deleted 3102 * structure is unsafe (even if actually legal with some 3103 * malloc()/free() implementations.) 3104 */ 3105 3106 nextPtr = handlerPtr->nextPtr; 3107 3108 /* 3109 * If we deleted the current handler while we were executing it, we 3110 * will have spliced it out of the list and set the 3111 * LIMIT_HANDLER_DELETED flag. 3112 */ 3113 3114 if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { 3115 if (handlerPtr->deleteProc != NULL) { 3116 (handlerPtr->deleteProc)(handlerPtr->clientData); 3117 } 3118 ckfree((char *) handlerPtr); 3119 } 3120 } 3121} 3122 3123/* 3124 *---------------------------------------------------------------------- 3125 * 3126 * Tcl_LimitAddHandler -- 3127 * 3128 * Add a callback handler for a particular resource limit. 3129 * 3130 * Results: 3131 * None. 3132 * 3133 * Side effects: 3134 * Extends the internal linked list of handlers for a limit. 3135 * 3136 *---------------------------------------------------------------------- 3137 */ 3138 3139void 3140Tcl_LimitAddHandler( 3141 Tcl_Interp *interp, 3142 int type, 3143 Tcl_LimitHandlerProc *handlerProc, 3144 ClientData clientData, 3145 Tcl_LimitHandlerDeleteProc *deleteProc) 3146{ 3147 Interp *iPtr = (Interp *) interp; 3148 LimitHandler *handlerPtr; 3149 3150 /* 3151 * Convert everything into a real deletion callback. 3152 */ 3153 3154 if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) { 3155 deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free; 3156 } 3157 if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) { 3158 deleteProc = NULL; 3159 } 3160 3161 /* 3162 * Allocate a handler record. 3163 */ 3164 3165 handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler)); 3166 handlerPtr->flags = 0; 3167 handlerPtr->handlerProc = handlerProc; 3168 handlerPtr->clientData = clientData; 3169 handlerPtr->deleteProc = deleteProc; 3170 handlerPtr->prevPtr = NULL; 3171 3172 /* 3173 * Prepend onto the front of the correct linked list. 3174 */ 3175 3176 switch (type) { 3177 case TCL_LIMIT_COMMANDS: 3178 handlerPtr->nextPtr = iPtr->limit.cmdHandlers; 3179 if (handlerPtr->nextPtr != NULL) { 3180 handlerPtr->nextPtr->prevPtr = handlerPtr; 3181 } 3182 iPtr->limit.cmdHandlers = handlerPtr; 3183 return; 3184 3185 case TCL_LIMIT_TIME: 3186 handlerPtr->nextPtr = iPtr->limit.timeHandlers; 3187 if (handlerPtr->nextPtr != NULL) { 3188 handlerPtr->nextPtr->prevPtr = handlerPtr; 3189 } 3190 iPtr->limit.timeHandlers = handlerPtr; 3191 return; 3192 } 3193 3194 Tcl_Panic("unknown type of resource limit"); 3195} 3196 3197/* 3198 *---------------------------------------------------------------------- 3199 * 3200 * Tcl_LimitRemoveHandler -- 3201 * 3202 * Remove a callback handler for a particular resource limit. 3203 * 3204 * Results: 3205 * None. 3206 * 3207 * Side effects: 3208 * The handler is spliced out of the internal linked list for the limit, 3209 * and if not currently being invoked, deleted. Otherwise it is just 3210 * marked for deletion and removed when the limit handler has finished 3211 * executing. 3212 * 3213 *---------------------------------------------------------------------- 3214 */ 3215 3216void 3217Tcl_LimitRemoveHandler( 3218 Tcl_Interp *interp, 3219 int type, 3220 Tcl_LimitHandlerProc *handlerProc, 3221 ClientData clientData) 3222{ 3223 Interp *iPtr = (Interp *) interp; 3224 LimitHandler *handlerPtr; 3225 3226 switch (type) { 3227 case TCL_LIMIT_COMMANDS: 3228 handlerPtr = iPtr->limit.cmdHandlers; 3229 break; 3230 case TCL_LIMIT_TIME: 3231 handlerPtr = iPtr->limit.timeHandlers; 3232 break; 3233 default: 3234 Tcl_Panic("unknown type of resource limit"); 3235 return; 3236 } 3237 3238 for (; handlerPtr!=NULL ; handlerPtr=handlerPtr->nextPtr) { 3239 if ((handlerPtr->handlerProc != handlerProc) || 3240 (handlerPtr->clientData != clientData)) { 3241 continue; 3242 } 3243 3244 /* 3245 * We've found the handler to delete; mark it as doomed if not already 3246 * so marked (which shouldn't actually happen). 3247 */ 3248 3249 if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { 3250 return; 3251 } 3252 handlerPtr->flags |= LIMIT_HANDLER_DELETED; 3253 3254 /* 3255 * Splice the handler out of the doubly-linked list. 3256 */ 3257 3258 if (handlerPtr->prevPtr == NULL) { 3259 switch (type) { 3260 case TCL_LIMIT_COMMANDS: 3261 iPtr->limit.cmdHandlers = handlerPtr->nextPtr; 3262 break; 3263 case TCL_LIMIT_TIME: 3264 iPtr->limit.timeHandlers = handlerPtr->nextPtr; 3265 break; 3266 } 3267 } else { 3268 handlerPtr->prevPtr->nextPtr = handlerPtr->nextPtr; 3269 } 3270 if (handlerPtr->nextPtr != NULL) { 3271 handlerPtr->nextPtr->prevPtr = handlerPtr->prevPtr; 3272 } 3273 3274 /* 3275 * If nothing is currently executing the handler, delete its client 3276 * data and the overall handler structure now. Otherwise it will all 3277 * go away when the handler returns. 3278 */ 3279 3280 if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { 3281 if (handlerPtr->deleteProc != NULL) { 3282 (handlerPtr->deleteProc)(handlerPtr->clientData); 3283 } 3284 ckfree((char *) handlerPtr); 3285 } 3286 return; 3287 } 3288} 3289 3290/* 3291 *---------------------------------------------------------------------- 3292 * 3293 * TclLimitRemoveAllHandlers -- 3294 * 3295 * Remove all limit callback handlers for an interpreter. This is invoked 3296 * as part of deleting the interpreter. 3297 * 3298 * Results: 3299 * None. 3300 * 3301 * Side effects: 3302 * Limit handlers are deleted or marked for deletion (as with 3303 * Tcl_LimitRemoveHandler). 3304 * 3305 *---------------------------------------------------------------------- 3306 */ 3307 3308void 3309TclLimitRemoveAllHandlers( 3310 Tcl_Interp *interp) 3311{ 3312 Interp *iPtr = (Interp *) interp; 3313 LimitHandler *handlerPtr, *nextHandlerPtr; 3314 3315 /* 3316 * Delete all command-limit handlers. 3317 */ 3318 3319 for (handlerPtr=iPtr->limit.cmdHandlers, iPtr->limit.cmdHandlers=NULL; 3320 handlerPtr!=NULL; handlerPtr=nextHandlerPtr) { 3321 nextHandlerPtr = handlerPtr->nextPtr; 3322 3323 /* 3324 * Do not delete here if it has already been marked for deletion. 3325 */ 3326 3327 if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { 3328 continue; 3329 } 3330 handlerPtr->flags |= LIMIT_HANDLER_DELETED; 3331 handlerPtr->prevPtr = NULL; 3332 handlerPtr->nextPtr = NULL; 3333 3334 /* 3335 * If nothing is currently executing the handler, delete its client 3336 * data and the overall handler structure now. Otherwise it will all 3337 * go away when the handler returns. 3338 */ 3339 3340 if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { 3341 if (handlerPtr->deleteProc != NULL) { 3342 (handlerPtr->deleteProc)(handlerPtr->clientData); 3343 } 3344 ckfree((char *) handlerPtr); 3345 } 3346 } 3347 3348 /* 3349 * Delete all time-limit handlers. 3350 */ 3351 3352 for (handlerPtr=iPtr->limit.timeHandlers, iPtr->limit.timeHandlers=NULL; 3353 handlerPtr!=NULL; handlerPtr=nextHandlerPtr) { 3354 nextHandlerPtr = handlerPtr->nextPtr; 3355 3356 /* 3357 * Do not delete here if it has already been marked for deletion. 3358 */ 3359 3360 if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { 3361 continue; 3362 } 3363 handlerPtr->flags |= LIMIT_HANDLER_DELETED; 3364 handlerPtr->prevPtr = NULL; 3365 handlerPtr->nextPtr = NULL; 3366 3367 /* 3368 * If nothing is currently executing the handler, delete its client 3369 * data and the overall handler structure now. Otherwise it will all 3370 * go away when the handler returns. 3371 */ 3372 3373 if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { 3374 if (handlerPtr->deleteProc != NULL) { 3375 (handlerPtr->deleteProc)(handlerPtr->clientData); 3376 } 3377 ckfree((char *) handlerPtr); 3378 } 3379 } 3380 3381 /* 3382 * Delete the timer callback that is used to trap limits that occur in 3383 * [vwait]s... 3384 */ 3385 3386 if (iPtr->limit.timeEvent != NULL) { 3387 Tcl_DeleteTimerHandler(iPtr->limit.timeEvent); 3388 iPtr->limit.timeEvent = NULL; 3389 } 3390} 3391 3392/* 3393 *---------------------------------------------------------------------- 3394 * 3395 * Tcl_LimitTypeEnabled -- 3396 * 3397 * Check whether a particular limit has been enabled for an interpreter. 3398 * 3399 * Results: 3400 * A boolean value. 3401 * 3402 * Side effects: 3403 * None. 3404 * 3405 *---------------------------------------------------------------------- 3406 */ 3407 3408int 3409Tcl_LimitTypeEnabled( 3410 Tcl_Interp *interp, 3411 int type) 3412{ 3413 Interp *iPtr = (Interp *) interp; 3414 3415 return (iPtr->limit.active & type) != 0; 3416} 3417 3418/* 3419 *---------------------------------------------------------------------- 3420 * 3421 * Tcl_LimitTypeExceeded -- 3422 * 3423 * Check whether a particular limit has been exceeded for an interpreter. 3424 * 3425 * Results: 3426 * A boolean value (note that Tcl_LimitExceeded will always return 3427 * non-zero when this function returns non-zero). 3428 * 3429 * Side effects: 3430 * None. 3431 * 3432 *---------------------------------------------------------------------- 3433 */ 3434 3435int 3436Tcl_LimitTypeExceeded( 3437 Tcl_Interp *interp, 3438 int type) 3439{ 3440 Interp *iPtr = (Interp *) interp; 3441 3442 return (iPtr->limit.exceeded & type) != 0; 3443} 3444 3445/* 3446 *---------------------------------------------------------------------- 3447 * 3448 * Tcl_LimitTypeSet -- 3449 * 3450 * Enable a particular limit for an interpreter. 3451 * 3452 * Results: 3453 * None. 3454 * 3455 * Side effects: 3456 * The limit is turned on and will be checked in future at an interval 3457 * determined by the frequency of calling of Tcl_LimitReady and the 3458 * granularity of the limit in question. 3459 * 3460 *---------------------------------------------------------------------- 3461 */ 3462 3463void 3464Tcl_LimitTypeSet( 3465 Tcl_Interp *interp, 3466 int type) 3467{ 3468 Interp *iPtr = (Interp *) interp; 3469 3470 iPtr->limit.active |= type; 3471} 3472 3473/* 3474 *---------------------------------------------------------------------- 3475 * 3476 * Tcl_LimitTypeReset -- 3477 * 3478 * Disable a particular limit for an interpreter. 3479 * 3480 * Results: 3481 * None. 3482 * 3483 * Side effects: 3484 * The limit is disabled. If the limit was exceeded when this function 3485 * was called, the limit will no longer be exceeded afterwards and the 3486 * interpreter will be free to execute further scripts (assuming it isn't 3487 * also deleted, of course). 3488 * 3489 *---------------------------------------------------------------------- 3490 */ 3491 3492void 3493Tcl_LimitTypeReset( 3494 Tcl_Interp *interp, 3495 int type) 3496{ 3497 Interp *iPtr = (Interp *) interp; 3498 3499 iPtr->limit.active &= ~type; 3500 iPtr->limit.exceeded &= ~type; 3501} 3502 3503/* 3504 *---------------------------------------------------------------------- 3505 * 3506 * Tcl_LimitSetCommands -- 3507 * 3508 * Set the command limit for an interpreter. 3509 * 3510 * Results: 3511 * None. 3512 * 3513 * Side effects: 3514 * Also resets whether the command limit was exceeded. This might permit 3515 * a small amount of further execution in the interpreter even if the 3516 * limit itself is theoretically exceeded. 3517 * 3518 *---------------------------------------------------------------------- 3519 */ 3520 3521void 3522Tcl_LimitSetCommands( 3523 Tcl_Interp *interp, 3524 int commandLimit) 3525{ 3526 Interp *iPtr = (Interp *) interp; 3527 3528 iPtr->limit.cmdCount = commandLimit; 3529 iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; 3530} 3531 3532/* 3533 *---------------------------------------------------------------------- 3534 * 3535 * Tcl_LimitGetCommands -- 3536 * 3537 * Get the number of commands that may be executed in the interpreter 3538 * before the command-limit is reached. 3539 * 3540 * Results: 3541 * An upper bound on the number of commands. 3542 * 3543 * Side effects: 3544 * None. 3545 * 3546 *---------------------------------------------------------------------- 3547 */ 3548 3549int 3550Tcl_LimitGetCommands( 3551 Tcl_Interp *interp) 3552{ 3553 Interp *iPtr = (Interp *) interp; 3554 3555 return iPtr->limit.cmdCount; 3556} 3557 3558/* 3559 *---------------------------------------------------------------------- 3560 * 3561 * Tcl_LimitSetTime -- 3562 * 3563 * Set the time limit for an interpreter by copying it from the value 3564 * pointed to by the timeLimitPtr argument. 3565 * 3566 * Results: 3567 * None. 3568 * 3569 * Side effects: 3570 * Also resets whether the time limit was exceeded. This might permit a 3571 * small amount of further execution in the interpreter even if the limit 3572 * itself is theoretically exceeded. 3573 * 3574 *---------------------------------------------------------------------- 3575 */ 3576 3577void 3578Tcl_LimitSetTime( 3579 Tcl_Interp *interp, 3580 Tcl_Time *timeLimitPtr) 3581{ 3582 Interp *iPtr = (Interp *) interp; 3583 Tcl_Time nextMoment; 3584 3585 memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time)); 3586 if (iPtr->limit.timeEvent != NULL) { 3587 Tcl_DeleteTimerHandler(iPtr->limit.timeEvent); 3588 } 3589 nextMoment.sec = timeLimitPtr->sec; 3590 nextMoment.usec = timeLimitPtr->usec+10; 3591 if (nextMoment.usec >= 1000000) { 3592 nextMoment.sec++; 3593 nextMoment.usec -= 1000000; 3594 } 3595 iPtr->limit.timeEvent = TclCreateAbsoluteTimerHandler(&nextMoment, 3596 TimeLimitCallback, interp); 3597 iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; 3598} 3599 3600/* 3601 *---------------------------------------------------------------------- 3602 * 3603 * TimeLimitCallback -- 3604 * 3605 * Callback that allows time limits to be enforced even when doing a 3606 * blocking wait for events. 3607 * 3608 * Results: 3609 * None. 3610 * 3611 * Side effects: 3612 * May put the interpreter into a state where it can no longer execute 3613 * commands. May make callbacks into other interpreters. 3614 * 3615 *---------------------------------------------------------------------- 3616 */ 3617 3618static void 3619TimeLimitCallback( 3620 ClientData clientData) 3621{ 3622 Tcl_Interp *interp = clientData; 3623 Interp *iPtr = clientData; 3624 int code; 3625 3626 Tcl_Preserve(interp); 3627 iPtr->limit.timeEvent = NULL; 3628 3629 /* 3630 * Must reset the granularity ticker here to force an immediate full 3631 * check. This is OK because we're swallowing the cost in the overall cost 3632 * of the event loop. [Bug 2891362] 3633 */ 3634 3635 iPtr->limit.granularityTicker = 0; 3636 3637 code = Tcl_LimitCheck(interp); 3638 if (code != TCL_OK) { 3639 Tcl_AddErrorInfo(interp, "\n (while waiting for event)"); 3640 TclBackgroundException(interp, code); 3641 } 3642 Tcl_Release(interp); 3643} 3644 3645/* 3646 *---------------------------------------------------------------------- 3647 * 3648 * Tcl_LimitGetTime -- 3649 * 3650 * Get the current time limit. 3651 * 3652 * Results: 3653 * The time limit (by it being copied into the variable pointed to by the 3654 * timeLimitPtr). 3655 * 3656 * Side effects: 3657 * None. 3658 * 3659 *---------------------------------------------------------------------- 3660 */ 3661 3662void 3663Tcl_LimitGetTime( 3664 Tcl_Interp *interp, 3665 Tcl_Time *timeLimitPtr) 3666{ 3667 Interp *iPtr = (Interp *) interp; 3668 3669 memcpy(timeLimitPtr, &iPtr->limit.time, sizeof(Tcl_Time)); 3670} 3671 3672/* 3673 *---------------------------------------------------------------------- 3674 * 3675 * Tcl_LimitSetGranularity -- 3676 * 3677 * Set the granularity divisor (which must be positive) for a particular 3678 * limit. 3679 * 3680 * Results: 3681 * None. 3682 * 3683 * Side effects: 3684 * The granularity is updated. 3685 * 3686 *---------------------------------------------------------------------- 3687 */ 3688 3689void 3690Tcl_LimitSetGranularity( 3691 Tcl_Interp *interp, 3692 int type, 3693 int granularity) 3694{ 3695 Interp *iPtr = (Interp *) interp; 3696 if (granularity < 1) { 3697 Tcl_Panic("limit granularity must be positive"); 3698 } 3699 3700 switch (type) { 3701 case TCL_LIMIT_COMMANDS: 3702 iPtr->limit.cmdGranularity = granularity; 3703 return; 3704 case TCL_LIMIT_TIME: 3705 iPtr->limit.timeGranularity = granularity; 3706 return; 3707 } 3708 Tcl_Panic("unknown type of resource limit"); 3709} 3710 3711/* 3712 *---------------------------------------------------------------------- 3713 * 3714 * Tcl_LimitGetGranularity -- 3715 * 3716 * Get the granularity divisor for a particular limit. 3717 * 3718 * Results: 3719 * The granularity divisor for the given limit. 3720 * 3721 * Side effects: 3722 * None. 3723 * 3724 *---------------------------------------------------------------------- 3725 */ 3726 3727int 3728Tcl_LimitGetGranularity( 3729 Tcl_Interp *interp, 3730 int type) 3731{ 3732 Interp *iPtr = (Interp *) interp; 3733 3734 switch (type) { 3735 case TCL_LIMIT_COMMANDS: 3736 return iPtr->limit.cmdGranularity; 3737 case TCL_LIMIT_TIME: 3738 return iPtr->limit.timeGranularity; 3739 } 3740 Tcl_Panic("unknown type of resource limit"); 3741 return -1; /* NOT REACHED */ 3742} 3743 3744/* 3745 *---------------------------------------------------------------------- 3746 * 3747 * DeleteScriptLimitCallback -- 3748 * 3749 * Callback for when a script limit (a limit callback implemented as a 3750 * Tcl script in a master interpreter, as set up from Tcl) is deleted. 3751 * 3752 * Results: 3753 * None. 3754 * 3755 * Side effects: 3756 * The reference to the script callback from the controlling interpreter 3757 * is removed. 3758 * 3759 *---------------------------------------------------------------------- 3760 */ 3761 3762static void 3763DeleteScriptLimitCallback( 3764 ClientData clientData) 3765{ 3766 ScriptLimitCallback *limitCBPtr = clientData; 3767 3768 Tcl_DecrRefCount(limitCBPtr->scriptObj); 3769 if (limitCBPtr->entryPtr != NULL) { 3770 Tcl_DeleteHashEntry(limitCBPtr->entryPtr); 3771 } 3772 ckfree((char *) limitCBPtr); 3773} 3774 3775/* 3776 *---------------------------------------------------------------------- 3777 * 3778 * CallScriptLimitCallback -- 3779 * 3780 * Invoke a script limit callback. Used to implement limit callbacks set 3781 * at the Tcl level on child interpreters. 3782 * 3783 * Results: 3784 * None. 3785 * 3786 * Side effects: 3787 * Depends on the callback script. Errors are reported as background 3788 * errors. 3789 * 3790 *---------------------------------------------------------------------- 3791 */ 3792 3793static void 3794CallScriptLimitCallback( 3795 ClientData clientData, 3796 Tcl_Interp *interp) /* Interpreter which failed the limit */ 3797{ 3798 ScriptLimitCallback *limitCBPtr = clientData; 3799 int code; 3800 3801 if (Tcl_InterpDeleted(limitCBPtr->interp)) { 3802 return; 3803 } 3804 Tcl_Preserve(limitCBPtr->interp); 3805 code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj, 3806 TCL_EVAL_GLOBAL); 3807 if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) { 3808 TclBackgroundException(limitCBPtr->interp, code); 3809 } 3810 Tcl_Release(limitCBPtr->interp); 3811} 3812 3813/* 3814 *---------------------------------------------------------------------- 3815 * 3816 * SetScriptLimitCallback -- 3817 * 3818 * Install (or remove, if scriptObj is NULL) a limit callback script that 3819 * is called when the target interpreter exceeds the type of limit 3820 * specified. Each interpreter may only have one callback set on another 3821 * interpreter through this mechanism (though as many interpreters may be 3822 * limited as the programmer chooses overall). 3823 * 3824 * Results: 3825 * None. 3826 * 3827 * Side effects: 3828 * A limit callback implemented as an invokation of a Tcl script in 3829 * another interpreter is either installed or removed. 3830 * 3831 *---------------------------------------------------------------------- 3832 */ 3833 3834static void 3835SetScriptLimitCallback( 3836 Tcl_Interp *interp, 3837 int type, 3838 Tcl_Interp *targetInterp, 3839 Tcl_Obj *scriptObj) 3840{ 3841 ScriptLimitCallback *limitCBPtr; 3842 Tcl_HashEntry *hashPtr; 3843 int isNew; 3844 ScriptLimitCallbackKey key; 3845 Interp *iPtr = (Interp *) interp; 3846 3847 if (interp == targetInterp) { 3848 Tcl_Panic("installing limit callback to the limited interpreter"); 3849 } 3850 3851 key.interp = targetInterp; 3852 key.type = type; 3853 3854 if (scriptObj == NULL) { 3855 hashPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); 3856 if (hashPtr != NULL) { 3857 Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, 3858 Tcl_GetHashValue(hashPtr)); 3859 } 3860 return; 3861 } 3862 3863 hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, (char *) &key, 3864 &isNew); 3865 if (!isNew) { 3866 limitCBPtr = Tcl_GetHashValue(hashPtr); 3867 limitCBPtr->entryPtr = NULL; 3868 Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, 3869 limitCBPtr); 3870 } 3871 3872 limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback)); 3873 limitCBPtr->interp = interp; 3874 limitCBPtr->scriptObj = scriptObj; 3875 limitCBPtr->entryPtr = hashPtr; 3876 limitCBPtr->type = type; 3877 Tcl_IncrRefCount(scriptObj); 3878 3879 Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback, 3880 limitCBPtr, DeleteScriptLimitCallback); 3881 Tcl_SetHashValue(hashPtr, limitCBPtr); 3882} 3883 3884/* 3885 *---------------------------------------------------------------------- 3886 * 3887 * TclRemoveScriptLimitCallbacks -- 3888 * 3889 * Remove all script-implemented limit callbacks that make calls back 3890 * into the given interpreter. This invoked as part of deleting an 3891 * interpreter. 3892 * 3893 * Results: 3894 * None. 3895 * 3896 * Side effects: 3897 * The script limit callbacks are removed or marked for later removal. 3898 * 3899 *---------------------------------------------------------------------- 3900 */ 3901 3902void 3903TclRemoveScriptLimitCallbacks( 3904 Tcl_Interp *interp) 3905{ 3906 Interp *iPtr = (Interp *) interp; 3907 Tcl_HashEntry *hashPtr; 3908 Tcl_HashSearch search; 3909 ScriptLimitCallbackKey *keyPtr; 3910 3911 hashPtr = Tcl_FirstHashEntry(&iPtr->limit.callbacks, &search); 3912 while (hashPtr != NULL) { 3913 keyPtr = (ScriptLimitCallbackKey *) 3914 Tcl_GetHashKey(&iPtr->limit.callbacks, hashPtr); 3915 Tcl_LimitRemoveHandler(keyPtr->interp, keyPtr->type, 3916 CallScriptLimitCallback, Tcl_GetHashValue(hashPtr)); 3917 hashPtr = Tcl_NextHashEntry(&search); 3918 } 3919 Tcl_DeleteHashTable(&iPtr->limit.callbacks); 3920} 3921 3922/* 3923 *---------------------------------------------------------------------- 3924 * 3925 * TclInitLimitSupport -- 3926 * 3927 * Initialise all the parts of the interpreter relating to resource limit 3928 * management. This allows an interpreter to both have limits set upon 3929 * itself and set limits upon other interpreters. 3930 * 3931 * Results: 3932 * None. 3933 * 3934 * Side effects: 3935 * The resource limit subsystem is initialised for the interpreter. 3936 * 3937 *---------------------------------------------------------------------- 3938 */ 3939 3940void 3941TclInitLimitSupport( 3942 Tcl_Interp *interp) 3943{ 3944 Interp *iPtr = (Interp *) interp; 3945 3946 iPtr->limit.active = 0; 3947 iPtr->limit.granularityTicker = 0; 3948 iPtr->limit.exceeded = 0; 3949 iPtr->limit.cmdCount = 0; 3950 iPtr->limit.cmdHandlers = NULL; 3951 iPtr->limit.cmdGranularity = 1; 3952 memset(&iPtr->limit.time, 0, sizeof(Tcl_Time)); 3953 iPtr->limit.timeHandlers = NULL; 3954 iPtr->limit.timeEvent = NULL; 3955 iPtr->limit.timeGranularity = 10; 3956 Tcl_InitHashTable(&iPtr->limit.callbacks, 3957 sizeof(ScriptLimitCallbackKey)/sizeof(int)); 3958} 3959 3960/* 3961 *---------------------------------------------------------------------- 3962 * 3963 * InheritLimitsFromMaster -- 3964 * 3965 * Derive the interpreter limit configuration for a slave interpreter 3966 * from the limit config for the master. 3967 * 3968 * Results: 3969 * None. 3970 * 3971 * Side effects: 3972 * The slave interpreter limits are set so that if the master has a 3973 * limit, it may not exceed it by handing off work to slave interpreters. 3974 * Note that this does not transfer limit callbacks from the master to 3975 * the slave. 3976 * 3977 *---------------------------------------------------------------------- 3978 */ 3979 3980static void 3981InheritLimitsFromMaster( 3982 Tcl_Interp *slaveInterp, 3983 Tcl_Interp *masterInterp) 3984{ 3985 Interp *slavePtr = (Interp *) slaveInterp; 3986 Interp *masterPtr = (Interp *) masterInterp; 3987 3988 if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) { 3989 slavePtr->limit.active |= TCL_LIMIT_COMMANDS; 3990 slavePtr->limit.cmdCount = 0; 3991 slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity; 3992 } 3993 if (masterPtr->limit.active & TCL_LIMIT_TIME) { 3994 slavePtr->limit.active |= TCL_LIMIT_TIME; 3995 memcpy(&slavePtr->limit.time, &masterPtr->limit.time, 3996 sizeof(Tcl_Time)); 3997 slavePtr->limit.timeGranularity = masterPtr->limit.timeGranularity; 3998 } 3999} 4000 4001/* 4002 *---------------------------------------------------------------------- 4003 * 4004 * SlaveCommandLimitCmd -- 4005 * 4006 * Implementation of the [interp limit $i commands] and [$i limit 4007 * commands] subcommands. See the interp manual page for a full 4008 * description. 4009 * 4010 * Results: 4011 * A standard Tcl result. 4012 * 4013 * Side effects: 4014 * Depends on the arguments. 4015 * 4016 *---------------------------------------------------------------------- 4017 */ 4018 4019static int 4020SlaveCommandLimitCmd( 4021 Tcl_Interp *interp, /* Current interpreter. */ 4022 Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ 4023 int consumedObjc, /* Number of args already parsed. */ 4024 int objc, /* Total number of arguments. */ 4025 Tcl_Obj *const objv[]) /* Argument objects. */ 4026{ 4027 static const char *options[] = { 4028 "-command", "-granularity", "-value", NULL 4029 }; 4030 enum Options { 4031 OPT_CMD, OPT_GRAN, OPT_VAL 4032 }; 4033 Interp *iPtr = (Interp *) interp; 4034 int index; 4035 ScriptLimitCallbackKey key; 4036 ScriptLimitCallback *limitCBPtr; 4037 Tcl_HashEntry *hPtr; 4038 4039 if (objc == consumedObjc) { 4040 Tcl_Obj *dictPtr; 4041 4042 TclNewObj(dictPtr); 4043 key.interp = slaveInterp; 4044 key.type = TCL_LIMIT_COMMANDS; 4045 hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); 4046 if (hPtr != NULL) { 4047 limitCBPtr = Tcl_GetHashValue(hPtr); 4048 if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { 4049 Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), 4050 limitCBPtr->scriptObj); 4051 } else { 4052 goto putEmptyCommandInDict; 4053 } 4054 } else { 4055 Tcl_Obj *empty; 4056 4057 putEmptyCommandInDict: 4058 TclNewObj(empty); 4059 Tcl_DictObjPut(NULL, dictPtr, 4060 Tcl_NewStringObj(options[0], -1), empty); 4061 } 4062 Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), 4063 Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, 4064 TCL_LIMIT_COMMANDS))); 4065 4066 if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { 4067 Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), 4068 Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); 4069 } else { 4070 Tcl_Obj *empty; 4071 4072 TclNewObj(empty); 4073 Tcl_DictObjPut(NULL, dictPtr, 4074 Tcl_NewStringObj(options[2], -1), empty); 4075 } 4076 Tcl_SetObjResult(interp, dictPtr); 4077 return TCL_OK; 4078 } else if (objc == consumedObjc+1) { 4079 if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option", 4080 0, &index) != TCL_OK) { 4081 return TCL_ERROR; 4082 } 4083 switch ((enum Options) index) { 4084 case OPT_CMD: 4085 key.interp = slaveInterp; 4086 key.type = TCL_LIMIT_COMMANDS; 4087 hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); 4088 if (hPtr != NULL) { 4089 limitCBPtr = Tcl_GetHashValue(hPtr); 4090 if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { 4091 Tcl_SetObjResult(interp, limitCBPtr->scriptObj); 4092 } 4093 } 4094 break; 4095 case OPT_GRAN: 4096 Tcl_SetObjResult(interp, Tcl_NewIntObj( 4097 Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); 4098 break; 4099 case OPT_VAL: 4100 if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { 4101 Tcl_SetObjResult(interp, 4102 Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); 4103 } 4104 break; 4105 } 4106 return TCL_OK; 4107 } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { 4108 Tcl_WrongNumArgs(interp, consumedObjc, objv, 4109 "?-option? ?value? ?-option value ...?"); 4110 return TCL_ERROR; 4111 } else { 4112 int i, scriptLen = 0, limitLen = 0; 4113 Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL; 4114 int gran = 0, limit = 0; 4115 4116 for (i=consumedObjc ; i<objc ; i+=2) { 4117 if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, 4118 &index) != TCL_OK) { 4119 return TCL_ERROR; 4120 } 4121 switch ((enum Options) index) { 4122 case OPT_CMD: 4123 scriptObj = objv[i+1]; 4124 (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); 4125 break; 4126 case OPT_GRAN: 4127 granObj = objv[i+1]; 4128 if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { 4129 return TCL_ERROR; 4130 } 4131 if (gran < 1) { 4132 Tcl_AppendResult(interp, "granularity must be at " 4133 "least 1", NULL); 4134 return TCL_ERROR; 4135 } 4136 break; 4137 case OPT_VAL: 4138 limitObj = objv[i+1]; 4139 (void) Tcl_GetStringFromObj(objv[i+1], &limitLen); 4140 if (limitLen == 0) { 4141 break; 4142 } 4143 if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) { 4144 return TCL_ERROR; 4145 } 4146 if (limit < 0) { 4147 Tcl_AppendResult(interp, "command limit value must be at " 4148 "least 0", NULL); 4149 return TCL_ERROR; 4150 } 4151 break; 4152 } 4153 } 4154 if (scriptObj != NULL) { 4155 SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, slaveInterp, 4156 (scriptLen > 0 ? scriptObj : NULL)); 4157 } 4158 if (granObj != NULL) { 4159 Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran); 4160 } 4161 if (limitObj != NULL) { 4162 if (limitLen > 0) { 4163 Tcl_LimitSetCommands(slaveInterp, limit); 4164 Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS); 4165 } else { 4166 Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS); 4167 } 4168 } 4169 return TCL_OK; 4170 } 4171} 4172 4173/* 4174 *---------------------------------------------------------------------- 4175 * 4176 * SlaveTimeLimitCmd -- 4177 * 4178 * Implementation of the [interp limit $i time] and [$i limit time] 4179 * subcommands. See the interp manual page for a full description. 4180 * 4181 * Results: 4182 * A standard Tcl result. 4183 * 4184 * Side effects: 4185 * Depends on the arguments. 4186 * 4187 *---------------------------------------------------------------------- 4188 */ 4189 4190static int 4191SlaveTimeLimitCmd( 4192 Tcl_Interp *interp, /* Current interpreter. */ 4193 Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ 4194 int consumedObjc, /* Number of args already parsed. */ 4195 int objc, /* Total number of arguments. */ 4196 Tcl_Obj *const objv[]) /* Argument objects. */ 4197{ 4198 static const char *options[] = { 4199 "-command", "-granularity", "-milliseconds", "-seconds", NULL 4200 }; 4201 enum Options { 4202 OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC 4203 }; 4204 Interp *iPtr = (Interp *) interp; 4205 int index; 4206 ScriptLimitCallbackKey key; 4207 ScriptLimitCallback *limitCBPtr; 4208 Tcl_HashEntry *hPtr; 4209 4210 if (objc == consumedObjc) { 4211 Tcl_Obj *dictPtr; 4212 4213 TclNewObj(dictPtr); 4214 key.interp = slaveInterp; 4215 key.type = TCL_LIMIT_TIME; 4216 hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); 4217 if (hPtr != NULL) { 4218 limitCBPtr = Tcl_GetHashValue(hPtr); 4219 if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { 4220 Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), 4221 limitCBPtr->scriptObj); 4222 } else { 4223 goto putEmptyCommandInDict; 4224 } 4225 } else { 4226 Tcl_Obj *empty; 4227 putEmptyCommandInDict: 4228 TclNewObj(empty); 4229 Tcl_DictObjPut(NULL, dictPtr, 4230 Tcl_NewStringObj(options[0], -1), empty); 4231 } 4232 Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), 4233 Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, 4234 TCL_LIMIT_TIME))); 4235 4236 if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { 4237 Tcl_Time limitMoment; 4238 4239 Tcl_LimitGetTime(slaveInterp, &limitMoment); 4240 Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), 4241 Tcl_NewLongObj(limitMoment.usec/1000)); 4242 Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1), 4243 Tcl_NewLongObj(limitMoment.sec)); 4244 } else { 4245 Tcl_Obj *empty; 4246 4247 TclNewObj(empty); 4248 Tcl_DictObjPut(NULL, dictPtr, 4249 Tcl_NewStringObj(options[2], -1), empty); 4250 Tcl_DictObjPut(NULL, dictPtr, 4251 Tcl_NewStringObj(options[3], -1), empty); 4252 } 4253 Tcl_SetObjResult(interp, dictPtr); 4254 return TCL_OK; 4255 } else if (objc == consumedObjc+1) { 4256 if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option", 4257 0, &index) != TCL_OK) { 4258 return TCL_ERROR; 4259 } 4260 switch ((enum Options) index) { 4261 case OPT_CMD: 4262 key.interp = slaveInterp; 4263 key.type = TCL_LIMIT_TIME; 4264 hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); 4265 if (hPtr != NULL) { 4266 limitCBPtr = Tcl_GetHashValue(hPtr); 4267 if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { 4268 Tcl_SetObjResult(interp, limitCBPtr->scriptObj); 4269 } 4270 } 4271 break; 4272 case OPT_GRAN: 4273 Tcl_SetObjResult(interp, Tcl_NewIntObj( 4274 Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME))); 4275 break; 4276 case OPT_MILLI: 4277 if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { 4278 Tcl_Time limitMoment; 4279 4280 Tcl_LimitGetTime(slaveInterp, &limitMoment); 4281 Tcl_SetObjResult(interp, 4282 Tcl_NewLongObj(limitMoment.usec/1000)); 4283 } 4284 break; 4285 case OPT_SEC: 4286 if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { 4287 Tcl_Time limitMoment; 4288 4289 Tcl_LimitGetTime(slaveInterp, &limitMoment); 4290 Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec)); 4291 } 4292 break; 4293 } 4294 return TCL_OK; 4295 } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { 4296 Tcl_WrongNumArgs(interp, consumedObjc, objv, 4297 "?-option? ?value? ?-option value ...?"); 4298 return TCL_ERROR; 4299 } else { 4300 int i, scriptLen = 0, milliLen = 0, secLen = 0; 4301 Tcl_Obj *scriptObj = NULL, *granObj = NULL; 4302 Tcl_Obj *milliObj = NULL, *secObj = NULL; 4303 int gran = 0; 4304 Tcl_Time limitMoment; 4305 int tmp; 4306 4307 Tcl_LimitGetTime(slaveInterp, &limitMoment); 4308 for (i=consumedObjc ; i<objc ; i+=2) { 4309 if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, 4310 &index) != TCL_OK) { 4311 return TCL_ERROR; 4312 } 4313 switch ((enum Options) index) { 4314 case OPT_CMD: 4315 scriptObj = objv[i+1]; 4316 (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); 4317 break; 4318 case OPT_GRAN: 4319 granObj = objv[i+1]; 4320 if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { 4321 return TCL_ERROR; 4322 } 4323 if (gran < 1) { 4324 Tcl_AppendResult(interp, "granularity must be at " 4325 "least 1", NULL); 4326 return TCL_ERROR; 4327 } 4328 break; 4329 case OPT_MILLI: 4330 milliObj = objv[i+1]; 4331 (void) Tcl_GetStringFromObj(objv[i+1], &milliLen); 4332 if (milliLen == 0) { 4333 break; 4334 } 4335 if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { 4336 return TCL_ERROR; 4337 } 4338 if (tmp < 0) { 4339 Tcl_AppendResult(interp, "milliseconds must be at least 0", 4340 NULL); 4341 return TCL_ERROR; 4342 } 4343 limitMoment.usec = ((long)tmp)*1000; 4344 break; 4345 case OPT_SEC: 4346 secObj = objv[i+1]; 4347 (void) Tcl_GetStringFromObj(objv[i+1], &secLen); 4348 if (secLen == 0) { 4349 break; 4350 } 4351 if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { 4352 return TCL_ERROR; 4353 } 4354 if (tmp < 0) { 4355 Tcl_AppendResult(interp, "seconds must be at least 0", 4356 NULL); 4357 return TCL_ERROR; 4358 } 4359 limitMoment.sec = tmp; 4360 break; 4361 } 4362 } 4363 if (milliObj != NULL || secObj != NULL) { 4364 if (milliObj != NULL) { 4365 /* 4366 * Setting -milliseconds but clearing -seconds, or resetting 4367 * -milliseconds but not resetting -seconds? Bad voodoo! 4368 */ 4369 4370 if (secObj != NULL && secLen == 0 && milliLen > 0) { 4371 Tcl_AppendResult(interp, "may only set -milliseconds " 4372 "if -seconds is not also being reset", NULL); 4373 return TCL_ERROR; 4374 } 4375 if (milliLen == 0 && (secObj == NULL || secLen > 0)) { 4376 Tcl_AppendResult(interp, "may only reset -milliseconds " 4377 "if -seconds is also being reset", NULL); 4378 return TCL_ERROR; 4379 } 4380 } 4381 4382 if (milliLen > 0 || secLen > 0) { 4383 /* 4384 * Force usec to be in range [0..1000000), possibly 4385 * incrementing sec in the process. This makes it much easier 4386 * for people to write scripts that do small time increments. 4387 */ 4388 4389 limitMoment.sec += limitMoment.usec / 1000000; 4390 limitMoment.usec %= 1000000; 4391 4392 Tcl_LimitSetTime(slaveInterp, &limitMoment); 4393 Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME); 4394 } else { 4395 Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME); 4396 } 4397 } 4398 if (scriptObj != NULL) { 4399 SetScriptLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp, 4400 (scriptLen > 0 ? scriptObj : NULL)); 4401 } 4402 if (granObj != NULL) { 4403 Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran); 4404 } 4405 return TCL_OK; 4406 } 4407} 4408 4409/* 4410 * Local Variables: 4411 * mode: c 4412 * c-basic-offset: 4 4413 * fill-column: 78 4414 * End: 4415 */ 4416