[25] | 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 2008/01/30 10:45:55 msofer 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 | |
---|
| 24 | static char *tclPreInitScript = NULL; |
---|
| 25 | |
---|
| 26 | /* Forward declaration */ |
---|
| 27 | struct 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 | |
---|
| 37 | typedef 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 | |
---|
| 78 | typedef 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 | |
---|
| 107 | typedef 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 | |
---|
| 132 | typedef 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 | |
---|
| 149 | typedef 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 | |
---|
| 163 | typedef 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 | |
---|
| 176 | typedef 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 | |
---|
| 187 | static 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[]); |
---|
| 191 | static int AliasDelete(Tcl_Interp *interp, |
---|
| 192 | Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); |
---|
| 193 | static int AliasDescribe(Tcl_Interp *interp, |
---|
| 194 | Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); |
---|
| 195 | static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); |
---|
| 196 | static int AliasObjCmd(ClientData dummy, |
---|
| 197 | Tcl_Interp *currentInterp, int objc, |
---|
| 198 | Tcl_Obj *const objv[]); |
---|
| 199 | static void AliasObjCmdDeleteProc(ClientData clientData); |
---|
| 200 | static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr); |
---|
| 201 | static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc, |
---|
| 202 | Tcl_Obj *const objv[]); |
---|
| 203 | static void InterpInfoDeleteProc(ClientData clientData, |
---|
| 204 | Tcl_Interp *interp); |
---|
| 205 | static int SlaveBgerror(Tcl_Interp *interp, |
---|
| 206 | Tcl_Interp *slaveInterp, int objc, |
---|
| 207 | Tcl_Obj *const objv[]); |
---|
| 208 | static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, |
---|
| 209 | int safe); |
---|
| 210 | static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp, |
---|
| 211 | int objc, Tcl_Obj *const objv[]); |
---|
| 212 | static int SlaveExpose(Tcl_Interp *interp, |
---|
| 213 | Tcl_Interp *slaveInterp, int objc, |
---|
| 214 | Tcl_Obj *const objv[]); |
---|
| 215 | static int SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp, |
---|
| 216 | int objc, Tcl_Obj *const objv[]); |
---|
| 217 | static int SlaveHidden(Tcl_Interp *interp, |
---|
| 218 | Tcl_Interp *slaveInterp); |
---|
| 219 | static int SlaveInvokeHidden(Tcl_Interp *interp, |
---|
| 220 | Tcl_Interp *slaveInterp, |
---|
| 221 | const char *namespaceName, |
---|
| 222 | int objc, Tcl_Obj *const objv[]); |
---|
| 223 | static int SlaveMarkTrusted(Tcl_Interp *interp, |
---|
| 224 | Tcl_Interp *slaveInterp); |
---|
| 225 | static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp, |
---|
| 226 | int objc, Tcl_Obj *const objv[]); |
---|
| 227 | static void SlaveObjCmdDeleteProc(ClientData clientData); |
---|
| 228 | static int SlaveRecursionLimit(Tcl_Interp *interp, |
---|
| 229 | Tcl_Interp *slaveInterp, int objc, |
---|
| 230 | Tcl_Obj *const objv[]); |
---|
| 231 | static int SlaveCommandLimitCmd(Tcl_Interp *interp, |
---|
| 232 | Tcl_Interp *slaveInterp, int consumedObjc, |
---|
| 233 | int objc, Tcl_Obj *const objv[]); |
---|
| 234 | static int SlaveTimeLimitCmd(Tcl_Interp *interp, |
---|
| 235 | Tcl_Interp *slaveInterp, int consumedObjc, |
---|
| 236 | int objc, Tcl_Obj *const objv[]); |
---|
| 237 | static void InheritLimitsFromMaster(Tcl_Interp *slaveInterp, |
---|
| 238 | Tcl_Interp *masterInterp); |
---|
| 239 | static void SetScriptLimitCallback(Tcl_Interp *interp, int type, |
---|
| 240 | Tcl_Interp *targetInterp, Tcl_Obj *scriptObj); |
---|
| 241 | static void CallScriptLimitCallback(ClientData clientData, |
---|
| 242 | Tcl_Interp *interp); |
---|
| 243 | static void DeleteScriptLimitCallback(ClientData clientData); |
---|
| 244 | static void RunLimitHandlers(LimitHandler *handlerPtr, |
---|
| 245 | Tcl_Interp *interp); |
---|
| 246 | static 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 | |
---|
| 265 | char * |
---|
| 266 | TclSetPreInitScript( |
---|
| 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 | |
---|
| 293 | int |
---|
| 294 | Tcl_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 | |
---|
| 427 | int |
---|
| 428 | TclInterpInit( |
---|
| 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 | |
---|
| 472 | static void |
---|
| 473 | InterpInfoDeleteProc( |
---|
| 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 */ |
---|
| 551 | int |
---|
| 552 | Tcl_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 | |
---|
| 1026 | static Tcl_Interp * |
---|
| 1027 | GetInterp2( |
---|
| 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 | |
---|
| 1059 | int |
---|
| 1060 | Tcl_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 | |
---|
| 1115 | int |
---|
| 1116 | Tcl_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 | |
---|
| 1157 | int |
---|
| 1158 | Tcl_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 | |
---|
| 1218 | int |
---|
| 1219 | Tcl_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 | |
---|
| 1281 | int |
---|
| 1282 | TclPreventAliasLoop( |
---|
| 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 | |
---|
| 1377 | static int |
---|
| 1378 | AliasCreate( |
---|
| 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 | |
---|
| 1536 | static int |
---|
| 1537 | AliasDelete( |
---|
| 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 | |
---|
| 1584 | static int |
---|
| 1585 | AliasDescribe( |
---|
| 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 | |
---|
| 1628 | static int |
---|
| 1629 | AliasList( |
---|
| 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 | |
---|
| 1672 | static int |
---|
| 1673 | AliasObjCmd( |
---|
| 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 | |
---|
| 1790 | static void |
---|
| 1791 | AliasObjCmdDeleteProc( |
---|
| 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 | |
---|
| 1850 | Tcl_Interp * |
---|
| 1851 | Tcl_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 | |
---|
| 1882 | Tcl_Interp * |
---|
| 1883 | Tcl_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 | |
---|
| 1913 | Tcl_Interp * |
---|
| 1914 | Tcl_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 | |
---|
| 1950 | int |
---|
| 1951 | Tcl_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 | |
---|
| 1989 | static Tcl_Interp * |
---|
| 1990 | GetInterp( |
---|
| 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 | |
---|
| 2048 | static int |
---|
| 2049 | SlaveBgerror( |
---|
| 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(interp, objv[0]); |
---|
| 2065 | } |
---|
| 2066 | Tcl_SetObjResult(interp, TclGetBgErrorHandler(interp)); |
---|
| 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 | |
---|
| 2089 | static Tcl_Interp * |
---|
| 2090 | SlaveCreate( |
---|
| 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 | |
---|
| 2221 | static int |
---|
| 2222 | SlaveObjCmd( |
---|
| 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 | |
---|
| 2414 | static void |
---|
| 2415 | SlaveObjCmdDeleteProc( |
---|
| 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 | |
---|
| 2459 | static int |
---|
| 2460 | SlaveEval( |
---|
| 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 invoker available to eval'd script. |
---|
| 2476 | */ |
---|
| 2477 | |
---|
| 2478 | Interp *iPtr = (Interp *) interp; |
---|
| 2479 | result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr, 0); |
---|
| 2480 | } else { |
---|
| 2481 | objPtr = Tcl_ConcatObj(objc, objv); |
---|
| 2482 | Tcl_IncrRefCount(objPtr); |
---|
| 2483 | result = Tcl_EvalObjEx(slaveInterp, objPtr, 0); |
---|
| 2484 | Tcl_DecrRefCount(objPtr); |
---|
| 2485 | } |
---|
| 2486 | TclTransferResult(slaveInterp, result, interp); |
---|
| 2487 | |
---|
| 2488 | Tcl_Release(slaveInterp); |
---|
| 2489 | return result; |
---|
| 2490 | } |
---|
| 2491 | |
---|
| 2492 | /* |
---|
| 2493 | *---------------------------------------------------------------------- |
---|
| 2494 | * |
---|
| 2495 | * SlaveExpose -- |
---|
| 2496 | * |
---|
| 2497 | * Helper function to expose a command in a slave interpreter. |
---|
| 2498 | * |
---|
| 2499 | * Results: |
---|
| 2500 | * A standard Tcl result. |
---|
| 2501 | * |
---|
| 2502 | * Side effects: |
---|
| 2503 | * After this call scripts in the slave will be able to invoke the newly |
---|
| 2504 | * exposed command. |
---|
| 2505 | * |
---|
| 2506 | *---------------------------------------------------------------------- |
---|
| 2507 | */ |
---|
| 2508 | |
---|
| 2509 | static int |
---|
| 2510 | SlaveExpose( |
---|
| 2511 | Tcl_Interp *interp, /* Interp for error return. */ |
---|
| 2512 | Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ |
---|
| 2513 | int objc, /* Number of arguments. */ |
---|
| 2514 | Tcl_Obj *const objv[]) /* Argument strings. */ |
---|
| 2515 | { |
---|
| 2516 | char *name; |
---|
| 2517 | |
---|
| 2518 | if (Tcl_IsSafe(interp)) { |
---|
| 2519 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 2520 | "permission denied: safe interpreter cannot expose commands", |
---|
| 2521 | -1)); |
---|
| 2522 | return TCL_ERROR; |
---|
| 2523 | } |
---|
| 2524 | |
---|
| 2525 | name = TclGetString(objv[(objc == 1) ? 0 : 1]); |
---|
| 2526 | if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]), |
---|
| 2527 | name) != TCL_OK) { |
---|
| 2528 | TclTransferResult(slaveInterp, TCL_ERROR, interp); |
---|
| 2529 | return TCL_ERROR; |
---|
| 2530 | } |
---|
| 2531 | return TCL_OK; |
---|
| 2532 | } |
---|
| 2533 | |
---|
| 2534 | /* |
---|
| 2535 | *---------------------------------------------------------------------- |
---|
| 2536 | * |
---|
| 2537 | * SlaveRecursionLimit -- |
---|
| 2538 | * |
---|
| 2539 | * Helper function to set/query the Recursion limit of an interp |
---|
| 2540 | * |
---|
| 2541 | * Results: |
---|
| 2542 | * A standard Tcl result. |
---|
| 2543 | * |
---|
| 2544 | * Side effects: |
---|
| 2545 | * When (objc == 1), slaveInterp will be set to a new recursion limit of |
---|
| 2546 | * objv[0]. |
---|
| 2547 | * |
---|
| 2548 | *---------------------------------------------------------------------- |
---|
| 2549 | */ |
---|
| 2550 | |
---|
| 2551 | static int |
---|
| 2552 | SlaveRecursionLimit( |
---|
| 2553 | Tcl_Interp *interp, /* Interp for error return. */ |
---|
| 2554 | Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */ |
---|
| 2555 | int objc, /* Set or Query. */ |
---|
| 2556 | Tcl_Obj *const objv[]) /* Argument strings. */ |
---|
| 2557 | { |
---|
| 2558 | Interp *iPtr; |
---|
| 2559 | int limit; |
---|
| 2560 | |
---|
| 2561 | if (objc) { |
---|
| 2562 | if (Tcl_IsSafe(interp)) { |
---|
| 2563 | Tcl_AppendResult(interp, "permission denied: " |
---|
| 2564 | "safe interpreters cannot change recursion limit", NULL); |
---|
| 2565 | return TCL_ERROR; |
---|
| 2566 | } |
---|
| 2567 | if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { |
---|
| 2568 | return TCL_ERROR; |
---|
| 2569 | } |
---|
| 2570 | if (limit <= 0) { |
---|
| 2571 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 2572 | "recursion limit must be > 0", -1)); |
---|
| 2573 | return TCL_ERROR; |
---|
| 2574 | } |
---|
| 2575 | Tcl_SetRecursionLimit(slaveInterp, limit); |
---|
| 2576 | iPtr = (Interp *) slaveInterp; |
---|
| 2577 | if (interp == slaveInterp && iPtr->numLevels > limit) { |
---|
| 2578 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 2579 | "falling back due to new recursion limit", -1)); |
---|
| 2580 | return TCL_ERROR; |
---|
| 2581 | } |
---|
| 2582 | Tcl_SetObjResult(interp, objv[0]); |
---|
| 2583 | return TCL_OK; |
---|
| 2584 | } else { |
---|
| 2585 | limit = Tcl_SetRecursionLimit(slaveInterp, 0); |
---|
| 2586 | Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); |
---|
| 2587 | return TCL_OK; |
---|
| 2588 | } |
---|
| 2589 | } |
---|
| 2590 | |
---|
| 2591 | /* |
---|
| 2592 | *---------------------------------------------------------------------- |
---|
| 2593 | * |
---|
| 2594 | * SlaveHide -- |
---|
| 2595 | * |
---|
| 2596 | * Helper function to hide a command in a slave interpreter. |
---|
| 2597 | * |
---|
| 2598 | * Results: |
---|
| 2599 | * A standard Tcl result. |
---|
| 2600 | * |
---|
| 2601 | * Side effects: |
---|
| 2602 | * After this call scripts in the slave will no longer be able to invoke |
---|
| 2603 | * the named command. |
---|
| 2604 | * |
---|
| 2605 | *---------------------------------------------------------------------- |
---|
| 2606 | */ |
---|
| 2607 | |
---|
| 2608 | static int |
---|
| 2609 | SlaveHide( |
---|
| 2610 | Tcl_Interp *interp, /* Interp for error return. */ |
---|
| 2611 | Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */ |
---|
| 2612 | int objc, /* Number of arguments. */ |
---|
| 2613 | Tcl_Obj *const objv[]) /* Argument strings. */ |
---|
| 2614 | { |
---|
| 2615 | char *name; |
---|
| 2616 | |
---|
| 2617 | if (Tcl_IsSafe(interp)) { |
---|
| 2618 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 2619 | "permission denied: safe interpreter cannot hide commands", |
---|
| 2620 | -1)); |
---|
| 2621 | return TCL_ERROR; |
---|
| 2622 | } |
---|
| 2623 | |
---|
| 2624 | name = TclGetString(objv[(objc == 1) ? 0 : 1]); |
---|
| 2625 | if (Tcl_HideCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) { |
---|
| 2626 | TclTransferResult(slaveInterp, TCL_ERROR, interp); |
---|
| 2627 | return TCL_ERROR; |
---|
| 2628 | } |
---|
| 2629 | return TCL_OK; |
---|
| 2630 | } |
---|
| 2631 | |
---|
| 2632 | /* |
---|
| 2633 | *---------------------------------------------------------------------- |
---|
| 2634 | * |
---|
| 2635 | * SlaveHidden -- |
---|
| 2636 | * |
---|
| 2637 | * Helper function to compute list of hidden commands in a slave |
---|
| 2638 | * interpreter. |
---|
| 2639 | * |
---|
| 2640 | * Results: |
---|
| 2641 | * A standard Tcl result. |
---|
| 2642 | * |
---|
| 2643 | * Side effects: |
---|
| 2644 | * None. |
---|
| 2645 | * |
---|
| 2646 | *---------------------------------------------------------------------- |
---|
| 2647 | */ |
---|
| 2648 | |
---|
| 2649 | static int |
---|
| 2650 | SlaveHidden( |
---|
| 2651 | Tcl_Interp *interp, /* Interp for data return. */ |
---|
| 2652 | Tcl_Interp *slaveInterp) /* Interp whose hidden commands to query. */ |
---|
| 2653 | { |
---|
| 2654 | Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */ |
---|
| 2655 | Tcl_HashTable *hTblPtr; /* For local searches. */ |
---|
| 2656 | Tcl_HashEntry *hPtr; /* For local searches. */ |
---|
| 2657 | Tcl_HashSearch hSearch; /* For local searches. */ |
---|
| 2658 | |
---|
| 2659 | hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; |
---|
| 2660 | if (hTblPtr != NULL) { |
---|
| 2661 | for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); |
---|
| 2662 | hPtr != NULL; |
---|
| 2663 | hPtr = Tcl_NextHashEntry(&hSearch)) { |
---|
| 2664 | Tcl_ListObjAppendElement(NULL, listObjPtr, |
---|
| 2665 | Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); |
---|
| 2666 | } |
---|
| 2667 | } |
---|
| 2668 | Tcl_SetObjResult(interp, listObjPtr); |
---|
| 2669 | return TCL_OK; |
---|
| 2670 | } |
---|
| 2671 | |
---|
| 2672 | /* |
---|
| 2673 | *---------------------------------------------------------------------- |
---|
| 2674 | * |
---|
| 2675 | * SlaveInvokeHidden -- |
---|
| 2676 | * |
---|
| 2677 | * Helper function to invoke a hidden command in a slave interpreter. |
---|
| 2678 | * |
---|
| 2679 | * Results: |
---|
| 2680 | * A standard Tcl result. |
---|
| 2681 | * |
---|
| 2682 | * Side effects: |
---|
| 2683 | * Whatever the hidden command does. |
---|
| 2684 | * |
---|
| 2685 | *---------------------------------------------------------------------- |
---|
| 2686 | */ |
---|
| 2687 | |
---|
| 2688 | static int |
---|
| 2689 | SlaveInvokeHidden( |
---|
| 2690 | Tcl_Interp *interp, /* Interp for error return. */ |
---|
| 2691 | Tcl_Interp *slaveInterp, /* The slave interpreter in which command will |
---|
| 2692 | * be invoked. */ |
---|
| 2693 | const char *namespaceName, /* The namespace to use, if any. */ |
---|
| 2694 | int objc, /* Number of arguments. */ |
---|
| 2695 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 2696 | { |
---|
| 2697 | int result; |
---|
| 2698 | |
---|
| 2699 | if (Tcl_IsSafe(interp)) { |
---|
| 2700 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 2701 | "not allowed to invoke hidden commands from safe interpreter", |
---|
| 2702 | -1)); |
---|
| 2703 | return TCL_ERROR; |
---|
| 2704 | } |
---|
| 2705 | |
---|
| 2706 | Tcl_Preserve(slaveInterp); |
---|
| 2707 | Tcl_AllowExceptions(slaveInterp); |
---|
| 2708 | |
---|
| 2709 | if (namespaceName == NULL) { |
---|
| 2710 | result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); |
---|
| 2711 | } else { |
---|
| 2712 | Namespace *nsPtr, *dummy1, *dummy2; |
---|
| 2713 | const char *tail; |
---|
| 2714 | |
---|
| 2715 | result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL, |
---|
| 2716 | TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG |
---|
| 2717 | | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); |
---|
| 2718 | if (result == TCL_OK) { |
---|
| 2719 | result = TclObjInvokeNamespace(slaveInterp, objc, objv, |
---|
| 2720 | (Tcl_Namespace *)nsPtr, TCL_INVOKE_HIDDEN); |
---|
| 2721 | } |
---|
| 2722 | } |
---|
| 2723 | |
---|
| 2724 | TclTransferResult(slaveInterp, result, interp); |
---|
| 2725 | |
---|
| 2726 | Tcl_Release(slaveInterp); |
---|
| 2727 | return result; |
---|
| 2728 | } |
---|
| 2729 | |
---|
| 2730 | /* |
---|
| 2731 | *---------------------------------------------------------------------- |
---|
| 2732 | * |
---|
| 2733 | * SlaveMarkTrusted -- |
---|
| 2734 | * |
---|
| 2735 | * Helper function to mark a slave interpreter as trusted (unsafe). |
---|
| 2736 | * |
---|
| 2737 | * Results: |
---|
| 2738 | * A standard Tcl result. |
---|
| 2739 | * |
---|
| 2740 | * Side effects: |
---|
| 2741 | * After this call the hard-wired security checks in the core no longer |
---|
| 2742 | * prevent the slave from performing certain operations. |
---|
| 2743 | * |
---|
| 2744 | *---------------------------------------------------------------------- |
---|
| 2745 | */ |
---|
| 2746 | |
---|
| 2747 | static int |
---|
| 2748 | SlaveMarkTrusted( |
---|
| 2749 | Tcl_Interp *interp, /* Interp for error return. */ |
---|
| 2750 | Tcl_Interp *slaveInterp) /* The slave interpreter which will be marked |
---|
| 2751 | * trusted. */ |
---|
| 2752 | { |
---|
| 2753 | if (Tcl_IsSafe(interp)) { |
---|
| 2754 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 2755 | "permission denied: safe interpreter cannot mark trusted", |
---|
| 2756 | -1)); |
---|
| 2757 | return TCL_ERROR; |
---|
| 2758 | } |
---|
| 2759 | ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; |
---|
| 2760 | return TCL_OK; |
---|
| 2761 | } |
---|
| 2762 | |
---|
| 2763 | /* |
---|
| 2764 | *---------------------------------------------------------------------- |
---|
| 2765 | * |
---|
| 2766 | * Tcl_IsSafe -- |
---|
| 2767 | * |
---|
| 2768 | * Determines whether an interpreter is safe |
---|
| 2769 | * |
---|
| 2770 | * Results: |
---|
| 2771 | * 1 if it is safe, 0 if it is not. |
---|
| 2772 | * |
---|
| 2773 | * Side effects: |
---|
| 2774 | * None. |
---|
| 2775 | * |
---|
| 2776 | *---------------------------------------------------------------------- |
---|
| 2777 | */ |
---|
| 2778 | |
---|
| 2779 | int |
---|
| 2780 | Tcl_IsSafe( |
---|
| 2781 | Tcl_Interp *interp) /* Is this interpreter "safe" ? */ |
---|
| 2782 | { |
---|
| 2783 | Interp *iPtr = (Interp *) interp; |
---|
| 2784 | |
---|
| 2785 | if (iPtr == NULL) { |
---|
| 2786 | return 0; |
---|
| 2787 | } |
---|
| 2788 | return (iPtr->flags & SAFE_INTERP) ? 1 : 0; |
---|
| 2789 | } |
---|
| 2790 | |
---|
| 2791 | /* |
---|
| 2792 | *---------------------------------------------------------------------- |
---|
| 2793 | * |
---|
| 2794 | * Tcl_MakeSafe -- |
---|
| 2795 | * |
---|
| 2796 | * Makes its argument interpreter contain only functionality that is |
---|
| 2797 | * defined to be part of Safe Tcl. Unsafe commands are hidden, the env |
---|
| 2798 | * array is unset, and the standard channels are removed. |
---|
| 2799 | * |
---|
| 2800 | * Results: |
---|
| 2801 | * None. |
---|
| 2802 | * |
---|
| 2803 | * Side effects: |
---|
| 2804 | * Hides commands in its argument interpreter, and removes settings and |
---|
| 2805 | * channels. |
---|
| 2806 | * |
---|
| 2807 | *---------------------------------------------------------------------- |
---|
| 2808 | */ |
---|
| 2809 | |
---|
| 2810 | int |
---|
| 2811 | Tcl_MakeSafe( |
---|
| 2812 | Tcl_Interp *interp) /* Interpreter to be made safe. */ |
---|
| 2813 | { |
---|
| 2814 | Tcl_Channel chan; /* Channel to remove from safe interpreter. */ |
---|
| 2815 | Interp *iPtr = (Interp *) interp; |
---|
| 2816 | |
---|
| 2817 | TclHideUnsafeCommands(interp); |
---|
| 2818 | |
---|
| 2819 | iPtr->flags |= SAFE_INTERP; |
---|
| 2820 | |
---|
| 2821 | /* |
---|
| 2822 | * Unsetting variables : (which should not have been set in the first |
---|
| 2823 | * place, but...) |
---|
| 2824 | */ |
---|
| 2825 | |
---|
| 2826 | /* |
---|
| 2827 | * No env array in a safe slave. |
---|
| 2828 | */ |
---|
| 2829 | |
---|
| 2830 | Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); |
---|
| 2831 | |
---|
| 2832 | /* |
---|
| 2833 | * Remove unsafe parts of tcl_platform |
---|
| 2834 | */ |
---|
| 2835 | |
---|
| 2836 | Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY); |
---|
| 2837 | Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY); |
---|
| 2838 | Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY); |
---|
| 2839 | Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY); |
---|
| 2840 | |
---|
| 2841 | /* |
---|
| 2842 | * Unset path informations variables (the only one remaining is [info |
---|
| 2843 | * nameofexecutable]) |
---|
| 2844 | */ |
---|
| 2845 | |
---|
| 2846 | Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); |
---|
| 2847 | Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); |
---|
| 2848 | Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); |
---|
| 2849 | |
---|
| 2850 | /* |
---|
| 2851 | * Remove the standard channels from the interpreter; safe interpreters do |
---|
| 2852 | * not ordinarily have access to stdin, stdout and stderr. |
---|
| 2853 | * |
---|
| 2854 | * NOTE: These channels are not added to the interpreter by the |
---|
| 2855 | * Tcl_CreateInterp call, but may be added later, by another I/O |
---|
| 2856 | * operation. We want to ensure that the interpreter does not have these |
---|
| 2857 | * channels even if it is being made safe after being used for some time.. |
---|
| 2858 | */ |
---|
| 2859 | |
---|
| 2860 | chan = Tcl_GetStdChannel(TCL_STDIN); |
---|
| 2861 | if (chan != NULL) { |
---|
| 2862 | Tcl_UnregisterChannel(interp, chan); |
---|
| 2863 | } |
---|
| 2864 | chan = Tcl_GetStdChannel(TCL_STDOUT); |
---|
| 2865 | if (chan != NULL) { |
---|
| 2866 | Tcl_UnregisterChannel(interp, chan); |
---|
| 2867 | } |
---|
| 2868 | chan = Tcl_GetStdChannel(TCL_STDERR); |
---|
| 2869 | if (chan != NULL) { |
---|
| 2870 | Tcl_UnregisterChannel(interp, chan); |
---|
| 2871 | } |
---|
| 2872 | |
---|
| 2873 | return TCL_OK; |
---|
| 2874 | } |
---|
| 2875 | |
---|
| 2876 | /* |
---|
| 2877 | *---------------------------------------------------------------------- |
---|
| 2878 | * |
---|
| 2879 | * Tcl_LimitExceeded -- |
---|
| 2880 | * |
---|
| 2881 | * Tests whether any limit has been exceeded in the given interpreter |
---|
| 2882 | * (i.e. whether the interpreter is currently unable to process further |
---|
| 2883 | * scripts). |
---|
| 2884 | * |
---|
| 2885 | * Results: |
---|
| 2886 | * A boolean value. |
---|
| 2887 | * |
---|
| 2888 | * Side effects: |
---|
| 2889 | * None. |
---|
| 2890 | * |
---|
| 2891 | * Notes: |
---|
| 2892 | * If you change this function, you MUST also update TclLimitExceeded() in |
---|
| 2893 | * tclInt.h. |
---|
| 2894 | *---------------------------------------------------------------------- |
---|
| 2895 | */ |
---|
| 2896 | |
---|
| 2897 | int |
---|
| 2898 | Tcl_LimitExceeded( |
---|
| 2899 | Tcl_Interp *interp) |
---|
| 2900 | { |
---|
| 2901 | register Interp *iPtr = (Interp *) interp; |
---|
| 2902 | |
---|
| 2903 | return iPtr->limit.exceeded != 0; |
---|
| 2904 | } |
---|
| 2905 | |
---|
| 2906 | /* |
---|
| 2907 | *---------------------------------------------------------------------- |
---|
| 2908 | * |
---|
| 2909 | * Tcl_LimitReady -- |
---|
| 2910 | * |
---|
| 2911 | * Find out whether any limit has been set on the interpreter, and if so |
---|
| 2912 | * check whether the granularity of that limit is such that the full |
---|
| 2913 | * limit check should be carried out. |
---|
| 2914 | * |
---|
| 2915 | * Results: |
---|
| 2916 | * A boolean value that indicates whether to call Tcl_LimitCheck. |
---|
| 2917 | * |
---|
| 2918 | * Side effects: |
---|
| 2919 | * Increments the limit granularity counter. |
---|
| 2920 | * |
---|
| 2921 | * Notes: |
---|
| 2922 | * If you change this function, you MUST also update TclLimitReady() in |
---|
| 2923 | * tclInt.h. |
---|
| 2924 | * |
---|
| 2925 | *---------------------------------------------------------------------- |
---|
| 2926 | */ |
---|
| 2927 | |
---|
| 2928 | int |
---|
| 2929 | Tcl_LimitReady( |
---|
| 2930 | Tcl_Interp *interp) |
---|
| 2931 | { |
---|
| 2932 | register Interp *iPtr = (Interp *) interp; |
---|
| 2933 | |
---|
| 2934 | if (iPtr->limit.active != 0) { |
---|
| 2935 | register int ticker = ++iPtr->limit.granularityTicker; |
---|
| 2936 | |
---|
| 2937 | if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && |
---|
| 2938 | ((iPtr->limit.cmdGranularity == 1) || |
---|
| 2939 | (ticker % iPtr->limit.cmdGranularity == 0))) { |
---|
| 2940 | return 1; |
---|
| 2941 | } |
---|
| 2942 | if ((iPtr->limit.active & TCL_LIMIT_TIME) && |
---|
| 2943 | ((iPtr->limit.timeGranularity == 1) || |
---|
| 2944 | (ticker % iPtr->limit.timeGranularity == 0))) { |
---|
| 2945 | return 1; |
---|
| 2946 | } |
---|
| 2947 | } |
---|
| 2948 | return 0; |
---|
| 2949 | } |
---|
| 2950 | |
---|
| 2951 | /* |
---|
| 2952 | *---------------------------------------------------------------------- |
---|
| 2953 | * |
---|
| 2954 | * Tcl_LimitCheck -- |
---|
| 2955 | * |
---|
| 2956 | * Check all currently set limits in the interpreter (where permitted by |
---|
| 2957 | * granularity). If a limit is exceeded, call its callbacks and, if the |
---|
| 2958 | * limit is still exceeded after the callbacks have run, make the |
---|
| 2959 | * interpreter generate an error that cannot be caught within the limited |
---|
| 2960 | * interpreter. |
---|
| 2961 | * |
---|
| 2962 | * Results: |
---|
| 2963 | * A Tcl result value (TCL_OK if no limit is exceeded, and TCL_ERROR if a |
---|
| 2964 | * limit has been exceeded). |
---|
| 2965 | * |
---|
| 2966 | * Side effects: |
---|
| 2967 | * May invoke system calls. May invoke other interpreters. May be |
---|
| 2968 | * reentrant. May put the interpreter into a state where it can no longer |
---|
| 2969 | * execute commands without outside intervention. |
---|
| 2970 | * |
---|
| 2971 | *---------------------------------------------------------------------- |
---|
| 2972 | */ |
---|
| 2973 | |
---|
| 2974 | int |
---|
| 2975 | Tcl_LimitCheck( |
---|
| 2976 | Tcl_Interp *interp) |
---|
| 2977 | { |
---|
| 2978 | Interp *iPtr = (Interp *) interp; |
---|
| 2979 | register int ticker = iPtr->limit.granularityTicker; |
---|
| 2980 | |
---|
| 2981 | if (Tcl_InterpDeleted(interp)) { |
---|
| 2982 | return TCL_OK; |
---|
| 2983 | } |
---|
| 2984 | |
---|
| 2985 | if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && |
---|
| 2986 | ((iPtr->limit.cmdGranularity == 1) || |
---|
| 2987 | (ticker % iPtr->limit.cmdGranularity == 0)) && |
---|
| 2988 | (iPtr->limit.cmdCount < iPtr->cmdCount)) { |
---|
| 2989 | iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS; |
---|
| 2990 | Tcl_Preserve(interp); |
---|
| 2991 | RunLimitHandlers(iPtr->limit.cmdHandlers, interp); |
---|
| 2992 | if (iPtr->limit.cmdCount >= iPtr->cmdCount) { |
---|
| 2993 | iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; |
---|
| 2994 | } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { |
---|
| 2995 | Tcl_ResetResult(interp); |
---|
| 2996 | Tcl_AppendResult(interp, "command count limit exceeded", NULL); |
---|
| 2997 | Tcl_Release(interp); |
---|
| 2998 | return TCL_ERROR; |
---|
| 2999 | } |
---|
| 3000 | Tcl_Release(interp); |
---|
| 3001 | } |
---|
| 3002 | |
---|
| 3003 | if ((iPtr->limit.active & TCL_LIMIT_TIME) && |
---|
| 3004 | ((iPtr->limit.timeGranularity == 1) || |
---|
| 3005 | (ticker % iPtr->limit.timeGranularity == 0))) { |
---|
| 3006 | Tcl_Time now; |
---|
| 3007 | |
---|
| 3008 | Tcl_GetTime(&now); |
---|
| 3009 | if (iPtr->limit.time.sec < now.sec || |
---|
| 3010 | (iPtr->limit.time.sec == now.sec && |
---|
| 3011 | iPtr->limit.time.usec < now.usec)) { |
---|
| 3012 | iPtr->limit.exceeded |= TCL_LIMIT_TIME; |
---|
| 3013 | Tcl_Preserve(interp); |
---|
| 3014 | RunLimitHandlers(iPtr->limit.timeHandlers, interp); |
---|
| 3015 | if (iPtr->limit.time.sec > now.sec || |
---|
| 3016 | (iPtr->limit.time.sec == now.sec && |
---|
| 3017 | iPtr->limit.time.usec >= now.usec)) { |
---|
| 3018 | iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; |
---|
| 3019 | } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { |
---|
| 3020 | Tcl_ResetResult(interp); |
---|
| 3021 | Tcl_AppendResult(interp, "time limit exceeded", NULL); |
---|
| 3022 | Tcl_Release(interp); |
---|
| 3023 | return TCL_ERROR; |
---|
| 3024 | } |
---|
| 3025 | Tcl_Release(interp); |
---|
| 3026 | } |
---|
| 3027 | } |
---|
| 3028 | |
---|
| 3029 | return TCL_OK; |
---|
| 3030 | } |
---|
| 3031 | |
---|
| 3032 | /* |
---|
| 3033 | *---------------------------------------------------------------------- |
---|
| 3034 | * |
---|
| 3035 | * RunLimitHandlers -- |
---|
| 3036 | * |
---|
| 3037 | * Invoke all the limit handlers in a list (for a particular limit). |
---|
| 3038 | * Note that no particular limit handler callback will be invoked |
---|
| 3039 | * reentrantly. |
---|
| 3040 | * |
---|
| 3041 | * Results: |
---|
| 3042 | * None. |
---|
| 3043 | * |
---|
| 3044 | * Side effects: |
---|
| 3045 | * Depends on the limit handlers. |
---|
| 3046 | * |
---|
| 3047 | *---------------------------------------------------------------------- |
---|
| 3048 | */ |
---|
| 3049 | |
---|
| 3050 | static void |
---|
| 3051 | RunLimitHandlers( |
---|
| 3052 | LimitHandler *handlerPtr, |
---|
| 3053 | Tcl_Interp *interp) |
---|
| 3054 | { |
---|
| 3055 | LimitHandler *nextPtr; |
---|
| 3056 | for (; handlerPtr!=NULL ; handlerPtr=nextPtr) { |
---|
| 3057 | if (handlerPtr->flags & (LIMIT_HANDLER_DELETED|LIMIT_HANDLER_ACTIVE)) { |
---|
| 3058 | /* |
---|
| 3059 | * Reentrant call or something seriously strange in the delete |
---|
| 3060 | * code. |
---|
| 3061 | */ |
---|
| 3062 | |
---|
| 3063 | nextPtr = handlerPtr->nextPtr; |
---|
| 3064 | continue; |
---|
| 3065 | } |
---|
| 3066 | |
---|
| 3067 | /* |
---|
| 3068 | * Set the ACTIVE flag while running the limit handler itself so we |
---|
| 3069 | * cannot reentrantly call this handler and know to use the alternate |
---|
| 3070 | * method of deletion if necessary. |
---|
| 3071 | */ |
---|
| 3072 | |
---|
| 3073 | handlerPtr->flags |= LIMIT_HANDLER_ACTIVE; |
---|
| 3074 | (handlerPtr->handlerProc)(handlerPtr->clientData, interp); |
---|
| 3075 | handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE; |
---|
| 3076 | |
---|
| 3077 | /* |
---|
| 3078 | * Rediscover this value; it might have changed during the processing |
---|
| 3079 | * of a limit handler. We have to record it here because we might |
---|
| 3080 | * delete the structure below, and reading a value out of a deleted |
---|
| 3081 | * structure is unsafe (even if actually legal with some |
---|
| 3082 | * malloc()/free() implementations.) |
---|
| 3083 | */ |
---|
| 3084 | |
---|
| 3085 | nextPtr = handlerPtr->nextPtr; |
---|
| 3086 | |
---|
| 3087 | /* |
---|
| 3088 | * If we deleted the current handler while we were executing it, we |
---|
| 3089 | * will have spliced it out of the list and set the |
---|
| 3090 | * LIMIT_HANDLER_DELETED flag. |
---|
| 3091 | */ |
---|
| 3092 | |
---|
| 3093 | if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { |
---|
| 3094 | if (handlerPtr->deleteProc != NULL) { |
---|
| 3095 | (handlerPtr->deleteProc)(handlerPtr->clientData); |
---|
| 3096 | } |
---|
| 3097 | ckfree((char *) handlerPtr); |
---|
| 3098 | } |
---|
| 3099 | } |
---|
| 3100 | } |
---|
| 3101 | |
---|
| 3102 | /* |
---|
| 3103 | *---------------------------------------------------------------------- |
---|
| 3104 | * |
---|
| 3105 | * Tcl_LimitAddHandler -- |
---|
| 3106 | * |
---|
| 3107 | * Add a callback handler for a particular resource limit. |
---|
| 3108 | * |
---|
| 3109 | * Results: |
---|
| 3110 | * None. |
---|
| 3111 | * |
---|
| 3112 | * Side effects: |
---|
| 3113 | * Extends the internal linked list of handlers for a limit. |
---|
| 3114 | * |
---|
| 3115 | *---------------------------------------------------------------------- |
---|
| 3116 | */ |
---|
| 3117 | |
---|
| 3118 | void |
---|
| 3119 | Tcl_LimitAddHandler( |
---|
| 3120 | Tcl_Interp *interp, |
---|
| 3121 | int type, |
---|
| 3122 | Tcl_LimitHandlerProc *handlerProc, |
---|
| 3123 | ClientData clientData, |
---|
| 3124 | Tcl_LimitHandlerDeleteProc *deleteProc) |
---|
| 3125 | { |
---|
| 3126 | Interp *iPtr = (Interp *) interp; |
---|
| 3127 | LimitHandler *handlerPtr; |
---|
| 3128 | |
---|
| 3129 | /* |
---|
| 3130 | * Convert everything into a real deletion callback. |
---|
| 3131 | */ |
---|
| 3132 | |
---|
| 3133 | if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) { |
---|
| 3134 | deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free; |
---|
| 3135 | } |
---|
| 3136 | if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) { |
---|
| 3137 | deleteProc = NULL; |
---|
| 3138 | } |
---|
| 3139 | |
---|
| 3140 | /* |
---|
| 3141 | * Allocate a handler record. |
---|
| 3142 | */ |
---|
| 3143 | |
---|
| 3144 | handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler)); |
---|
| 3145 | handlerPtr->flags = 0; |
---|
| 3146 | handlerPtr->handlerProc = handlerProc; |
---|
| 3147 | handlerPtr->clientData = clientData; |
---|
| 3148 | handlerPtr->deleteProc = deleteProc; |
---|
| 3149 | handlerPtr->prevPtr = NULL; |
---|
| 3150 | |
---|
| 3151 | /* |
---|
| 3152 | * Prepend onto the front of the correct linked list. |
---|
| 3153 | */ |
---|
| 3154 | |
---|
| 3155 | switch (type) { |
---|
| 3156 | case TCL_LIMIT_COMMANDS: |
---|
| 3157 | handlerPtr->nextPtr = iPtr->limit.cmdHandlers; |
---|
| 3158 | if (handlerPtr->nextPtr != NULL) { |
---|
| 3159 | handlerPtr->nextPtr->prevPtr = handlerPtr; |
---|
| 3160 | } |
---|
| 3161 | iPtr->limit.cmdHandlers = handlerPtr; |
---|
| 3162 | return; |
---|
| 3163 | |
---|
| 3164 | case TCL_LIMIT_TIME: |
---|
| 3165 | handlerPtr->nextPtr = iPtr->limit.timeHandlers; |
---|
| 3166 | if (handlerPtr->nextPtr != NULL) { |
---|
| 3167 | handlerPtr->nextPtr->prevPtr = handlerPtr; |
---|
| 3168 | } |
---|
| 3169 | iPtr->limit.timeHandlers = handlerPtr; |
---|
| 3170 | return; |
---|
| 3171 | } |
---|
| 3172 | |
---|
| 3173 | Tcl_Panic("unknown type of resource limit"); |
---|
| 3174 | } |
---|
| 3175 | |
---|
| 3176 | /* |
---|
| 3177 | *---------------------------------------------------------------------- |
---|
| 3178 | * |
---|
| 3179 | * Tcl_LimitRemoveHandler -- |
---|
| 3180 | * |
---|
| 3181 | * Remove a callback handler for a particular resource limit. |
---|
| 3182 | * |
---|
| 3183 | * Results: |
---|
| 3184 | * None. |
---|
| 3185 | * |
---|
| 3186 | * Side effects: |
---|
| 3187 | * The handler is spliced out of the internal linked list for the limit, |
---|
| 3188 | * and if not currently being invoked, deleted. Otherwise it is just |
---|
| 3189 | * marked for deletion and removed when the limit handler has finished |
---|
| 3190 | * executing. |
---|
| 3191 | * |
---|
| 3192 | *---------------------------------------------------------------------- |
---|
| 3193 | */ |
---|
| 3194 | |
---|
| 3195 | void |
---|
| 3196 | Tcl_LimitRemoveHandler( |
---|
| 3197 | Tcl_Interp *interp, |
---|
| 3198 | int type, |
---|
| 3199 | Tcl_LimitHandlerProc *handlerProc, |
---|
| 3200 | ClientData clientData) |
---|
| 3201 | { |
---|
| 3202 | Interp *iPtr = (Interp *) interp; |
---|
| 3203 | LimitHandler *handlerPtr; |
---|
| 3204 | |
---|
| 3205 | switch (type) { |
---|
| 3206 | case TCL_LIMIT_COMMANDS: |
---|
| 3207 | handlerPtr = iPtr->limit.cmdHandlers; |
---|
| 3208 | break; |
---|
| 3209 | case TCL_LIMIT_TIME: |
---|
| 3210 | handlerPtr = iPtr->limit.timeHandlers; |
---|
| 3211 | break; |
---|
| 3212 | default: |
---|
| 3213 | Tcl_Panic("unknown type of resource limit"); |
---|
| 3214 | return; |
---|
| 3215 | } |
---|
| 3216 | |
---|
| 3217 | for (; handlerPtr!=NULL ; handlerPtr=handlerPtr->nextPtr) { |
---|
| 3218 | if ((handlerPtr->handlerProc != handlerProc) || |
---|
| 3219 | (handlerPtr->clientData != clientData)) { |
---|
| 3220 | continue; |
---|
| 3221 | } |
---|
| 3222 | |
---|
| 3223 | /* |
---|
| 3224 | * We've found the handler to delete; mark it as doomed if not already |
---|
| 3225 | * so marked (which shouldn't actually happen). |
---|
| 3226 | */ |
---|
| 3227 | |
---|
| 3228 | if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { |
---|
| 3229 | return; |
---|
| 3230 | } |
---|
| 3231 | handlerPtr->flags |= LIMIT_HANDLER_DELETED; |
---|
| 3232 | |
---|
| 3233 | /* |
---|
| 3234 | * Splice the handler out of the doubly-linked list. |
---|
| 3235 | */ |
---|
| 3236 | |
---|
| 3237 | if (handlerPtr->prevPtr == NULL) { |
---|
| 3238 | switch (type) { |
---|
| 3239 | case TCL_LIMIT_COMMANDS: |
---|
| 3240 | iPtr->limit.cmdHandlers = handlerPtr->nextPtr; |
---|
| 3241 | break; |
---|
| 3242 | case TCL_LIMIT_TIME: |
---|
| 3243 | iPtr->limit.timeHandlers = handlerPtr->nextPtr; |
---|
| 3244 | break; |
---|
| 3245 | } |
---|
| 3246 | } else { |
---|
| 3247 | handlerPtr->prevPtr->nextPtr = handlerPtr->nextPtr; |
---|
| 3248 | } |
---|
| 3249 | if (handlerPtr->nextPtr != NULL) { |
---|
| 3250 | handlerPtr->nextPtr->prevPtr = handlerPtr->prevPtr; |
---|
| 3251 | } |
---|
| 3252 | |
---|
| 3253 | /* |
---|
| 3254 | * If nothing is currently executing the handler, delete its client |
---|
| 3255 | * data and the overall handler structure now. Otherwise it will all |
---|
| 3256 | * go away when the handler returns. |
---|
| 3257 | */ |
---|
| 3258 | |
---|
| 3259 | if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { |
---|
| 3260 | if (handlerPtr->deleteProc != NULL) { |
---|
| 3261 | (handlerPtr->deleteProc)(handlerPtr->clientData); |
---|
| 3262 | } |
---|
| 3263 | ckfree((char *) handlerPtr); |
---|
| 3264 | } |
---|
| 3265 | return; |
---|
| 3266 | } |
---|
| 3267 | } |
---|
| 3268 | |
---|
| 3269 | /* |
---|
| 3270 | *---------------------------------------------------------------------- |
---|
| 3271 | * |
---|
| 3272 | * TclLimitRemoveAllHandlers -- |
---|
| 3273 | * |
---|
| 3274 | * Remove all limit callback handlers for an interpreter. This is invoked |
---|
| 3275 | * as part of deleting the interpreter. |
---|
| 3276 | * |
---|
| 3277 | * Results: |
---|
| 3278 | * None. |
---|
| 3279 | * |
---|
| 3280 | * Side effects: |
---|
| 3281 | * Limit handlers are deleted or marked for deletion (as with |
---|
| 3282 | * Tcl_LimitRemoveHandler). |
---|
| 3283 | * |
---|
| 3284 | *---------------------------------------------------------------------- |
---|
| 3285 | */ |
---|
| 3286 | |
---|
| 3287 | void |
---|
| 3288 | TclLimitRemoveAllHandlers( |
---|
| 3289 | Tcl_Interp *interp) |
---|
| 3290 | { |
---|
| 3291 | Interp *iPtr = (Interp *) interp; |
---|
| 3292 | LimitHandler *handlerPtr, *nextHandlerPtr; |
---|
| 3293 | |
---|
| 3294 | /* |
---|
| 3295 | * Delete all command-limit handlers. |
---|
| 3296 | */ |
---|
| 3297 | |
---|
| 3298 | for (handlerPtr=iPtr->limit.cmdHandlers, iPtr->limit.cmdHandlers=NULL; |
---|
| 3299 | handlerPtr!=NULL; handlerPtr=nextHandlerPtr) { |
---|
| 3300 | nextHandlerPtr = handlerPtr->nextPtr; |
---|
| 3301 | |
---|
| 3302 | /* |
---|
| 3303 | * Do not delete here if it has already been marked for deletion. |
---|
| 3304 | */ |
---|
| 3305 | |
---|
| 3306 | if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { |
---|
| 3307 | continue; |
---|
| 3308 | } |
---|
| 3309 | handlerPtr->flags |= LIMIT_HANDLER_DELETED; |
---|
| 3310 | handlerPtr->prevPtr = NULL; |
---|
| 3311 | handlerPtr->nextPtr = NULL; |
---|
| 3312 | |
---|
| 3313 | /* |
---|
| 3314 | * If nothing is currently executing the handler, delete its client |
---|
| 3315 | * data and the overall handler structure now. Otherwise it will all |
---|
| 3316 | * go away when the handler returns. |
---|
| 3317 | */ |
---|
| 3318 | |
---|
| 3319 | if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { |
---|
| 3320 | if (handlerPtr->deleteProc != NULL) { |
---|
| 3321 | (handlerPtr->deleteProc)(handlerPtr->clientData); |
---|
| 3322 | } |
---|
| 3323 | ckfree((char *) handlerPtr); |
---|
| 3324 | } |
---|
| 3325 | } |
---|
| 3326 | |
---|
| 3327 | /* |
---|
| 3328 | * Delete all time-limit handlers. |
---|
| 3329 | */ |
---|
| 3330 | |
---|
| 3331 | for (handlerPtr=iPtr->limit.timeHandlers, iPtr->limit.timeHandlers=NULL; |
---|
| 3332 | handlerPtr!=NULL; handlerPtr=nextHandlerPtr) { |
---|
| 3333 | nextHandlerPtr = handlerPtr->nextPtr; |
---|
| 3334 | |
---|
| 3335 | /* |
---|
| 3336 | * Do not delete here if it has already been marked for deletion. |
---|
| 3337 | */ |
---|
| 3338 | |
---|
| 3339 | if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { |
---|
| 3340 | continue; |
---|
| 3341 | } |
---|
| 3342 | handlerPtr->flags |= LIMIT_HANDLER_DELETED; |
---|
| 3343 | handlerPtr->prevPtr = NULL; |
---|
| 3344 | handlerPtr->nextPtr = NULL; |
---|
| 3345 | |
---|
| 3346 | /* |
---|
| 3347 | * If nothing is currently executing the handler, delete its client |
---|
| 3348 | * data and the overall handler structure now. Otherwise it will all |
---|
| 3349 | * go away when the handler returns. |
---|
| 3350 | */ |
---|
| 3351 | |
---|
| 3352 | if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { |
---|
| 3353 | if (handlerPtr->deleteProc != NULL) { |
---|
| 3354 | (handlerPtr->deleteProc)(handlerPtr->clientData); |
---|
| 3355 | } |
---|
| 3356 | ckfree((char *) handlerPtr); |
---|
| 3357 | } |
---|
| 3358 | } |
---|
| 3359 | |
---|
| 3360 | /* |
---|
| 3361 | * Delete the timer callback that is used to trap limits that occur in |
---|
| 3362 | * [vwait]s... |
---|
| 3363 | */ |
---|
| 3364 | |
---|
| 3365 | if (iPtr->limit.timeEvent != NULL) { |
---|
| 3366 | Tcl_DeleteTimerHandler(iPtr->limit.timeEvent); |
---|
| 3367 | iPtr->limit.timeEvent = NULL; |
---|
| 3368 | } |
---|
| 3369 | } |
---|
| 3370 | |
---|
| 3371 | /* |
---|
| 3372 | *---------------------------------------------------------------------- |
---|
| 3373 | * |
---|
| 3374 | * Tcl_LimitTypeEnabled -- |
---|
| 3375 | * |
---|
| 3376 | * Check whether a particular limit has been enabled for an interpreter. |
---|
| 3377 | * |
---|
| 3378 | * Results: |
---|
| 3379 | * A boolean value. |
---|
| 3380 | * |
---|
| 3381 | * Side effects: |
---|
| 3382 | * None. |
---|
| 3383 | * |
---|
| 3384 | *---------------------------------------------------------------------- |
---|
| 3385 | */ |
---|
| 3386 | |
---|
| 3387 | int |
---|
| 3388 | Tcl_LimitTypeEnabled( |
---|
| 3389 | Tcl_Interp *interp, |
---|
| 3390 | int type) |
---|
| 3391 | { |
---|
| 3392 | Interp *iPtr = (Interp *) interp; |
---|
| 3393 | |
---|
| 3394 | return (iPtr->limit.active & type) != 0; |
---|
| 3395 | } |
---|
| 3396 | |
---|
| 3397 | /* |
---|
| 3398 | *---------------------------------------------------------------------- |
---|
| 3399 | * |
---|
| 3400 | * Tcl_LimitTypeExceeded -- |
---|
| 3401 | * |
---|
| 3402 | * Check whether a particular limit has been exceeded for an interpreter. |
---|
| 3403 | * |
---|
| 3404 | * Results: |
---|
| 3405 | * A boolean value (note that Tcl_LimitExceeded will always return |
---|
| 3406 | * non-zero when this function returns non-zero). |
---|
| 3407 | * |
---|
| 3408 | * Side effects: |
---|
| 3409 | * None. |
---|
| 3410 | * |
---|
| 3411 | *---------------------------------------------------------------------- |
---|
| 3412 | */ |
---|
| 3413 | |
---|
| 3414 | int |
---|
| 3415 | Tcl_LimitTypeExceeded( |
---|
| 3416 | Tcl_Interp *interp, |
---|
| 3417 | int type) |
---|
| 3418 | { |
---|
| 3419 | Interp *iPtr = (Interp *) interp; |
---|
| 3420 | |
---|
| 3421 | return (iPtr->limit.exceeded & type) != 0; |
---|
| 3422 | } |
---|
| 3423 | |
---|
| 3424 | /* |
---|
| 3425 | *---------------------------------------------------------------------- |
---|
| 3426 | * |
---|
| 3427 | * Tcl_LimitTypeSet -- |
---|
| 3428 | * |
---|
| 3429 | * Enable a particular limit for an interpreter. |
---|
| 3430 | * |
---|
| 3431 | * Results: |
---|
| 3432 | * None. |
---|
| 3433 | * |
---|
| 3434 | * Side effects: |
---|
| 3435 | * The limit is turned on and will be checked in future at an interval |
---|
| 3436 | * determined by the frequency of calling of Tcl_LimitReady and the |
---|
| 3437 | * granularity of the limit in question. |
---|
| 3438 | * |
---|
| 3439 | *---------------------------------------------------------------------- |
---|
| 3440 | */ |
---|
| 3441 | |
---|
| 3442 | void |
---|
| 3443 | Tcl_LimitTypeSet( |
---|
| 3444 | Tcl_Interp *interp, |
---|
| 3445 | int type) |
---|
| 3446 | { |
---|
| 3447 | Interp *iPtr = (Interp *) interp; |
---|
| 3448 | |
---|
| 3449 | iPtr->limit.active |= type; |
---|
| 3450 | } |
---|
| 3451 | |
---|
| 3452 | /* |
---|
| 3453 | *---------------------------------------------------------------------- |
---|
| 3454 | * |
---|
| 3455 | * Tcl_LimitTypeReset -- |
---|
| 3456 | * |
---|
| 3457 | * Disable a particular limit for an interpreter. |
---|
| 3458 | * |
---|
| 3459 | * Results: |
---|
| 3460 | * None. |
---|
| 3461 | * |
---|
| 3462 | * Side effects: |
---|
| 3463 | * The limit is disabled. If the limit was exceeded when this function |
---|
| 3464 | * was called, the limit will no longer be exceeded afterwards and the |
---|
| 3465 | * interpreter will be free to execute further scripts (assuming it isn't |
---|
| 3466 | * also deleted, of course). |
---|
| 3467 | * |
---|
| 3468 | *---------------------------------------------------------------------- |
---|
| 3469 | */ |
---|
| 3470 | |
---|
| 3471 | void |
---|
| 3472 | Tcl_LimitTypeReset( |
---|
| 3473 | Tcl_Interp *interp, |
---|
| 3474 | int type) |
---|
| 3475 | { |
---|
| 3476 | Interp *iPtr = (Interp *) interp; |
---|
| 3477 | |
---|
| 3478 | iPtr->limit.active &= ~type; |
---|
| 3479 | iPtr->limit.exceeded &= ~type; |
---|
| 3480 | } |
---|
| 3481 | |
---|
| 3482 | /* |
---|
| 3483 | *---------------------------------------------------------------------- |
---|
| 3484 | * |
---|
| 3485 | * Tcl_LimitSetCommands -- |
---|
| 3486 | * |
---|
| 3487 | * Set the command limit for an interpreter. |
---|
| 3488 | * |
---|
| 3489 | * Results: |
---|
| 3490 | * None. |
---|
| 3491 | * |
---|
| 3492 | * Side effects: |
---|
| 3493 | * Also resets whether the command limit was exceeded. This might permit |
---|
| 3494 | * a small amount of further execution in the interpreter even if the |
---|
| 3495 | * limit itself is theoretically exceeded. |
---|
| 3496 | * |
---|
| 3497 | *---------------------------------------------------------------------- |
---|
| 3498 | */ |
---|
| 3499 | |
---|
| 3500 | void |
---|
| 3501 | Tcl_LimitSetCommands( |
---|
| 3502 | Tcl_Interp *interp, |
---|
| 3503 | int commandLimit) |
---|
| 3504 | { |
---|
| 3505 | Interp *iPtr = (Interp *) interp; |
---|
| 3506 | |
---|
| 3507 | iPtr->limit.cmdCount = commandLimit; |
---|
| 3508 | iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; |
---|
| 3509 | } |
---|
| 3510 | |
---|
| 3511 | /* |
---|
| 3512 | *---------------------------------------------------------------------- |
---|
| 3513 | * |
---|
| 3514 | * Tcl_LimitGetCommands -- |
---|
| 3515 | * |
---|
| 3516 | * Get the number of commands that may be executed in the interpreter |
---|
| 3517 | * before the command-limit is reached. |
---|
| 3518 | * |
---|
| 3519 | * Results: |
---|
| 3520 | * An upper bound on the number of commands. |
---|
| 3521 | * |
---|
| 3522 | * Side effects: |
---|
| 3523 | * None. |
---|
| 3524 | * |
---|
| 3525 | *---------------------------------------------------------------------- |
---|
| 3526 | */ |
---|
| 3527 | |
---|
| 3528 | int |
---|
| 3529 | Tcl_LimitGetCommands( |
---|
| 3530 | Tcl_Interp *interp) |
---|
| 3531 | { |
---|
| 3532 | Interp *iPtr = (Interp *) interp; |
---|
| 3533 | |
---|
| 3534 | return iPtr->limit.cmdCount; |
---|
| 3535 | } |
---|
| 3536 | |
---|
| 3537 | /* |
---|
| 3538 | *---------------------------------------------------------------------- |
---|
| 3539 | * |
---|
| 3540 | * Tcl_LimitSetTime -- |
---|
| 3541 | * |
---|
| 3542 | * Set the time limit for an interpreter by copying it from the value |
---|
| 3543 | * pointed to by the timeLimitPtr argument. |
---|
| 3544 | * |
---|
| 3545 | * Results: |
---|
| 3546 | * None. |
---|
| 3547 | * |
---|
| 3548 | * Side effects: |
---|
| 3549 | * Also resets whether the time limit was exceeded. This might permit a |
---|
| 3550 | * small amount of further execution in the interpreter even if the limit |
---|
| 3551 | * itself is theoretically exceeded. |
---|
| 3552 | * |
---|
| 3553 | *---------------------------------------------------------------------- |
---|
| 3554 | */ |
---|
| 3555 | |
---|
| 3556 | void |
---|
| 3557 | Tcl_LimitSetTime( |
---|
| 3558 | Tcl_Interp *interp, |
---|
| 3559 | Tcl_Time *timeLimitPtr) |
---|
| 3560 | { |
---|
| 3561 | Interp *iPtr = (Interp *) interp; |
---|
| 3562 | Tcl_Time nextMoment; |
---|
| 3563 | |
---|
| 3564 | memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time)); |
---|
| 3565 | if (iPtr->limit.timeEvent != NULL) { |
---|
| 3566 | Tcl_DeleteTimerHandler(iPtr->limit.timeEvent); |
---|
| 3567 | } |
---|
| 3568 | nextMoment.sec = timeLimitPtr->sec; |
---|
| 3569 | nextMoment.usec = timeLimitPtr->usec+10; |
---|
| 3570 | if (nextMoment.usec >= 1000000) { |
---|
| 3571 | nextMoment.sec++; |
---|
| 3572 | nextMoment.usec -= 1000000; |
---|
| 3573 | } |
---|
| 3574 | iPtr->limit.timeEvent = TclCreateAbsoluteTimerHandler(&nextMoment, |
---|
| 3575 | TimeLimitCallback, interp); |
---|
| 3576 | iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; |
---|
| 3577 | } |
---|
| 3578 | |
---|
| 3579 | /* |
---|
| 3580 | *---------------------------------------------------------------------- |
---|
| 3581 | * |
---|
| 3582 | * TimeLimitCallback -- |
---|
| 3583 | * |
---|
| 3584 | * Callback that allows time limits to be enforced even when doing a |
---|
| 3585 | * blocking wait for events. |
---|
| 3586 | * |
---|
| 3587 | * Results: |
---|
| 3588 | * None. |
---|
| 3589 | * |
---|
| 3590 | * Side effects: |
---|
| 3591 | * May put the interpreter into a state where it can no longer execute |
---|
| 3592 | * commands. May make callbacks into other interpreters. |
---|
| 3593 | * |
---|
| 3594 | *---------------------------------------------------------------------- |
---|
| 3595 | */ |
---|
| 3596 | |
---|
| 3597 | static void |
---|
| 3598 | TimeLimitCallback( |
---|
| 3599 | ClientData clientData) |
---|
| 3600 | { |
---|
| 3601 | Tcl_Interp *interp = clientData; |
---|
| 3602 | int code; |
---|
| 3603 | |
---|
| 3604 | Tcl_Preserve(interp); |
---|
| 3605 | ((Interp *)interp)->limit.timeEvent = NULL; |
---|
| 3606 | code = Tcl_LimitCheck(interp); |
---|
| 3607 | if (code != TCL_OK) { |
---|
| 3608 | Tcl_AddErrorInfo(interp, "\n (while waiting for event)"); |
---|
| 3609 | TclBackgroundException(interp, code); |
---|
| 3610 | } |
---|
| 3611 | Tcl_Release(interp); |
---|
| 3612 | } |
---|
| 3613 | |
---|
| 3614 | /* |
---|
| 3615 | *---------------------------------------------------------------------- |
---|
| 3616 | * |
---|
| 3617 | * Tcl_LimitGetTime -- |
---|
| 3618 | * |
---|
| 3619 | * Get the current time limit. |
---|
| 3620 | * |
---|
| 3621 | * Results: |
---|
| 3622 | * The time limit (by it being copied into the variable pointed to by the |
---|
| 3623 | * timeLimitPtr). |
---|
| 3624 | * |
---|
| 3625 | * Side effects: |
---|
| 3626 | * None. |
---|
| 3627 | * |
---|
| 3628 | *---------------------------------------------------------------------- |
---|
| 3629 | */ |
---|
| 3630 | |
---|
| 3631 | void |
---|
| 3632 | Tcl_LimitGetTime( |
---|
| 3633 | Tcl_Interp *interp, |
---|
| 3634 | Tcl_Time *timeLimitPtr) |
---|
| 3635 | { |
---|
| 3636 | Interp *iPtr = (Interp *) interp; |
---|
| 3637 | |
---|
| 3638 | memcpy(timeLimitPtr, &iPtr->limit.time, sizeof(Tcl_Time)); |
---|
| 3639 | } |
---|
| 3640 | |
---|
| 3641 | /* |
---|
| 3642 | *---------------------------------------------------------------------- |
---|
| 3643 | * |
---|
| 3644 | * Tcl_LimitSetGranularity -- |
---|
| 3645 | * |
---|
| 3646 | * Set the granularity divisor (which must be positive) for a particular |
---|
| 3647 | * limit. |
---|
| 3648 | * |
---|
| 3649 | * Results: |
---|
| 3650 | * None. |
---|
| 3651 | * |
---|
| 3652 | * Side effects: |
---|
| 3653 | * The granularity is updated. |
---|
| 3654 | * |
---|
| 3655 | *---------------------------------------------------------------------- |
---|
| 3656 | */ |
---|
| 3657 | |
---|
| 3658 | void |
---|
| 3659 | Tcl_LimitSetGranularity( |
---|
| 3660 | Tcl_Interp *interp, |
---|
| 3661 | int type, |
---|
| 3662 | int granularity) |
---|
| 3663 | { |
---|
| 3664 | Interp *iPtr = (Interp *) interp; |
---|
| 3665 | if (granularity < 1) { |
---|
| 3666 | Tcl_Panic("limit granularity must be positive"); |
---|
| 3667 | } |
---|
| 3668 | |
---|
| 3669 | switch (type) { |
---|
| 3670 | case TCL_LIMIT_COMMANDS: |
---|
| 3671 | iPtr->limit.cmdGranularity = granularity; |
---|
| 3672 | return; |
---|
| 3673 | case TCL_LIMIT_TIME: |
---|
| 3674 | iPtr->limit.timeGranularity = granularity; |
---|
| 3675 | return; |
---|
| 3676 | } |
---|
| 3677 | Tcl_Panic("unknown type of resource limit"); |
---|
| 3678 | } |
---|
| 3679 | |
---|
| 3680 | /* |
---|
| 3681 | *---------------------------------------------------------------------- |
---|
| 3682 | * |
---|
| 3683 | * Tcl_LimitGetGranularity -- |
---|
| 3684 | * |
---|
| 3685 | * Get the granularity divisor for a particular limit. |
---|
| 3686 | * |
---|
| 3687 | * Results: |
---|
| 3688 | * The granularity divisor for the given limit. |
---|
| 3689 | * |
---|
| 3690 | * Side effects: |
---|
| 3691 | * None. |
---|
| 3692 | * |
---|
| 3693 | *---------------------------------------------------------------------- |
---|
| 3694 | */ |
---|
| 3695 | |
---|
| 3696 | int |
---|
| 3697 | Tcl_LimitGetGranularity( |
---|
| 3698 | Tcl_Interp *interp, |
---|
| 3699 | int type) |
---|
| 3700 | { |
---|
| 3701 | Interp *iPtr = (Interp *) interp; |
---|
| 3702 | |
---|
| 3703 | switch (type) { |
---|
| 3704 | case TCL_LIMIT_COMMANDS: |
---|
| 3705 | return iPtr->limit.cmdGranularity; |
---|
| 3706 | case TCL_LIMIT_TIME: |
---|
| 3707 | return iPtr->limit.timeGranularity; |
---|
| 3708 | } |
---|
| 3709 | Tcl_Panic("unknown type of resource limit"); |
---|
| 3710 | return -1; /* NOT REACHED */ |
---|
| 3711 | } |
---|
| 3712 | |
---|
| 3713 | /* |
---|
| 3714 | *---------------------------------------------------------------------- |
---|
| 3715 | * |
---|
| 3716 | * DeleteScriptLimitCallback -- |
---|
| 3717 | * |
---|
| 3718 | * Callback for when a script limit (a limit callback implemented as a |
---|
| 3719 | * Tcl script in a master interpreter, as set up from Tcl) is deleted. |
---|
| 3720 | * |
---|
| 3721 | * Results: |
---|
| 3722 | * None. |
---|
| 3723 | * |
---|
| 3724 | * Side effects: |
---|
| 3725 | * The reference to the script callback from the controlling interpreter |
---|
| 3726 | * is removed. |
---|
| 3727 | * |
---|
| 3728 | *---------------------------------------------------------------------- |
---|
| 3729 | */ |
---|
| 3730 | |
---|
| 3731 | static void |
---|
| 3732 | DeleteScriptLimitCallback( |
---|
| 3733 | ClientData clientData) |
---|
| 3734 | { |
---|
| 3735 | ScriptLimitCallback *limitCBPtr = clientData; |
---|
| 3736 | |
---|
| 3737 | Tcl_DecrRefCount(limitCBPtr->scriptObj); |
---|
| 3738 | if (limitCBPtr->entryPtr != NULL) { |
---|
| 3739 | Tcl_DeleteHashEntry(limitCBPtr->entryPtr); |
---|
| 3740 | } |
---|
| 3741 | ckfree((char *) limitCBPtr); |
---|
| 3742 | } |
---|
| 3743 | |
---|
| 3744 | /* |
---|
| 3745 | *---------------------------------------------------------------------- |
---|
| 3746 | * |
---|
| 3747 | * CallScriptLimitCallback -- |
---|
| 3748 | * |
---|
| 3749 | * Invoke a script limit callback. Used to implement limit callbacks set |
---|
| 3750 | * at the Tcl level on child interpreters. |
---|
| 3751 | * |
---|
| 3752 | * Results: |
---|
| 3753 | * None. |
---|
| 3754 | * |
---|
| 3755 | * Side effects: |
---|
| 3756 | * Depends on the callback script. Errors are reported as background |
---|
| 3757 | * errors. |
---|
| 3758 | * |
---|
| 3759 | *---------------------------------------------------------------------- |
---|
| 3760 | */ |
---|
| 3761 | |
---|
| 3762 | static void |
---|
| 3763 | CallScriptLimitCallback( |
---|
| 3764 | ClientData clientData, |
---|
| 3765 | Tcl_Interp *interp) /* Interpreter which failed the limit */ |
---|
| 3766 | { |
---|
| 3767 | ScriptLimitCallback *limitCBPtr = clientData; |
---|
| 3768 | int code; |
---|
| 3769 | |
---|
| 3770 | if (Tcl_InterpDeleted(limitCBPtr->interp)) { |
---|
| 3771 | return; |
---|
| 3772 | } |
---|
| 3773 | Tcl_Preserve(limitCBPtr->interp); |
---|
| 3774 | code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj, |
---|
| 3775 | TCL_EVAL_GLOBAL); |
---|
| 3776 | if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) { |
---|
| 3777 | TclBackgroundException(limitCBPtr->interp, code); |
---|
| 3778 | } |
---|
| 3779 | Tcl_Release(limitCBPtr->interp); |
---|
| 3780 | } |
---|
| 3781 | |
---|
| 3782 | /* |
---|
| 3783 | *---------------------------------------------------------------------- |
---|
| 3784 | * |
---|
| 3785 | * SetScriptLimitCallback -- |
---|
| 3786 | * |
---|
| 3787 | * Install (or remove, if scriptObj is NULL) a limit callback script that |
---|
| 3788 | * is called when the target interpreter exceeds the type of limit |
---|
| 3789 | * specified. Each interpreter may only have one callback set on another |
---|
| 3790 | * interpreter through this mechanism (though as many interpreters may be |
---|
| 3791 | * limited as the programmer chooses overall). |
---|
| 3792 | * |
---|
| 3793 | * Results: |
---|
| 3794 | * None. |
---|
| 3795 | * |
---|
| 3796 | * Side effects: |
---|
| 3797 | * A limit callback implemented as an invokation of a Tcl script in |
---|
| 3798 | * another interpreter is either installed or removed. |
---|
| 3799 | * |
---|
| 3800 | *---------------------------------------------------------------------- |
---|
| 3801 | */ |
---|
| 3802 | |
---|
| 3803 | static void |
---|
| 3804 | SetScriptLimitCallback( |
---|
| 3805 | Tcl_Interp *interp, |
---|
| 3806 | int type, |
---|
| 3807 | Tcl_Interp *targetInterp, |
---|
| 3808 | Tcl_Obj *scriptObj) |
---|
| 3809 | { |
---|
| 3810 | ScriptLimitCallback *limitCBPtr; |
---|
| 3811 | Tcl_HashEntry *hashPtr; |
---|
| 3812 | int isNew; |
---|
| 3813 | ScriptLimitCallbackKey key; |
---|
| 3814 | Interp *iPtr = (Interp *) interp; |
---|
| 3815 | |
---|
| 3816 | if (interp == targetInterp) { |
---|
| 3817 | Tcl_Panic("installing limit callback to the limited interpreter"); |
---|
| 3818 | } |
---|
| 3819 | |
---|
| 3820 | key.interp = targetInterp; |
---|
| 3821 | key.type = type; |
---|
| 3822 | |
---|
| 3823 | if (scriptObj == NULL) { |
---|
| 3824 | hashPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); |
---|
| 3825 | if (hashPtr != NULL) { |
---|
| 3826 | Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, |
---|
| 3827 | Tcl_GetHashValue(hashPtr)); |
---|
| 3828 | } |
---|
| 3829 | return; |
---|
| 3830 | } |
---|
| 3831 | |
---|
| 3832 | hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, (char *) &key, |
---|
| 3833 | &isNew); |
---|
| 3834 | if (!isNew) { |
---|
| 3835 | limitCBPtr = Tcl_GetHashValue(hashPtr); |
---|
| 3836 | limitCBPtr->entryPtr = NULL; |
---|
| 3837 | Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, |
---|
| 3838 | limitCBPtr); |
---|
| 3839 | } |
---|
| 3840 | |
---|
| 3841 | limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback)); |
---|
| 3842 | limitCBPtr->interp = interp; |
---|
| 3843 | limitCBPtr->scriptObj = scriptObj; |
---|
| 3844 | limitCBPtr->entryPtr = hashPtr; |
---|
| 3845 | limitCBPtr->type = type; |
---|
| 3846 | Tcl_IncrRefCount(scriptObj); |
---|
| 3847 | |
---|
| 3848 | Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback, |
---|
| 3849 | limitCBPtr, DeleteScriptLimitCallback); |
---|
| 3850 | Tcl_SetHashValue(hashPtr, limitCBPtr); |
---|
| 3851 | } |
---|
| 3852 | |
---|
| 3853 | /* |
---|
| 3854 | *---------------------------------------------------------------------- |
---|
| 3855 | * |
---|
| 3856 | * TclRemoveScriptLimitCallbacks -- |
---|
| 3857 | * |
---|
| 3858 | * Remove all script-implemented limit callbacks that make calls back |
---|
| 3859 | * into the given interpreter. This invoked as part of deleting an |
---|
| 3860 | * interpreter. |
---|
| 3861 | * |
---|
| 3862 | * Results: |
---|
| 3863 | * None. |
---|
| 3864 | * |
---|
| 3865 | * Side effects: |
---|
| 3866 | * The script limit callbacks are removed or marked for later removal. |
---|
| 3867 | * |
---|
| 3868 | *---------------------------------------------------------------------- |
---|
| 3869 | */ |
---|
| 3870 | |
---|
| 3871 | void |
---|
| 3872 | TclRemoveScriptLimitCallbacks( |
---|
| 3873 | Tcl_Interp *interp) |
---|
| 3874 | { |
---|
| 3875 | Interp *iPtr = (Interp *) interp; |
---|
| 3876 | Tcl_HashEntry *hashPtr; |
---|
| 3877 | Tcl_HashSearch search; |
---|
| 3878 | ScriptLimitCallbackKey *keyPtr; |
---|
| 3879 | |
---|
| 3880 | hashPtr = Tcl_FirstHashEntry(&iPtr->limit.callbacks, &search); |
---|
| 3881 | while (hashPtr != NULL) { |
---|
| 3882 | keyPtr = (ScriptLimitCallbackKey *) |
---|
| 3883 | Tcl_GetHashKey(&iPtr->limit.callbacks, hashPtr); |
---|
| 3884 | Tcl_LimitRemoveHandler(keyPtr->interp, keyPtr->type, |
---|
| 3885 | CallScriptLimitCallback, Tcl_GetHashValue(hashPtr)); |
---|
| 3886 | hashPtr = Tcl_NextHashEntry(&search); |
---|
| 3887 | } |
---|
| 3888 | Tcl_DeleteHashTable(&iPtr->limit.callbacks); |
---|
| 3889 | } |
---|
| 3890 | |
---|
| 3891 | /* |
---|
| 3892 | *---------------------------------------------------------------------- |
---|
| 3893 | * |
---|
| 3894 | * TclInitLimitSupport -- |
---|
| 3895 | * |
---|
| 3896 | * Initialise all the parts of the interpreter relating to resource limit |
---|
| 3897 | * management. This allows an interpreter to both have limits set upon |
---|
| 3898 | * itself and set limits upon other interpreters. |
---|
| 3899 | * |
---|
| 3900 | * Results: |
---|
| 3901 | * None. |
---|
| 3902 | * |
---|
| 3903 | * Side effects: |
---|
| 3904 | * The resource limit subsystem is initialised for the interpreter. |
---|
| 3905 | * |
---|
| 3906 | *---------------------------------------------------------------------- |
---|
| 3907 | */ |
---|
| 3908 | |
---|
| 3909 | void |
---|
| 3910 | TclInitLimitSupport( |
---|
| 3911 | Tcl_Interp *interp) |
---|
| 3912 | { |
---|
| 3913 | Interp *iPtr = (Interp *) interp; |
---|
| 3914 | |
---|
| 3915 | iPtr->limit.active = 0; |
---|
| 3916 | iPtr->limit.granularityTicker = 0; |
---|
| 3917 | iPtr->limit.exceeded = 0; |
---|
| 3918 | iPtr->limit.cmdCount = 0; |
---|
| 3919 | iPtr->limit.cmdHandlers = NULL; |
---|
| 3920 | iPtr->limit.cmdGranularity = 1; |
---|
| 3921 | memset(&iPtr->limit.time, 0, sizeof(Tcl_Time)); |
---|
| 3922 | iPtr->limit.timeHandlers = NULL; |
---|
| 3923 | iPtr->limit.timeEvent = NULL; |
---|
| 3924 | iPtr->limit.timeGranularity = 10; |
---|
| 3925 | Tcl_InitHashTable(&iPtr->limit.callbacks, |
---|
| 3926 | sizeof(ScriptLimitCallbackKey)/sizeof(int)); |
---|
| 3927 | } |
---|
| 3928 | |
---|
| 3929 | /* |
---|
| 3930 | *---------------------------------------------------------------------- |
---|
| 3931 | * |
---|
| 3932 | * InheritLimitsFromMaster -- |
---|
| 3933 | * |
---|
| 3934 | * Derive the interpreter limit configuration for a slave interpreter |
---|
| 3935 | * from the limit config for the master. |
---|
| 3936 | * |
---|
| 3937 | * Results: |
---|
| 3938 | * None. |
---|
| 3939 | * |
---|
| 3940 | * Side effects: |
---|
| 3941 | * The slave interpreter limits are set so that if the master has a |
---|
| 3942 | * limit, it may not exceed it by handing off work to slave interpreters. |
---|
| 3943 | * Note that this does not transfer limit callbacks from the master to |
---|
| 3944 | * the slave. |
---|
| 3945 | * |
---|
| 3946 | *---------------------------------------------------------------------- |
---|
| 3947 | */ |
---|
| 3948 | |
---|
| 3949 | static void |
---|
| 3950 | InheritLimitsFromMaster( |
---|
| 3951 | Tcl_Interp *slaveInterp, |
---|
| 3952 | Tcl_Interp *masterInterp) |
---|
| 3953 | { |
---|
| 3954 | Interp *slavePtr = (Interp *) slaveInterp; |
---|
| 3955 | Interp *masterPtr = (Interp *) masterInterp; |
---|
| 3956 | |
---|
| 3957 | if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) { |
---|
| 3958 | slavePtr->limit.active |= TCL_LIMIT_COMMANDS; |
---|
| 3959 | slavePtr->limit.cmdCount = 0; |
---|
| 3960 | slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity; |
---|
| 3961 | } |
---|
| 3962 | if (masterPtr->limit.active & TCL_LIMIT_TIME) { |
---|
| 3963 | slavePtr->limit.active |= TCL_LIMIT_TIME; |
---|
| 3964 | memcpy(&slavePtr->limit.time, &masterPtr->limit.time, |
---|
| 3965 | sizeof(Tcl_Time)); |
---|
| 3966 | slavePtr->limit.timeGranularity = masterPtr->limit.timeGranularity; |
---|
| 3967 | } |
---|
| 3968 | } |
---|
| 3969 | |
---|
| 3970 | /* |
---|
| 3971 | *---------------------------------------------------------------------- |
---|
| 3972 | * |
---|
| 3973 | * SlaveCommandLimitCmd -- |
---|
| 3974 | * |
---|
| 3975 | * Implementation of the [interp limit $i commands] and [$i limit |
---|
| 3976 | * commands] subcommands. See the interp manual page for a full |
---|
| 3977 | * description. |
---|
| 3978 | * |
---|
| 3979 | * Results: |
---|
| 3980 | * A standard Tcl result. |
---|
| 3981 | * |
---|
| 3982 | * Side effects: |
---|
| 3983 | * Depends on the arguments. |
---|
| 3984 | * |
---|
| 3985 | *---------------------------------------------------------------------- |
---|
| 3986 | */ |
---|
| 3987 | |
---|
| 3988 | static int |
---|
| 3989 | SlaveCommandLimitCmd( |
---|
| 3990 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 3991 | Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ |
---|
| 3992 | int consumedObjc, /* Number of args already parsed. */ |
---|
| 3993 | int objc, /* Total number of arguments. */ |
---|
| 3994 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 3995 | { |
---|
| 3996 | static const char *options[] = { |
---|
| 3997 | "-command", "-granularity", "-value", NULL |
---|
| 3998 | }; |
---|
| 3999 | enum Options { |
---|
| 4000 | OPT_CMD, OPT_GRAN, OPT_VAL |
---|
| 4001 | }; |
---|
| 4002 | Interp *iPtr = (Interp *) interp; |
---|
| 4003 | int index; |
---|
| 4004 | ScriptLimitCallbackKey key; |
---|
| 4005 | ScriptLimitCallback *limitCBPtr; |
---|
| 4006 | Tcl_HashEntry *hPtr; |
---|
| 4007 | |
---|
| 4008 | if (objc == consumedObjc) { |
---|
| 4009 | Tcl_Obj *dictPtr; |
---|
| 4010 | |
---|
| 4011 | TclNewObj(dictPtr); |
---|
| 4012 | key.interp = slaveInterp; |
---|
| 4013 | key.type = TCL_LIMIT_COMMANDS; |
---|
| 4014 | hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); |
---|
| 4015 | if (hPtr != NULL) { |
---|
| 4016 | limitCBPtr = Tcl_GetHashValue(hPtr); |
---|
| 4017 | if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { |
---|
| 4018 | Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), |
---|
| 4019 | limitCBPtr->scriptObj); |
---|
| 4020 | } else { |
---|
| 4021 | goto putEmptyCommandInDict; |
---|
| 4022 | } |
---|
| 4023 | } else { |
---|
| 4024 | Tcl_Obj *empty; |
---|
| 4025 | |
---|
| 4026 | putEmptyCommandInDict: |
---|
| 4027 | TclNewObj(empty); |
---|
| 4028 | Tcl_DictObjPut(NULL, dictPtr, |
---|
| 4029 | Tcl_NewStringObj(options[0], -1), empty); |
---|
| 4030 | } |
---|
| 4031 | Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), |
---|
| 4032 | Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, |
---|
| 4033 | TCL_LIMIT_COMMANDS))); |
---|
| 4034 | |
---|
| 4035 | if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { |
---|
| 4036 | Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), |
---|
| 4037 | Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); |
---|
| 4038 | } else { |
---|
| 4039 | Tcl_Obj *empty; |
---|
| 4040 | |
---|
| 4041 | TclNewObj(empty); |
---|
| 4042 | Tcl_DictObjPut(NULL, dictPtr, |
---|
| 4043 | Tcl_NewStringObj(options[2], -1), empty); |
---|
| 4044 | } |
---|
| 4045 | Tcl_SetObjResult(interp, dictPtr); |
---|
| 4046 | return TCL_OK; |
---|
| 4047 | } else if (objc == consumedObjc+1) { |
---|
| 4048 | if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option", |
---|
| 4049 | 0, &index) != TCL_OK) { |
---|
| 4050 | return TCL_ERROR; |
---|
| 4051 | } |
---|
| 4052 | switch ((enum Options) index) { |
---|
| 4053 | case OPT_CMD: |
---|
| 4054 | key.interp = slaveInterp; |
---|
| 4055 | key.type = TCL_LIMIT_COMMANDS; |
---|
| 4056 | hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); |
---|
| 4057 | if (hPtr != NULL) { |
---|
| 4058 | limitCBPtr = Tcl_GetHashValue(hPtr); |
---|
| 4059 | if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { |
---|
| 4060 | Tcl_SetObjResult(interp, limitCBPtr->scriptObj); |
---|
| 4061 | } |
---|
| 4062 | } |
---|
| 4063 | break; |
---|
| 4064 | case OPT_GRAN: |
---|
| 4065 | Tcl_SetObjResult(interp, Tcl_NewIntObj( |
---|
| 4066 | Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); |
---|
| 4067 | break; |
---|
| 4068 | case OPT_VAL: |
---|
| 4069 | if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { |
---|
| 4070 | Tcl_SetObjResult(interp, |
---|
| 4071 | Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); |
---|
| 4072 | } |
---|
| 4073 | break; |
---|
| 4074 | } |
---|
| 4075 | return TCL_OK; |
---|
| 4076 | } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { |
---|
| 4077 | Tcl_WrongNumArgs(interp, consumedObjc, objv, |
---|
| 4078 | "?-option? ?value? ?-option value ...?"); |
---|
| 4079 | return TCL_ERROR; |
---|
| 4080 | } else { |
---|
| 4081 | int i, scriptLen = 0, limitLen = 0; |
---|
| 4082 | Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL; |
---|
| 4083 | int gran = 0, limit = 0; |
---|
| 4084 | |
---|
| 4085 | for (i=consumedObjc ; i<objc ; i+=2) { |
---|
| 4086 | if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, |
---|
| 4087 | &index) != TCL_OK) { |
---|
| 4088 | return TCL_ERROR; |
---|
| 4089 | } |
---|
| 4090 | switch ((enum Options) index) { |
---|
| 4091 | case OPT_CMD: |
---|
| 4092 | scriptObj = objv[i+1]; |
---|
| 4093 | (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); |
---|
| 4094 | break; |
---|
| 4095 | case OPT_GRAN: |
---|
| 4096 | granObj = objv[i+1]; |
---|
| 4097 | if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { |
---|
| 4098 | return TCL_ERROR; |
---|
| 4099 | } |
---|
| 4100 | if (gran < 1) { |
---|
| 4101 | Tcl_AppendResult(interp, "granularity must be at " |
---|
| 4102 | "least 1", NULL); |
---|
| 4103 | return TCL_ERROR; |
---|
| 4104 | } |
---|
| 4105 | break; |
---|
| 4106 | case OPT_VAL: |
---|
| 4107 | limitObj = objv[i+1]; |
---|
| 4108 | (void) Tcl_GetStringFromObj(objv[i+1], &limitLen); |
---|
| 4109 | if (limitLen == 0) { |
---|
| 4110 | break; |
---|
| 4111 | } |
---|
| 4112 | if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) { |
---|
| 4113 | return TCL_ERROR; |
---|
| 4114 | } |
---|
| 4115 | if (limit < 0) { |
---|
| 4116 | Tcl_AppendResult(interp, "command limit value must be at " |
---|
| 4117 | "least 0", NULL); |
---|
| 4118 | return TCL_ERROR; |
---|
| 4119 | } |
---|
| 4120 | break; |
---|
| 4121 | } |
---|
| 4122 | } |
---|
| 4123 | if (scriptObj != NULL) { |
---|
| 4124 | SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, slaveInterp, |
---|
| 4125 | (scriptLen > 0 ? scriptObj : NULL)); |
---|
| 4126 | } |
---|
| 4127 | if (granObj != NULL) { |
---|
| 4128 | Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran); |
---|
| 4129 | } |
---|
| 4130 | if (limitObj != NULL) { |
---|
| 4131 | if (limitLen > 0) { |
---|
| 4132 | Tcl_LimitSetCommands(slaveInterp, limit); |
---|
| 4133 | Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS); |
---|
| 4134 | } else { |
---|
| 4135 | Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS); |
---|
| 4136 | } |
---|
| 4137 | } |
---|
| 4138 | return TCL_OK; |
---|
| 4139 | } |
---|
| 4140 | } |
---|
| 4141 | |
---|
| 4142 | /* |
---|
| 4143 | *---------------------------------------------------------------------- |
---|
| 4144 | * |
---|
| 4145 | * SlaveTimeLimitCmd -- |
---|
| 4146 | * |
---|
| 4147 | * Implementation of the [interp limit $i time] and [$i limit time] |
---|
| 4148 | * subcommands. See the interp manual page for a full description. |
---|
| 4149 | * |
---|
| 4150 | * Results: |
---|
| 4151 | * A standard Tcl result. |
---|
| 4152 | * |
---|
| 4153 | * Side effects: |
---|
| 4154 | * Depends on the arguments. |
---|
| 4155 | * |
---|
| 4156 | *---------------------------------------------------------------------- |
---|
| 4157 | */ |
---|
| 4158 | |
---|
| 4159 | static int |
---|
| 4160 | SlaveTimeLimitCmd( |
---|
| 4161 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 4162 | Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */ |
---|
| 4163 | int consumedObjc, /* Number of args already parsed. */ |
---|
| 4164 | int objc, /* Total number of arguments. */ |
---|
| 4165 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 4166 | { |
---|
| 4167 | static const char *options[] = { |
---|
| 4168 | "-command", "-granularity", "-milliseconds", "-seconds", NULL |
---|
| 4169 | }; |
---|
| 4170 | enum Options { |
---|
| 4171 | OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC |
---|
| 4172 | }; |
---|
| 4173 | Interp *iPtr = (Interp *) interp; |
---|
| 4174 | int index; |
---|
| 4175 | ScriptLimitCallbackKey key; |
---|
| 4176 | ScriptLimitCallback *limitCBPtr; |
---|
| 4177 | Tcl_HashEntry *hPtr; |
---|
| 4178 | |
---|
| 4179 | if (objc == consumedObjc) { |
---|
| 4180 | Tcl_Obj *dictPtr; |
---|
| 4181 | |
---|
| 4182 | TclNewObj(dictPtr); |
---|
| 4183 | key.interp = slaveInterp; |
---|
| 4184 | key.type = TCL_LIMIT_TIME; |
---|
| 4185 | hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); |
---|
| 4186 | if (hPtr != NULL) { |
---|
| 4187 | limitCBPtr = Tcl_GetHashValue(hPtr); |
---|
| 4188 | if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { |
---|
| 4189 | Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), |
---|
| 4190 | limitCBPtr->scriptObj); |
---|
| 4191 | } else { |
---|
| 4192 | goto putEmptyCommandInDict; |
---|
| 4193 | } |
---|
| 4194 | } else { |
---|
| 4195 | Tcl_Obj *empty; |
---|
| 4196 | putEmptyCommandInDict: |
---|
| 4197 | TclNewObj(empty); |
---|
| 4198 | Tcl_DictObjPut(NULL, dictPtr, |
---|
| 4199 | Tcl_NewStringObj(options[0], -1), empty); |
---|
| 4200 | } |
---|
| 4201 | Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), |
---|
| 4202 | Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, |
---|
| 4203 | TCL_LIMIT_TIME))); |
---|
| 4204 | |
---|
| 4205 | if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { |
---|
| 4206 | Tcl_Time limitMoment; |
---|
| 4207 | |
---|
| 4208 | Tcl_LimitGetTime(slaveInterp, &limitMoment); |
---|
| 4209 | Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), |
---|
| 4210 | Tcl_NewLongObj(limitMoment.usec/1000)); |
---|
| 4211 | Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1), |
---|
| 4212 | Tcl_NewLongObj(limitMoment.sec)); |
---|
| 4213 | } else { |
---|
| 4214 | Tcl_Obj *empty; |
---|
| 4215 | |
---|
| 4216 | TclNewObj(empty); |
---|
| 4217 | Tcl_DictObjPut(NULL, dictPtr, |
---|
| 4218 | Tcl_NewStringObj(options[2], -1), empty); |
---|
| 4219 | Tcl_DictObjPut(NULL, dictPtr, |
---|
| 4220 | Tcl_NewStringObj(options[3], -1), empty); |
---|
| 4221 | } |
---|
| 4222 | Tcl_SetObjResult(interp, dictPtr); |
---|
| 4223 | return TCL_OK; |
---|
| 4224 | } else if (objc == consumedObjc+1) { |
---|
| 4225 | if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option", |
---|
| 4226 | 0, &index) != TCL_OK) { |
---|
| 4227 | return TCL_ERROR; |
---|
| 4228 | } |
---|
| 4229 | switch ((enum Options) index) { |
---|
| 4230 | case OPT_CMD: |
---|
| 4231 | key.interp = slaveInterp; |
---|
| 4232 | key.type = TCL_LIMIT_TIME; |
---|
| 4233 | hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); |
---|
| 4234 | if (hPtr != NULL) { |
---|
| 4235 | limitCBPtr = Tcl_GetHashValue(hPtr); |
---|
| 4236 | if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { |
---|
| 4237 | Tcl_SetObjResult(interp, limitCBPtr->scriptObj); |
---|
| 4238 | } |
---|
| 4239 | } |
---|
| 4240 | break; |
---|
| 4241 | case OPT_GRAN: |
---|
| 4242 | Tcl_SetObjResult(interp, Tcl_NewIntObj( |
---|
| 4243 | Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME))); |
---|
| 4244 | break; |
---|
| 4245 | case OPT_MILLI: |
---|
| 4246 | if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { |
---|
| 4247 | Tcl_Time limitMoment; |
---|
| 4248 | |
---|
| 4249 | Tcl_LimitGetTime(slaveInterp, &limitMoment); |
---|
| 4250 | Tcl_SetObjResult(interp, |
---|
| 4251 | Tcl_NewLongObj(limitMoment.usec/1000)); |
---|
| 4252 | } |
---|
| 4253 | break; |
---|
| 4254 | case OPT_SEC: |
---|
| 4255 | if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { |
---|
| 4256 | Tcl_Time limitMoment; |
---|
| 4257 | |
---|
| 4258 | Tcl_LimitGetTime(slaveInterp, &limitMoment); |
---|
| 4259 | Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec)); |
---|
| 4260 | } |
---|
| 4261 | break; |
---|
| 4262 | } |
---|
| 4263 | return TCL_OK; |
---|
| 4264 | } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { |
---|
| 4265 | Tcl_WrongNumArgs(interp, consumedObjc, objv, |
---|
| 4266 | "?-option? ?value? ?-option value ...?"); |
---|
| 4267 | return TCL_ERROR; |
---|
| 4268 | } else { |
---|
| 4269 | int i, scriptLen = 0, milliLen = 0, secLen = 0; |
---|
| 4270 | Tcl_Obj *scriptObj = NULL, *granObj = NULL; |
---|
| 4271 | Tcl_Obj *milliObj = NULL, *secObj = NULL; |
---|
| 4272 | int gran = 0; |
---|
| 4273 | Tcl_Time limitMoment; |
---|
| 4274 | int tmp; |
---|
| 4275 | |
---|
| 4276 | Tcl_LimitGetTime(slaveInterp, &limitMoment); |
---|
| 4277 | for (i=consumedObjc ; i<objc ; i+=2) { |
---|
| 4278 | if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, |
---|
| 4279 | &index) != TCL_OK) { |
---|
| 4280 | return TCL_ERROR; |
---|
| 4281 | } |
---|
| 4282 | switch ((enum Options) index) { |
---|
| 4283 | case OPT_CMD: |
---|
| 4284 | scriptObj = objv[i+1]; |
---|
| 4285 | (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); |
---|
| 4286 | break; |
---|
| 4287 | case OPT_GRAN: |
---|
| 4288 | granObj = objv[i+1]; |
---|
| 4289 | if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { |
---|
| 4290 | return TCL_ERROR; |
---|
| 4291 | } |
---|
| 4292 | if (gran < 1) { |
---|
| 4293 | Tcl_AppendResult(interp, "granularity must be at " |
---|
| 4294 | "least 1", NULL); |
---|
| 4295 | return TCL_ERROR; |
---|
| 4296 | } |
---|
| 4297 | break; |
---|
| 4298 | case OPT_MILLI: |
---|
| 4299 | milliObj = objv[i+1]; |
---|
| 4300 | (void) Tcl_GetStringFromObj(objv[i+1], &milliLen); |
---|
| 4301 | if (milliLen == 0) { |
---|
| 4302 | break; |
---|
| 4303 | } |
---|
| 4304 | if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { |
---|
| 4305 | return TCL_ERROR; |
---|
| 4306 | } |
---|
| 4307 | if (tmp < 0) { |
---|
| 4308 | Tcl_AppendResult(interp, "milliseconds must be at least 0", |
---|
| 4309 | NULL); |
---|
| 4310 | return TCL_ERROR; |
---|
| 4311 | } |
---|
| 4312 | limitMoment.usec = ((long)tmp)*1000; |
---|
| 4313 | break; |
---|
| 4314 | case OPT_SEC: |
---|
| 4315 | secObj = objv[i+1]; |
---|
| 4316 | (void) Tcl_GetStringFromObj(objv[i+1], &secLen); |
---|
| 4317 | if (secLen == 0) { |
---|
| 4318 | break; |
---|
| 4319 | } |
---|
| 4320 | if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { |
---|
| 4321 | return TCL_ERROR; |
---|
| 4322 | } |
---|
| 4323 | if (tmp < 0) { |
---|
| 4324 | Tcl_AppendResult(interp, "seconds must be at least 0", |
---|
| 4325 | NULL); |
---|
| 4326 | return TCL_ERROR; |
---|
| 4327 | } |
---|
| 4328 | limitMoment.sec = tmp; |
---|
| 4329 | break; |
---|
| 4330 | } |
---|
| 4331 | } |
---|
| 4332 | if (milliObj != NULL || secObj != NULL) { |
---|
| 4333 | if (milliObj != NULL) { |
---|
| 4334 | /* |
---|
| 4335 | * Setting -milliseconds but clearing -seconds, or resetting |
---|
| 4336 | * -milliseconds but not resetting -seconds? Bad voodoo! |
---|
| 4337 | */ |
---|
| 4338 | |
---|
| 4339 | if (secObj != NULL && secLen == 0 && milliLen > 0) { |
---|
| 4340 | Tcl_AppendResult(interp, "may only set -milliseconds " |
---|
| 4341 | "if -seconds is not also being reset", NULL); |
---|
| 4342 | return TCL_ERROR; |
---|
| 4343 | } |
---|
| 4344 | if (milliLen == 0 && (secObj == NULL || secLen > 0)) { |
---|
| 4345 | Tcl_AppendResult(interp, "may only reset -milliseconds " |
---|
| 4346 | "if -seconds is also being reset", NULL); |
---|
| 4347 | return TCL_ERROR; |
---|
| 4348 | } |
---|
| 4349 | } |
---|
| 4350 | |
---|
| 4351 | if (milliLen > 0 || secLen > 0) { |
---|
| 4352 | /* |
---|
| 4353 | * Force usec to be in range [0..1000000), possibly |
---|
| 4354 | * incrementing sec in the process. This makes it much easier |
---|
| 4355 | * for people to write scripts that do small time increments. |
---|
| 4356 | */ |
---|
| 4357 | |
---|
| 4358 | limitMoment.sec += limitMoment.usec / 1000000; |
---|
| 4359 | limitMoment.usec %= 1000000; |
---|
| 4360 | |
---|
| 4361 | Tcl_LimitSetTime(slaveInterp, &limitMoment); |
---|
| 4362 | Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME); |
---|
| 4363 | } else { |
---|
| 4364 | Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME); |
---|
| 4365 | } |
---|
| 4366 | } |
---|
| 4367 | if (scriptObj != NULL) { |
---|
| 4368 | SetScriptLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp, |
---|
| 4369 | (scriptLen > 0 ? scriptObj : NULL)); |
---|
| 4370 | } |
---|
| 4371 | if (granObj != NULL) { |
---|
| 4372 | Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran); |
---|
| 4373 | } |
---|
| 4374 | return TCL_OK; |
---|
| 4375 | } |
---|
| 4376 | } |
---|
| 4377 | |
---|
| 4378 | /* |
---|
| 4379 | * Local Variables: |
---|
| 4380 | * mode: c |
---|
| 4381 | * c-basic-offset: 4 |
---|
| 4382 | * fill-column: 78 |
---|
| 4383 | * End: |
---|
| 4384 | */ |
---|