summaryrefslogtreecommitdiffstats
path: root/tcl8.6/generic/tclInterp.c
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2016-12-21 22:13:18 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2016-12-21 22:13:18 (GMT)
commit07e464099b99459d0a37757771791598ef3395d9 (patch)
tree4ba7d8aad13735e52f59bdce7ca5ba3151ebd7e3 /tcl8.6/generic/tclInterp.c
parentdeb3650e37f26f651f280e480c4df3d7dde87bae (diff)
downloadblt-07e464099b99459d0a37757771791598ef3395d9.zip
blt-07e464099b99459d0a37757771791598ef3395d9.tar.gz
blt-07e464099b99459d0a37757771791598ef3395d9.tar.bz2
new subtree for tcl/tk
Diffstat (limited to 'tcl8.6/generic/tclInterp.c')
-rw-r--r--tcl8.6/generic/tclInterp.c4825
1 files changed, 0 insertions, 4825 deletions
diff --git a/tcl8.6/generic/tclInterp.c b/tcl8.6/generic/tclInterp.c
deleted file mode 100644
index 66ce1e0..0000000
--- a/tcl8.6/generic/tclInterp.c
+++ /dev/null
@@ -1,4825 +0,0 @@
-/*
- * tclInterp.c --
- *
- * This file implements the "interp" command which allows creation and
- * manipulation of Tcl interpreters from within Tcl scripts.
- *
- * Copyright (c) 1995-1997 Sun Microsystems, Inc.
- * Copyright (c) 2004 Donal K. Fellows
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tclInt.h"
-
-/*
- * A pointer to a string that holds an initialization script that if non-NULL
- * is evaluated in Tcl_Init() prior to the built-in initialization script
- * above. This variable can be modified by the function below.
- */
-
-static const char *tclPreInitScript = NULL;
-
-/* Forward declaration */
-struct Target;
-
-/*
- * struct Alias:
- *
- * Stores information about an alias. Is stored in the slave interpreter and
- * used by the source command to find the target command in the master when
- * the source command is invoked.
- */
-
-typedef struct Alias {
- Tcl_Obj *token; /* Token for the alias command in the slave
- * interp. This used to be the command name in
- * the slave when the alias was first
- * created. */
- Tcl_Interp *targetInterp; /* Interp in which target command will be
- * invoked. */
- Tcl_Command slaveCmd; /* Source command in slave interpreter, bound
- * to command that invokes the target command
- * in the target interpreter. */
- Tcl_HashEntry *aliasEntryPtr;
- /* Entry for the alias hash table in slave.
- * This is used by alias deletion to remove
- * the alias from the slave interpreter alias
- * table. */
- struct Target *targetPtr; /* Entry for target command in master. This is
- * used in the master interpreter to map back
- * from the target command to aliases
- * redirecting to it. */
- int objc; /* Count of Tcl_Obj in the prefix of the
- * target command to be invoked in the target
- * interpreter. Additional arguments specified
- * when calling the alias in the slave interp
- * will be appended to the prefix before the
- * command is invoked. */
- Tcl_Obj *objPtr; /* The first actual prefix object - the target
- * command name; this has to be at the end of
- * the structure, which will be extended to
- * accomodate the remaining objects in the
- * prefix. */
-} Alias;
-
-/*
- *
- * struct Slave:
- *
- * Used by the "interp" command to record and find information about slave
- * interpreters. Maps from a command name in the master to information about a
- * slave interpreter, e.g. what aliases are defined in it.
- */
-
-typedef struct Slave {
- Tcl_Interp *masterInterp; /* Master interpreter for this slave. */
- Tcl_HashEntry *slaveEntryPtr;
- /* Hash entry in masters slave table for this
- * slave interpreter. Used to find this
- * record, and used when deleting the slave
- * interpreter to delete it from the master's
- * table. */
- Tcl_Interp *slaveInterp; /* The slave interpreter. */
- Tcl_Command interpCmd; /* Interpreter object command. */
- Tcl_HashTable aliasTable; /* Table which maps from names of commands in
- * slave interpreter to struct Alias defined
- * below. */
-} Slave;
-
-/*
- * struct Target:
- *
- * Maps from master interpreter commands back to the source commands in slave
- * interpreters. This is needed because aliases can be created between sibling
- * interpreters and must be deleted when the target interpreter is deleted. In
- * case they would not be deleted the source interpreter would be left with a
- * "dangling pointer". One such record is stored in the Master record of the
- * master interpreter with the master for each alias which directs to a
- * command in the master. These records are used to remove the source command
- * for an from a slave if/when the master is deleted. They are organized in a
- * doubly-linked list attached to the master interpreter.
- */
-
-typedef struct Target {
- Tcl_Command slaveCmd; /* Command for alias in slave interp. */
- Tcl_Interp *slaveInterp; /* Slave Interpreter. */
- struct Target *nextPtr; /* Next in list of target records, or NULL if
- * at the end of the list of targets. */
- struct Target *prevPtr; /* Previous in list of target records, or NULL
- * if at the start of the list of targets. */
-} Target;
-
-/*
- * struct Master:
- *
- * This record is used for two purposes: First, slaveTable (a hashtable) maps
- * from names of commands to slave interpreters. This hashtable is used to
- * store information about slave interpreters of this interpreter, to map over
- * all slaves, etc. The second purpose is to store information about all
- * aliases in slaves (or siblings) which direct to target commands in this
- * interpreter (using the targetsPtr doubly-linked list).
- *
- * NB: the flags field in the interp structure, used with SAFE_INTERP mask
- * denotes whether the interpreter is safe or not. Safe interpreters have
- * restricted functionality, can only create safe slave interpreters and can
- * only load safe extensions.
- */
-
-typedef struct Master {
- Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps
- * from command names to Slave records. */
- Target *targetsPtr; /* The head of a doubly-linked list of all the
- * target records which denote aliases from
- * slaves or sibling interpreters that direct
- * to commands in this interpreter. This list
- * is used to remove dangling pointers from
- * the slave (or sibling) interpreters when
- * this interpreter is deleted. */
-} Master;
-
-/*
- * The following structure keeps track of all the Master and Slave information
- * on a per-interp basis.
- */
-
-typedef struct InterpInfo {
- Master master; /* Keeps track of all interps for which this
- * interp is the Master. */
- Slave slave; /* Information necessary for this interp to
- * function as a slave. */
-} InterpInfo;
-
-/*
- * Limit callbacks handled by scripts are modelled as structures which are
- * stored in hashes indexed by a two-word key. Note that the type of the
- * 'type' field in the key is not int; this is to make sure that things are
- * likely to work properly on 64-bit architectures.
- */
-
-typedef struct ScriptLimitCallback {
- Tcl_Interp *interp; /* The interpreter in which to execute the
- * callback. */
- Tcl_Obj *scriptObj; /* The script to execute to perform the
- * user-defined part of the callback. */
- int type; /* What kind of callback is this. */
- Tcl_HashEntry *entryPtr; /* The entry in the hash table maintained by
- * the target interpreter that refers to this
- * callback record, or NULL if the entry has
- * already been deleted from that hash
- * table. */
-} ScriptLimitCallback;
-
-typedef struct ScriptLimitCallbackKey {
- Tcl_Interp *interp; /* The interpreter that the limit callback was
- * attached to. This is not the interpreter
- * that the callback runs in! */
- long type; /* The type of callback that this is. */
-} ScriptLimitCallbackKey;
-
-/*
- * TIP#143 limit handler internal representation.
- */
-
-struct LimitHandler {
- int flags; /* The state of this particular handler. */
- Tcl_LimitHandlerProc *handlerProc;
- /* The handler callback. */
- ClientData clientData; /* Opaque argument to the handler callback. */
- Tcl_LimitHandlerDeleteProc *deleteProc;
- /* How to delete the clientData. */
- LimitHandler *prevPtr; /* Previous item in linked list of
- * handlers. */
- LimitHandler *nextPtr; /* Next item in linked list of handlers. */
-};
-
-/*
- * Values for the LimitHandler flags field.
- * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being
- * processed; handlers are never to be entered reentrantly.
- * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This
- * should not normally be observed because when a handler is
- * deleted it is also spliced out of the list of handlers, but
- * even so we will be careful.
- */
-
-#define LIMIT_HANDLER_ACTIVE 0x01
-#define LIMIT_HANDLER_DELETED 0x02
-
-
-
-/*
- * Prototypes for local static functions:
- */
-
-static int AliasCreate(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp,
- Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc,
- Tcl_Obj *const objv[]);
-static int AliasDelete(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, Tcl_Obj *namePtr);
-static int AliasDescribe(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, Tcl_Obj *objPtr);
-static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp);
-static int AliasObjCmd(ClientData dummy,
- Tcl_Interp *currentInterp, int objc,
- Tcl_Obj *const objv[]);
-static int AliasNRCmd(ClientData dummy,
- Tcl_Interp *currentInterp, int objc,
- Tcl_Obj *const objv[]);
-static void AliasObjCmdDeleteProc(ClientData clientData);
-static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr);
-static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static void InterpInfoDeleteProc(ClientData clientData,
- Tcl_Interp *interp);
-static int SlaveBgerror(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, int objc,
- Tcl_Obj *const objv[]);
-static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr,
- int safe);
-static int SlaveDebugCmd(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp,
- int objc, Tcl_Obj *const objv[]);
-static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp,
- int objc, Tcl_Obj *const objv[]);
-static int SlaveExpose(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, int objc,
- Tcl_Obj *const objv[]);
-static int SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp,
- int objc, Tcl_Obj *const objv[]);
-static int SlaveHidden(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp);
-static int SlaveInvokeHidden(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp,
- const char *namespaceName,
- int objc, Tcl_Obj *const objv[]);
-static int SlaveMarkTrusted(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp);
-static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
-static void SlaveObjCmdDeleteProc(ClientData clientData);
-static int SlaveRecursionLimit(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, int objc,
- Tcl_Obj *const objv[]);
-static int SlaveCommandLimitCmd(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, int consumedObjc,
- int objc, Tcl_Obj *const objv[]);
-static int SlaveTimeLimitCmd(Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, int consumedObjc,
- int objc, Tcl_Obj *const objv[]);
-static void InheritLimitsFromMaster(Tcl_Interp *slaveInterp,
- Tcl_Interp *masterInterp);
-static void SetScriptLimitCallback(Tcl_Interp *interp, int type,
- Tcl_Interp *targetInterp, Tcl_Obj *scriptObj);
-static void CallScriptLimitCallback(ClientData clientData,
- Tcl_Interp *interp);
-static void DeleteScriptLimitCallback(ClientData clientData);
-static void RunLimitHandlers(LimitHandler *handlerPtr,
- Tcl_Interp *interp);
-static void TimeLimitCallback(ClientData clientData);
-
-/* NRE enabling */
-static Tcl_NRPostProc NRPostInvokeHidden;
-static Tcl_ObjCmdProc NRInterpCmd;
-static Tcl_ObjCmdProc NRSlaveCmd;
-
-
-/*
- *----------------------------------------------------------------------
- *
- * TclSetPreInitScript --
- *
- * This routine is used to change the value of the internal variable,
- * tclPreInitScript.
- *
- * Results:
- * Returns the current value of tclPreInitScript.
- *
- * Side effects:
- * Changes the way Tcl_Init() routine behaves.
- *
- *----------------------------------------------------------------------
- */
-
-const char *
-TclSetPreInitScript(
- const char *string) /* Pointer to a script. */
-{
- const char *prevString = tclPreInitScript;
- tclPreInitScript = string;
- return(prevString);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Init --
- *
- * This function is typically invoked by Tcl_AppInit functions to find
- * and source the "init.tcl" script, which should exist somewhere on the
- * Tcl library path.
- *
- * Results:
- * Returns a standard Tcl completion code and sets the interp's result if
- * there is an error.
- *
- * Side effects:
- * Depends on what's in the init.tcl script.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_Init(
- Tcl_Interp *interp) /* Interpreter to initialize. */
-{
- if (tclPreInitScript != NULL) {
- if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
- return TCL_ERROR;
- }
- }
-
- /*
- * In order to find init.tcl during initialization, the following script
- * is invoked by Tcl_Init(). It looks in several different directories:
- *
- * $tcl_library - can specify a primary location, if set, no
- * other locations will be checked. This is the
- * recommended way for a program that embeds
- * Tcl to specifically tell Tcl where to find
- * an init.tcl file.
- *
- * $env(TCL_LIBRARY) - highest priority so user can always override
- * the search path unless the application has
- * specified an exact directory above
- *
- * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl on
- * those platforms where it can determine at
- * runtime the directory where it expects the
- * init.tcl file to be. After [tclInit] reads
- * and uses this value, it [unset]s it.
- * External users of Tcl should not make use of
- * the variable to customize [tclInit].
- *
- * $tcl_libPath - OBSOLETE: This variable is no longer set by
- * Tcl itself, but [tclInit] examines it in
- * case some program that embeds Tcl is
- * customizing [tclInit] by setting this
- * variable to a list of directories in which
- * to search.
- *
- * [tcl::pkgconfig get scriptdir,runtime]
- * - the directory determined by configure to be
- * the place where Tcl's script library is to
- * be installed.
- *
- * The first directory on this path that contains a valid init.tcl script
- * will be set as the value of tcl_library.
- *
- * Note that this entire search mechanism can be bypassed by defining an
- * alternate tclInit command before calling Tcl_Init().
- */
-
- return Tcl_Eval(interp,
-"if {[namespace which -command tclInit] eq \"\"} {\n"
-" proc tclInit {} {\n"
-" global tcl_libPath tcl_library env tclDefaultLibrary\n"
-" rename tclInit {}\n"
-" if {[info exists tcl_library]} {\n"
-" set scripts {{set tcl_library}}\n"
-" } else {\n"
-" set scripts {}\n"
-" if {[info exists env(TCL_LIBRARY)] && ($env(TCL_LIBRARY) ne {})} {\n"
-" lappend scripts {set env(TCL_LIBRARY)}\n"
-" lappend scripts {\n"
-"if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail] == 0} continue\n"
-"if {$tail eq [info tclversion]} continue\n"
-"file join [file dirname $env(TCL_LIBRARY)] tcl[info tclversion]}\n"
-" }\n"
-" if {[info exists tclDefaultLibrary]} {\n"
-" lappend scripts {set tclDefaultLibrary}\n"
-" } else {\n"
-" lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n"
-" }\n"
-" lappend scripts {\n"
-"set parentDir [file dirname [file dirname [info nameofexecutable]]]\n"
-"set grandParentDir [file dirname $parentDir]\n"
-"file join $parentDir lib tcl[info tclversion]} \\\n"
-" {file join $grandParentDir lib tcl[info tclversion]} \\\n"
-" {file join $parentDir library} \\\n"
-" {file join $grandParentDir library} \\\n"
-" {file join $grandParentDir tcl[info patchlevel] library} \\\n"
-" {\n"
-"file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n"
-" if {[info exists tcl_libPath]\n"
-" && [catch {llength $tcl_libPath} len] == 0} {\n"
-" for {set i 0} {$i < $len} {incr i} {\n"
-" lappend scripts [list lindex \\$tcl_libPath $i]\n"
-" }\n"
-" }\n"
-" }\n"
-" set dirs {}\n"
-" set errors {}\n"
-" foreach script $scripts {\n"
-" lappend dirs [eval $script]\n"
-" set tcl_library [lindex $dirs end]\n"
-" set tclfile [file join $tcl_library init.tcl]\n"
-" if {[file exists $tclfile]} {\n"
-" if {[catch {uplevel #0 [list source $tclfile]} msg opts]} {\n"
-" append errors \"$tclfile: $msg\n\"\n"
-" append errors \"[dict get $opts -errorinfo]\n\"\n"
-" continue\n"
-" }\n"
-" unset -nocomplain tclDefaultLibrary\n"
-" return\n"
-" }\n"
-" }\n"
-" unset -nocomplain tclDefaultLibrary\n"
-" set msg \"Can't find a usable init.tcl in the following directories: \n\"\n"
-" append msg \" $dirs\n\n\"\n"
-" append msg \"$errors\n\n\"\n"
-" append msg \"This probably means that Tcl wasn't installed properly.\n\"\n"
-" error $msg\n"
-" }\n"
-"}\n"
-"tclInit");
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclInterpInit --
- *
- * Initializes the invoking interpreter for using the master, slave and
- * safe interp facilities. This is called from inside Tcl_CreateInterp().
- *
- * Results:
- * Always returns TCL_OK for backwards compatibility.
- *
- * Side effects:
- * Adds the "interp" command to an interpreter and initializes the
- * interpInfoPtr field of the invoking interpreter.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-TclInterpInit(
- Tcl_Interp *interp) /* Interpreter to initialize. */
-{
- InterpInfo *interpInfoPtr;
- Master *masterPtr;
- Slave *slavePtr;
-
- interpInfoPtr = ckalloc(sizeof(InterpInfo));
- ((Interp *) interp)->interpInfo = interpInfoPtr;
-
- masterPtr = &interpInfoPtr->master;
- Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
- masterPtr->targetsPtr = NULL;
-
- slavePtr = &interpInfoPtr->slave;
- slavePtr->masterInterp = NULL;
- slavePtr->slaveEntryPtr = NULL;
- slavePtr->slaveInterp = interp;
- slavePtr->interpCmd = NULL;
- Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
-
- Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd,
- NULL, NULL);
-
- Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
- return TCL_OK;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * InterpInfoDeleteProc --
- *
- * Invoked when an interpreter is being deleted. It releases all storage
- * used by the master/slave/safe interpreter facilities.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Cleans up storage. Sets the interpInfoPtr field of the interp to NULL.
- *
- *---------------------------------------------------------------------------
- */
-
-static void
-InterpInfoDeleteProc(
- ClientData clientData, /* Ignored. */
- Tcl_Interp *interp) /* Interp being deleted. All commands for
- * slave interps should already be deleted. */
-{
- InterpInfo *interpInfoPtr;
- Slave *slavePtr;
- Master *masterPtr;
- Target *targetPtr;
-
- interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
-
- /*
- * There shouldn't be any commands left.
- */
-
- masterPtr = &interpInfoPtr->master;
- if (masterPtr->slaveTable.numEntries != 0) {
- Tcl_Panic("InterpInfoDeleteProc: still exist commands");
- }
- Tcl_DeleteHashTable(&masterPtr->slaveTable);
-
- /*
- * Tell any interps that have aliases to this interp that they should
- * delete those aliases. If the other interp was already dead, it would
- * have removed the target record already.
- */
-
- for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) {
- Target *tmpPtr = targetPtr->nextPtr;
- Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
- targetPtr->slaveCmd);
- targetPtr = tmpPtr;
- }
-
- slavePtr = &interpInfoPtr->slave;
- if (slavePtr->interpCmd != NULL) {
- /*
- * Tcl_DeleteInterp() was called on this interpreter, rather "interp
- * delete" or the equivalent deletion of the command in the master.
- * First ensure that the cleanup callback doesn't try to delete the
- * interp again.
- */
-
- slavePtr->slaveInterp = NULL;
- Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
- slavePtr->interpCmd);
- }
-
- /*
- * There shouldn't be any aliases left.
- */
-
- if (slavePtr->aliasTable.numEntries != 0) {
- Tcl_Panic("InterpInfoDeleteProc: still exist aliases");
- }
- Tcl_DeleteHashTable(&slavePtr->aliasTable);
-
- ckfree(interpInfoPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_InterpObjCmd --
- *
- * This function is invoked to process the "interp" Tcl command. See the
- * user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
- /* ARGSUSED */
-int
-Tcl_InterpObjCmd(
- ClientData clientData, /* Unused. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
-}
-
-static int
-NRInterpCmd(
- ClientData clientData, /* Unused. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- Tcl_Interp *slaveInterp;
- int index;
- static const char *const options[] = {
- "alias", "aliases", "bgerror", "cancel",
- "create", "debug", "delete",
- "eval", "exists", "expose",
- "hide", "hidden", "issafe",
- "invokehidden", "limit", "marktrusted", "recursionlimit",
- "slaves", "share", "target", "transfer",
- NULL
- };
- enum option {
- OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL,
- OPT_CREATE, OPT_DEBUG, OPT_DELETE,
- OPT_EVAL, OPT_EXISTS, OPT_EXPOSE,
- OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE,
- OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT,
- OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER
- };
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
- &index) != TCL_OK) {
- return TCL_ERROR;
- }
- switch ((enum option) index) {
- case OPT_ALIAS: {
- Tcl_Interp *masterInterp;
-
- if (objc < 4) {
- aliasArgs:
- Tcl_WrongNumArgs(interp, 2, objv,
- "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- if (objc == 4) {
- return AliasDescribe(interp, slaveInterp, objv[3]);
- }
- if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) {
- return AliasDelete(interp, slaveInterp, objv[3]);
- }
- if (objc > 5) {
- masterInterp = GetInterp(interp, objv[4]);
- if (masterInterp == NULL) {
- return TCL_ERROR;
- }
- if (TclGetString(objv[5])[0] == '\0') {
- if (objc == 6) {
- return AliasDelete(interp, slaveInterp, objv[3]);
- }
- } else {
- return AliasCreate(interp, slaveInterp, masterInterp, objv[3],
- objv[5], objc - 6, objv + 6);
- }
- }
- goto aliasArgs;
- }
- case OPT_ALIASES:
- slaveInterp = GetInterp2(interp, objc, objv);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- return AliasList(interp, slaveInterp);
- case OPT_BGERROR:
- if (objc != 3 && objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
- case OPT_CANCEL: {
- int i, flags;
- Tcl_Obj *resultObjPtr;
- static const char *const cancelOptions[] = {
- "-unwind", "--", NULL
- };
- enum option {
- OPT_UNWIND, OPT_LAST
- };
-
- flags = 0;
-
- for (i = 2; i < objc; i++) {
- if (TclGetString(objv[i])[0] != '-') {
- break;
- }
- if (Tcl_GetIndexFromObj(interp, objv[i], cancelOptions, "option",
- 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
-
- switch ((enum option) index) {
- case OPT_UNWIND:
- /*
- * The evaluation stack in the target interp is to be unwound.
- */
-
- flags |= TCL_CANCEL_UNWIND;
- break;
- case OPT_LAST:
- i++;
- goto endOfForLoop;
- }
- }
-
- endOfForLoop:
- if (i < objc - 2) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "?-unwind? ?--? ?path? ?result?");
- return TCL_ERROR;
- }
-
- /*
- * Did they specify a slave interp to cancel the script in progress
- * in? If not, use the current interp.
- */
-
- if (i < objc) {
- slaveInterp = GetInterp(interp, objv[i]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- i++;
- } else {
- slaveInterp = interp;
- }
-
- if (i < objc) {
- resultObjPtr = objv[i];
-
- /*
- * Tcl_CancelEval removes this reference.
- */
-
- Tcl_IncrRefCount(resultObjPtr);
- i++;
- } else {
- resultObjPtr = NULL;
- }
-
- return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags);
- }
- case OPT_CREATE: {
- int i, last, safe;
- Tcl_Obj *slavePtr;
- char buf[16 + TCL_INTEGER_SPACE];
- static const char *const createOptions[] = {
- "-safe", "--", NULL
- };
- enum option {
- OPT_SAFE, OPT_LAST
- };
-
- safe = Tcl_IsSafe(interp);
-
- /*
- * Weird historical rules: "-safe" is accepted at the end, too.
- */
-
- slavePtr = NULL;
- last = 0;
- for (i = 2; i < objc; i++) {
- if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
- if (Tcl_GetIndexFromObj(interp, objv[i], createOptions,
- "option", 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- if (index == OPT_SAFE) {
- safe = 1;
- continue;
- }
- i++;
- last = 1;
- }
- if (slavePtr != NULL) {
- Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
- return TCL_ERROR;
- }
- if (i < objc) {
- slavePtr = objv[i];
- }
- }
- buf[0] = '\0';
- if (slavePtr == NULL) {
- /*
- * Create an anonymous interpreter -- we choose its name and the
- * name of the command. We check that the command name that we use
- * for the interpreter does not collide with an existing command
- * in the master interpreter.
- */
-
- for (i = 0; ; i++) {
- Tcl_CmdInfo cmdInfo;
-
- sprintf(buf, "interp%d", i);
- if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
- break;
- }
- }
- slavePtr = Tcl_NewStringObj(buf, -1);
- }
- if (SlaveCreate(interp, slavePtr, safe) == NULL) {
- if (buf[0] != '\0') {
- Tcl_DecrRefCount(slavePtr);
- }
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, slavePtr);
- return TCL_OK;
- }
- case OPT_DEBUG: /* TIP #378 */
- /*
- * Currently only -frame supported, otherwise ?-option ?value??
- */
-
- if (objc < 3 || objc > 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3);
- case OPT_DELETE: {
- int i;
- InterpInfo *iiPtr;
-
- for (i = 2; i < objc; i++) {
- slaveInterp = GetInterp(interp, objv[i]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- } else if (slaveInterp == interp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "cannot delete the current interpreter", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "DELETESELF", NULL);
- return TCL_ERROR;
- }
- iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
- Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
- iiPtr->slave.interpCmd);
- }
- return TCL_OK;
- }
- case OPT_EVAL:
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
- case OPT_EXISTS: {
- int exists = 1;
-
- slaveInterp = GetInterp2(interp, objc, objv);
- if (slaveInterp == NULL) {
- if (objc > 3) {
- return TCL_ERROR;
- }
- Tcl_ResetResult(interp);
- exists = 0;
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
- return TCL_OK;
- }
- case OPT_EXPOSE:
- if ((objc < 4) || (objc > 5)) {
- Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
- case OPT_HIDE:
- if ((objc < 4) || (objc > 5)) {
- Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
- case OPT_HIDDEN:
- slaveInterp = GetInterp2(interp, objc, objv);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- return SlaveHidden(interp, slaveInterp);
- case OPT_ISSAFE:
- slaveInterp = GetInterp2(interp, objc, objv);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
- return TCL_OK;
- case OPT_INVOKEHID: {
- int i;
- const char *namespaceName;
- static const char *const hiddenOptions[] = {
- "-global", "-namespace", "--", NULL
- };
- enum hiddenOption {
- OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST
- };
-
- namespaceName = NULL;
- for (i = 3; i < objc; i++) {
- if (TclGetString(objv[i])[0] != '-') {
- break;
- }
- if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option",
- 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- if (index == OPT_GLOBAL) {
- namespaceName = "::";
- } else if (index == OPT_NAMESPACE) {
- if (++i == objc) { /* There must be more arguments. */
- break;
- } else {
- namespaceName = TclGetString(objv[i]);
- }
- } else {
- i++;
- break;
- }
- }
- if (objc - i < 1) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i,
- objv + i);
- }
- case OPT_LIMIT: {
- static const char *const limitTypes[] = {
- "commands", "time", NULL
- };
- enum LimitTypes {
- LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME
- };
- int limitType;
-
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "path limitType ?-option value ...?");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0,
- &limitType) != TCL_OK) {
- return TCL_ERROR;
- }
- switch ((enum LimitTypes) limitType) {
- case LIMIT_TYPE_COMMANDS:
- return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv);
- case LIMIT_TYPE_TIME:
- return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv);
- }
- }
- case OPT_MARKTRUSTED:
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "path");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- return SlaveMarkTrusted(interp, slaveInterp);
- case OPT_RECLIMIT:
- if (objc != 3 && objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
- case OPT_SLAVES: {
- InterpInfo *iiPtr;
- Tcl_Obj *resultPtr;
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch hashSearch;
- char *string;
-
- slaveInterp = GetInterp2(interp, objc, objv);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
- resultPtr = Tcl_NewObj();
- hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
- for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
- string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
- Tcl_ListObjAppendElement(NULL, resultPtr,
- Tcl_NewStringObj(string, -1));
- }
- Tcl_SetObjResult(interp, resultPtr);
- return TCL_OK;
- }
- case OPT_TRANSFER:
- case OPT_SHARE: {
- Tcl_Interp *masterInterp; /* The master of the slave. */
- Tcl_Channel chan;
-
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
- return TCL_ERROR;
- }
- masterInterp = GetInterp(interp, objv[2]);
- if (masterInterp == NULL) {
- return TCL_ERROR;
- }
- chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL);
- if (chan == NULL) {
- Tcl_TransferResult(masterInterp, TCL_OK, interp);
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, objv[4]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
- Tcl_RegisterChannel(slaveInterp, chan);
- if (index == OPT_TRANSFER) {
- /*
- * When transferring, as opposed to sharing, we must unhitch the
- * channel from the interpreter where it started.
- */
-
- if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
- Tcl_TransferResult(masterInterp, TCL_OK, interp);
- return TCL_ERROR;
- }
- }
- return TCL_OK;
- }
- case OPT_TARGET: {
- InterpInfo *iiPtr;
- Tcl_HashEntry *hPtr;
- Alias *aliasPtr;
- const char *aliasName;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "path alias");
- return TCL_ERROR;
- }
-
- slaveInterp = GetInterp(interp, objv[2]);
- if (slaveInterp == NULL) {
- return TCL_ERROR;
- }
-
- aliasName = TclGetString(objv[3]);
-
- iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
- hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
- if (hPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "alias \"%s\" in path \"%s\" not found",
- aliasName, Tcl_GetString(objv[2])));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
- NULL);
- return TCL_ERROR;
- }
- aliasPtr = Tcl_GetHashValue(hPtr);
- if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "target interpreter for alias \"%s\" in path \"%s\" is "
- "not my descendant", aliasName, Tcl_GetString(objv[2])));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "TARGETSHROUDED", NULL);
- return TCL_ERROR;
- }
- return TCL_OK;
- }
- }
- return TCL_OK;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * GetInterp2 --
- *
- * Helper function for Tcl_InterpObjCmd() to convert the interp name
- * potentially specified on the command line to an Tcl_Interp.
- *
- * Results:
- * The return value is the interp specified on the command line, or the
- * interp argument itself if no interp was specified on the command line.
- * If the interp could not be found or the wrong number of arguments was
- * specified on the command line, the return value is NULL and an error
- * message is left in the interp's result.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-static Tcl_Interp *
-GetInterp2(
- Tcl_Interp *interp, /* Default interp if no interp was specified
- * on the command line. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- if (objc == 2) {
- return interp;
- } else if (objc == 3) {
- return GetInterp(interp, objv[2]);
- } else {
- Tcl_WrongNumArgs(interp, 2, objv, "?path?");
- return NULL;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateAlias --
- *
- * Creates an alias between two interpreters.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Creates a new alias, manipulates the result field of slaveInterp.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_CreateAlias(
- Tcl_Interp *slaveInterp, /* Interpreter for source command. */
- const char *slaveCmd, /* Command to install in slave. */
- Tcl_Interp *targetInterp, /* Interpreter for target command. */
- const char *targetCmd, /* Name of target command. */
- int argc, /* How many additional arguments? */
- const char *const *argv) /* These are the additional args. */
-{
- Tcl_Obj *slaveObjPtr, *targetObjPtr;
- Tcl_Obj **objv;
- int i;
- int result;
-
- objv = TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc);
- for (i = 0; i < argc; i++) {
- objv[i] = Tcl_NewStringObj(argv[i], -1);
- Tcl_IncrRefCount(objv[i]);
- }
-
- slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
- Tcl_IncrRefCount(slaveObjPtr);
-
- targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
- Tcl_IncrRefCount(targetObjPtr);
-
- result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
- targetObjPtr, argc, objv);
-
- for (i = 0; i < argc; i++) {
- Tcl_DecrRefCount(objv[i]);
- }
- TclStackFree(slaveInterp, objv);
- Tcl_DecrRefCount(targetObjPtr);
- Tcl_DecrRefCount(slaveObjPtr);
-
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateAliasObj --
- *
- * Object version: Creates an alias between two interpreters.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Creates a new alias.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_CreateAliasObj(
- Tcl_Interp *slaveInterp, /* Interpreter for source command. */
- const char *slaveCmd, /* Command to install in slave. */
- Tcl_Interp *targetInterp, /* Interpreter for target command. */
- const char *targetCmd, /* Name of target command. */
- int objc, /* How many additional arguments? */
- Tcl_Obj *const objv[]) /* Argument vector. */
-{
- Tcl_Obj *slaveObjPtr, *targetObjPtr;
- int result;
-
- slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
- Tcl_IncrRefCount(slaveObjPtr);
-
- targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
- Tcl_IncrRefCount(targetObjPtr);
-
- result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
- targetObjPtr, objc, objv);
-
- Tcl_DecrRefCount(slaveObjPtr);
- Tcl_DecrRefCount(targetObjPtr);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetAlias --
- *
- * Gets information about an alias.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetAlias(
- Tcl_Interp *interp, /* Interp to start search from. */
- const char *aliasName, /* Name of alias to find. */
- Tcl_Interp **targetInterpPtr,
- /* (Return) target interpreter. */
- const char **targetNamePtr, /* (Return) name of target command. */
- int *argcPtr, /* (Return) count of addnl args. */
- const char ***argvPtr) /* (Return) additional arguments. */
-{
- InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
- Tcl_HashEntry *hPtr;
- Alias *aliasPtr;
- int i, objc;
- Tcl_Obj **objv;
-
- hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
- if (hPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "alias \"%s\" not found", aliasName));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
- return TCL_ERROR;
- }
- aliasPtr = Tcl_GetHashValue(hPtr);
- objc = aliasPtr->objc;
- objv = &aliasPtr->objPtr;
-
- if (targetInterpPtr != NULL) {
- *targetInterpPtr = aliasPtr->targetInterp;
- }
- if (targetNamePtr != NULL) {
- *targetNamePtr = TclGetString(objv[0]);
- }
- if (argcPtr != NULL) {
- *argcPtr = objc - 1;
- }
- if (argvPtr != NULL) {
- *argvPtr = (const char **)
- ckalloc(sizeof(const char *) * (objc - 1));
- for (i = 1; i < objc; i++) {
- (*argvPtr)[i - 1] = TclGetString(objv[i]);
- }
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetAliasObj --
- *
- * Object version: Gets information about an alias.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetAliasObj(
- Tcl_Interp *interp, /* Interp to start search from. */
- const char *aliasName, /* Name of alias to find. */
- Tcl_Interp **targetInterpPtr,
- /* (Return) target interpreter. */
- const char **targetNamePtr, /* (Return) name of target command. */
- int *objcPtr, /* (Return) count of addnl args. */
- Tcl_Obj ***objvPtr) /* (Return) additional args. */
-{
- InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
- Tcl_HashEntry *hPtr;
- Alias *aliasPtr;
- int objc;
- Tcl_Obj **objv;
-
- hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
- if (hPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "alias \"%s\" not found", aliasName));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
- return TCL_ERROR;
- }
- aliasPtr = Tcl_GetHashValue(hPtr);
- objc = aliasPtr->objc;
- objv = &aliasPtr->objPtr;
-
- if (targetInterpPtr != NULL) {
- *targetInterpPtr = aliasPtr->targetInterp;
- }
- if (targetNamePtr != NULL) {
- *targetNamePtr = TclGetString(objv[0]);
- }
- if (objcPtr != NULL) {
- *objcPtr = objc - 1;
- }
- if (objvPtr != NULL) {
- *objvPtr = objv + 1;
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclPreventAliasLoop --
- *
- * When defining an alias or renaming a command, prevent an alias loop
- * from being formed.
- *
- * Results:
- * A standard Tcl object result.
- *
- * Side effects:
- * If TCL_ERROR is returned, the function also stores an error message in
- * the interpreter's result object.
- *
- * NOTE:
- * This function is public internal (instead of being static to this
- * file) because it is also used from TclRenameCommand.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclPreventAliasLoop(
- Tcl_Interp *interp, /* Interp in which to report errors. */
- Tcl_Interp *cmdInterp, /* Interp in which the command is being
- * defined. */
- Tcl_Command cmd) /* Tcl command we are attempting to define. */
-{
- Command *cmdPtr = (Command *) cmd;
- Alias *aliasPtr, *nextAliasPtr;
- Tcl_Command aliasCmd;
- Command *aliasCmdPtr;
-
- /*
- * If we are not creating or renaming an alias, then it is always OK to
- * create or rename the command.
- */
-
- if (cmdPtr->objProc != AliasObjCmd) {
- return TCL_OK;
- }
-
- /*
- * OK, we are dealing with an alias, so traverse the chain of aliases. If
- * we encounter the alias we are defining (or renaming to) any in the
- * chain then we have a loop.
- */
-
- aliasPtr = cmdPtr->objClientData;
- nextAliasPtr = aliasPtr;
- while (1) {
- Tcl_Obj *cmdNamePtr;
-
- /*
- * If the target of the next alias in the chain is the same as the
- * source alias, we have a loop.
- */
-
- if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) {
- /*
- * The slave interpreter can be deleted while creating the alias.
- * [Bug #641195]
- */
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "cannot define or rename alias \"%s\": interpreter deleted",
- Tcl_GetCommandName(cmdInterp, cmd)));
- return TCL_ERROR;
- }
- cmdNamePtr = nextAliasPtr->objPtr;
- aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
- TclGetString(cmdNamePtr),
- Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
- /*flags*/ 0);
- if (aliasCmd == NULL) {
- return TCL_OK;
- }
- aliasCmdPtr = (Command *) aliasCmd;
- if (aliasCmdPtr == cmdPtr) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "cannot define or rename alias \"%s\": would create a loop",
- Tcl_GetCommandName(cmdInterp, cmd)));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "ALIASLOOP", NULL);
- return TCL_ERROR;
- }
-
- /*
- * Otherwise, follow the chain one step further. See if the target
- * command is an alias - if so, follow the loop to its target command.
- * Otherwise we do not have a loop.
- */
-
- if (aliasCmdPtr->objProc != AliasObjCmd) {
- return TCL_OK;
- }
- nextAliasPtr = aliasCmdPtr->objClientData;
- }
-
- /* NOTREACHED */
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AliasCreate --
- *
- * Helper function to do the work to actually create an alias.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * An alias command is created and entered into the alias table for the
- * slave interpreter.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-AliasCreate(
- Tcl_Interp *interp, /* Interp for error reporting. */
- Tcl_Interp *slaveInterp, /* Interp where alias cmd will live or from
- * which alias will be deleted. */
- Tcl_Interp *masterInterp, /* Interp in which target command will be
- * invoked. */
- Tcl_Obj *namePtr, /* Name of alias cmd. */
- Tcl_Obj *targetNamePtr, /* Name of target cmd. */
- int objc, /* Additional arguments to store */
- Tcl_Obj *const objv[]) /* with alias. */
-{
- Alias *aliasPtr;
- Tcl_HashEntry *hPtr;
- Target *targetPtr;
- Slave *slavePtr;
- Master *masterPtr;
- Tcl_Obj **prefv;
- int isNew, i;
-
- aliasPtr = ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *));
- aliasPtr->token = namePtr;
- Tcl_IncrRefCount(aliasPtr->token);
- aliasPtr->targetInterp = masterInterp;
-
- aliasPtr->objc = objc + 1;
- prefv = &aliasPtr->objPtr;
-
- *prefv = targetNamePtr;
- Tcl_IncrRefCount(targetNamePtr);
- for (i = 0; i < objc; i++) {
- *(++prefv) = objv[i];
- Tcl_IncrRefCount(objv[i]);
- }
-
- Tcl_Preserve(slaveInterp);
- Tcl_Preserve(masterInterp);
-
- if (slaveInterp == masterInterp) {
- aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp,
- TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr,
- AliasObjCmdDeleteProc);
- } else {
- aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
- TclGetString(namePtr), AliasObjCmd, aliasPtr,
- AliasObjCmdDeleteProc);
- }
-
- if (TclPreventAliasLoop(interp, slaveInterp,
- aliasPtr->slaveCmd) != TCL_OK) {
- /*
- * Found an alias loop! The last call to Tcl_CreateObjCommand made the
- * alias point to itself. Delete the command and its alias record. Be
- * careful to wipe out its client data first, so the command doesn't
- * try to delete itself.
- */
-
- Command *cmdPtr;
-
- Tcl_DecrRefCount(aliasPtr->token);
- Tcl_DecrRefCount(targetNamePtr);
- for (i = 0; i < objc; i++) {
- Tcl_DecrRefCount(objv[i]);
- }
-
- cmdPtr = (Command *) aliasPtr->slaveCmd;
- cmdPtr->clientData = NULL;
- cmdPtr->deleteProc = NULL;
- cmdPtr->deleteData = NULL;
- Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
-
- ckfree(aliasPtr);
-
- /*
- * The result was already set by TclPreventAliasLoop.
- */
-
- Tcl_Release(slaveInterp);
- Tcl_Release(masterInterp);
- return TCL_ERROR;
- }
-
- /*
- * Make an entry in the alias table. If it already exists, retry.
- */
-
- slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
- while (1) {
- Tcl_Obj *newToken;
- const char *string;
-
- string = TclGetString(aliasPtr->token);
- hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew);
- if (isNew != 0) {
- break;
- }
-
- /*
- * The alias name cannot be used as unique token, it is already taken.
- * We can produce a unique token by prepending "::" repeatedly. This
- * algorithm is a stop-gap to try to maintain the command name as
- * token for most use cases, fearful of possible backwards compat
- * problems. A better algorithm would produce unique tokens that need
- * not be related to the command name.
- *
- * ATTENTION: the tests in interp.test and possibly safe.test depend
- * on the precise definition of these tokens.
- */
-
- TclNewLiteralStringObj(newToken, "::");
- Tcl_AppendObjToObj(newToken, aliasPtr->token);
- Tcl_DecrRefCount(aliasPtr->token);
- aliasPtr->token = newToken;
- Tcl_IncrRefCount(aliasPtr->token);
- }
-
- aliasPtr->aliasEntryPtr = hPtr;
- Tcl_SetHashValue(hPtr, aliasPtr);
-
- /*
- * Create the new command. We must do it after deleting any old command,
- * because the alias may be pointing at a renamed alias, as in:
- *
- * interp alias {} foo {} bar # Create an alias "foo"
- * rename foo zop # Now rename the alias
- * interp alias {} foo {} zop # Now recreate "foo"...
- */
-
- targetPtr = ckalloc(sizeof(Target));
- targetPtr->slaveCmd = aliasPtr->slaveCmd;
- targetPtr->slaveInterp = slaveInterp;
-
- masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master;
- targetPtr->nextPtr = masterPtr->targetsPtr;
- targetPtr->prevPtr = NULL;
- if (masterPtr->targetsPtr != NULL) {
- masterPtr->targetsPtr->prevPtr = targetPtr;
- }
- masterPtr->targetsPtr = targetPtr;
- aliasPtr->targetPtr = targetPtr;
-
- Tcl_SetObjResult(interp, aliasPtr->token);
-
- Tcl_Release(slaveInterp);
- Tcl_Release(masterInterp);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AliasDelete --
- *
- * Deletes the given alias from the slave interpreter given.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Deletes the alias from the slave interpreter.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-AliasDelete(
- Tcl_Interp *interp, /* Interpreter for result & errors. */
- Tcl_Interp *slaveInterp, /* Interpreter containing alias. */
- Tcl_Obj *namePtr) /* Name of alias to delete. */
-{
- Slave *slavePtr;
- Alias *aliasPtr;
- Tcl_HashEntry *hPtr;
-
- /*
- * If the alias has been renamed in the slave, the master can still use
- * the original name (with which it was created) to find the alias to
- * delete it.
- */
-
- slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
- hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr));
- if (hPtr == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "alias \"%s\" not found", TclGetString(namePtr)));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS",
- TclGetString(namePtr), NULL);
- return TCL_ERROR;
- }
- aliasPtr = Tcl_GetHashValue(hPtr);
- Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AliasDescribe --
- *
- * Sets the interpreter's result object to a Tcl list describing the
- * given alias in the given interpreter: its target command and the
- * additional arguments to prepend to any invocation of the alias.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-AliasDescribe(
- Tcl_Interp *interp, /* Interpreter for result & errors. */
- Tcl_Interp *slaveInterp, /* Interpreter containing alias. */
- Tcl_Obj *namePtr) /* Name of alias to describe. */
-{
- Slave *slavePtr;
- Tcl_HashEntry *hPtr;
- Alias *aliasPtr;
- Tcl_Obj *prefixPtr;
-
- /*
- * If the alias has been renamed in the slave, the master can still use
- * the original name (with which it was created) to find the alias to
- * describe it.
- */
-
- slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
- hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
- if (hPtr == NULL) {
- return TCL_OK;
- }
- aliasPtr = Tcl_GetHashValue(hPtr);
- prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
- Tcl_SetObjResult(interp, prefixPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AliasList --
- *
- * Computes a list of aliases defined in a slave interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-AliasList(
- Tcl_Interp *interp, /* Interp for data return. */
- Tcl_Interp *slaveInterp) /* Interp whose aliases to compute. */
-{
- Tcl_HashEntry *entryPtr;
- Tcl_HashSearch hashSearch;
- Tcl_Obj *resultPtr = Tcl_NewObj();
- Alias *aliasPtr;
- Slave *slavePtr;
-
- slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
-
- entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
- for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
- aliasPtr = Tcl_GetHashValue(entryPtr);
- Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token);
- }
- Tcl_SetObjResult(interp, resultPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AliasObjCmd --
- *
- * This is the function that services invocations of aliases in a slave
- * interpreter. One such command exists for each alias. When invoked,
- * this function redirects the invocation to the target command in the
- * master interpreter as designated by the Alias record associated with
- * this command.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Causes forwarding of the invocation; all possible side effects may
- * occur as a result of invoking the command to which the invocation is
- * forwarded.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-AliasNRCmd(
- ClientData clientData, /* Alias record. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument vector. */
-{
- Alias *aliasPtr = clientData;
- int prefc, cmdc, i;
- Tcl_Obj **prefv, **cmdv;
- Tcl_Obj *listPtr;
- List *listRep;
- int flags = TCL_EVAL_INVOKE;
-
- /*
- * Append the arguments to the command prefix and invoke the command in
- * the target interp's global namespace.
- */
-
- prefc = aliasPtr->objc;
- prefv = &aliasPtr->objPtr;
- cmdc = prefc + objc - 1;
-
- listPtr = Tcl_NewListObj(cmdc, NULL);
- listRep = listPtr->internalRep.twoPtrValue.ptr1;
- listRep->elemCount = cmdc;
- cmdv = &listRep->elements;
-
- prefv = &aliasPtr->objPtr;
- memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *)));
- memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
-
- for (i=0; i<cmdc; i++) {
- Tcl_IncrRefCount(cmdv[i]);
- }
-
- /*
- * Use the ensemble rewriting machinery to ensure correct error messages:
- * only the source command should show, not the full target prefix.
- */
-
- if (TclInitRewriteEnsemble(interp, 1, prefc, objv)) {
- TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
- }
- TclSkipTailcall(interp);
- return Tcl_NREvalObj(interp, listPtr, flags);
-}
-
-static int
-AliasObjCmd(
- ClientData clientData, /* Alias record. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument vector. */
-{
-#define ALIAS_CMDV_PREALLOC 10
- Alias *aliasPtr = clientData;
- Tcl_Interp *targetInterp = aliasPtr->targetInterp;
- int result, prefc, cmdc, i;
- Tcl_Obj **prefv, **cmdv;
- Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
- Interp *tPtr = (Interp *) targetInterp;
- int isRootEnsemble;
-
- /*
- * Append the arguments to the command prefix and invoke the command in
- * the target interp's global namespace.
- */
-
- prefc = aliasPtr->objc;
- prefv = &aliasPtr->objPtr;
- cmdc = prefc + objc - 1;
- if (cmdc <= ALIAS_CMDV_PREALLOC) {
- cmdv = cmdArr;
- } else {
- cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
- }
-
- memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *)));
- memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
-
- Tcl_ResetResult(targetInterp);
-
- for (i=0; i<cmdc; i++) {
- Tcl_IncrRefCount(cmdv[i]);
- }
-
- /*
- * Use the ensemble rewriting machinery to ensure correct error messages:
- * only the source command should show, not the full target prefix.
- */
-
- isRootEnsemble = TclInitRewriteEnsemble((Tcl_Interp *)tPtr, 1, prefc, objv);
-
- /*
- * Protect the target interpreter if it isn't the same as the source
- * interpreter so that we can continue to work with it after the target
- * command completes.
- */
-
- if (targetInterp != interp) {
- Tcl_Preserve(targetInterp);
- }
-
- /*
- * Execute the target command in the target interpreter.
- */
-
- result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
-
- /*
- * Clean up the ensemble rewrite info if we set it in the first place.
- */
-
- if (isRootEnsemble) {
- TclResetRewriteEnsemble((Tcl_Interp *)tPtr, 1);
- }
-
- /*
- * If it was a cross-interpreter alias, we need to transfer the result
- * back to the source interpreter and release the lock we previously set
- * on the target interpreter.
- */
-
- if (targetInterp != interp) {
- Tcl_TransferResult(targetInterp, result, interp);
- Tcl_Release(targetInterp);
- }
-
- for (i=0; i<cmdc; i++) {
- Tcl_DecrRefCount(cmdv[i]);
- }
- if (cmdv != cmdArr) {
- TclStackFree(interp, cmdv);
- }
- return result;
-#undef ALIAS_CMDV_PREALLOC
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AliasObjCmdDeleteProc --
- *
- * Is invoked when an alias command is deleted in a slave. Cleans up all
- * storage associated with this alias.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Deletes the alias record and its entry in the alias table for the
- * interpreter.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-AliasObjCmdDeleteProc(
- ClientData clientData) /* The alias record for this alias. */
-{
- Alias *aliasPtr = clientData;
- Target *targetPtr;
- int i;
- Tcl_Obj **objv;
-
- Tcl_DecrRefCount(aliasPtr->token);
- objv = &aliasPtr->objPtr;
- for (i = 0; i < aliasPtr->objc; i++) {
- Tcl_DecrRefCount(objv[i]);
- }
- Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
-
- /*
- * Splice the target record out of the target interpreter's master list.
- */
-
- targetPtr = aliasPtr->targetPtr;
- if (targetPtr->prevPtr != NULL) {
- targetPtr->prevPtr->nextPtr = targetPtr->nextPtr;
- } else {
- Master *masterPtr = &((InterpInfo *) ((Interp *)
- aliasPtr->targetInterp)->interpInfo)->master;
-
- masterPtr->targetsPtr = targetPtr->nextPtr;
- }
- if (targetPtr->nextPtr != NULL) {
- targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
- }
-
- ckfree(targetPtr);
- ckfree(aliasPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateSlave --
- *
- * Creates a slave interpreter. The slavePath argument denotes the name
- * of the new slave relative to the current interpreter; the slave is a
- * direct descendant of the one-before-last component of the path,
- * e.g. it is a descendant of the current interpreter if the slavePath
- * argument contains only one component. Optionally makes the slave
- * interpreter safe.
- *
- * Results:
- * Returns the interpreter structure created, or NULL if an error
- * occurred.
- *
- * Side effects:
- * Creates a new interpreter and a new interpreter object command in the
- * interpreter indicated by the slavePath argument.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Interp *
-Tcl_CreateSlave(
- Tcl_Interp *interp, /* Interpreter to start search at. */
- const char *slavePath, /* Name of slave to create. */
- int isSafe) /* Should new slave be "safe" ? */
-{
- Tcl_Obj *pathPtr;
- Tcl_Interp *slaveInterp;
-
- pathPtr = Tcl_NewStringObj(slavePath, -1);
- slaveInterp = SlaveCreate(interp, pathPtr, isSafe);
- Tcl_DecrRefCount(pathPtr);
-
- return slaveInterp;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetSlave --
- *
- * Finds a slave interpreter by its path name.
- *
- * Results:
- * Returns a Tcl_Interp * for the named interpreter or NULL if not found.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Interp *
-Tcl_GetSlave(
- Tcl_Interp *interp, /* Interpreter to start search from. */
- const char *slavePath) /* Path of slave to find. */
-{
- Tcl_Obj *pathPtr;
- Tcl_Interp *slaveInterp;
-
- pathPtr = Tcl_NewStringObj(slavePath, -1);
- slaveInterp = GetInterp(interp, pathPtr);
- Tcl_DecrRefCount(pathPtr);
-
- return slaveInterp;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetMaster --
- *
- * Finds the master interpreter of a slave interpreter.
- *
- * Results:
- * Returns a Tcl_Interp * for the master interpreter or NULL if none.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Interp *
-Tcl_GetMaster(
- Tcl_Interp *interp) /* Get the master of this interpreter. */
-{
- Slave *slavePtr; /* Slave record of this interpreter. */
-
- if (interp == NULL) {
- return NULL;
- }
- slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
- return slavePtr->masterInterp;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclSetSlaveCancelFlags --
- *
- * This function marks all slave interpreters belonging to a given
- * interpreter as being canceled or not canceled, depending on the
- * provided flags.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclSetSlaveCancelFlags(
- Tcl_Interp *interp, /* Set cancel flags of this interpreter. */
- int flags, /* Collection of OR-ed bits that control
- * the cancellation of the script. Only
- * TCL_CANCEL_UNWIND is currently
- * supported. */
- int force) /* Non-zero to ignore numLevels for the purpose
- * of resetting the cancellation flags. */
-{
- Master *masterPtr; /* Master record of given interpreter. */
- Tcl_HashEntry *hPtr; /* Search element. */
- Tcl_HashSearch hashSearch; /* Search variable. */
- Slave *slavePtr; /* Slave record of interpreter. */
- Interp *iPtr;
-
- if (interp == NULL) {
- return;
- }
-
- flags &= (CANCELED | TCL_CANCEL_UNWIND);
-
- masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master;
-
- hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch);
- for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
- slavePtr = Tcl_GetHashValue(hPtr);
- iPtr = (Interp *) slavePtr->slaveInterp;
-
- if (iPtr == NULL) {
- continue;
- }
-
- if (flags == 0) {
- TclResetCancellation((Tcl_Interp *) iPtr, force);
- } else {
- TclSetCancelFlags(iPtr, flags);
- }
-
- /*
- * Now, recursively handle this for the slaves of this slave
- * interpreter.
- */
-
- TclSetSlaveCancelFlags((Tcl_Interp *) iPtr, flags, force);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetInterpPath --
- *
- * Sets the result of the asking interpreter to a proper Tcl list
- * containing the names of interpreters between the asking and target
- * interpreters. The target interpreter must be either the same as the
- * asking interpreter or one of its slaves (including recursively).
- *
- * Results:
- * TCL_OK if the target interpreter is the same as, or a descendant of,
- * the asking interpreter; TCL_ERROR else. This way one can distinguish
- * between the case where the asking and target interps are the same (an
- * empty list is the result, and TCL_OK is returned) and when the target
- * is not a descendant of the asking interpreter (in which case the Tcl
- * result is an error message and the function returns TCL_ERROR).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GetInterpPath(
- Tcl_Interp *askingInterp, /* Interpreter to start search from. */
- Tcl_Interp *targetInterp) /* Interpreter to find. */
-{
- InterpInfo *iiPtr;
-
- if (targetInterp == askingInterp) {
- Tcl_SetObjResult(askingInterp, Tcl_NewObj());
- return TCL_OK;
- }
- if (targetInterp == NULL) {
- return TCL_ERROR;
- }
- iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
- if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){
- return TCL_ERROR;
- }
- Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp),
- Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable,
- iiPtr->slave.slaveEntryPtr), -1));
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * GetInterp --
- *
- * Helper function to find a slave interpreter given a pathname.
- *
- * Results:
- * Returns the slave interpreter known by that name in the calling
- * interpreter, or NULL if no interpreter known by that name exists.
- *
- * Side effects:
- * Assigns to the pointer variable passed in, if not NULL.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_Interp *
-GetInterp(
- Tcl_Interp *interp, /* Interp. to start search from. */
- Tcl_Obj *pathPtr) /* List object containing name of interp. to
- * be found. */
-{
- Tcl_HashEntry *hPtr; /* Search element. */
- Slave *slavePtr; /* Interim slave record. */
- Tcl_Obj **objv;
- int objc, i;
- Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
- InterpInfo *masterInfoPtr;
-
- if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
- return NULL;
- }
-
- searchInterp = interp;
- for (i = 0; i < objc; i++) {
- masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
- hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
- TclGetString(objv[i]));
- if (hPtr == NULL) {
- searchInterp = NULL;
- break;
- }
- slavePtr = Tcl_GetHashValue(hPtr);
- searchInterp = slavePtr->slaveInterp;
- if (searchInterp == NULL) {
- break;
- }
- }
- if (searchInterp == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "could not find interpreter \"%s\"", TclGetString(pathPtr)));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP",
- TclGetString(pathPtr), NULL);
- }
- return searchInterp;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveBgerror --
- *
- * Helper function to set/query the background error handling command
- * prefix of an interp
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * When (objc == 1), slaveInterp will be set to a new background handler
- * of objv[0].
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveBgerror(
- Tcl_Interp *interp, /* Interp for error return. */
- Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */
- int objc, /* Set or Query. */
- Tcl_Obj *const objv[]) /* Argument strings. */
-{
- if (objc) {
- int length;
-
- if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length)
- || (length < 1)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "cmdPrefix must be list of length >= 1", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BGERRORFORMAT", NULL);
- return TCL_ERROR;
- }
- TclSetBgErrorHandler(slaveInterp, objv[0]);
- }
- Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp));
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveCreate --
- *
- * Helper function to do the actual work of creating a slave interp and
- * new object command. Also optionally makes the new slave interpreter
- * "safe".
- *
- * Results:
- * Returns the new Tcl_Interp * if successful or NULL if not. If failed,
- * the result of the invoking interpreter contains an error message.
- *
- * Side effects:
- * Creates a new slave interpreter and a new object command.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_Interp *
-SlaveCreate(
- Tcl_Interp *interp, /* Interp. to start search from. */
- Tcl_Obj *pathPtr, /* Path (name) of slave to create. */
- int safe) /* Should we make it "safe"? */
-{
- Tcl_Interp *masterInterp, *slaveInterp;
- Slave *slavePtr;
- InterpInfo *masterInfoPtr;
- Tcl_HashEntry *hPtr;
- const char *path;
- int isNew, objc;
- Tcl_Obj **objv;
-
- if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
- return NULL;
- }
- if (objc < 2) {
- masterInterp = interp;
- path = TclGetString(pathPtr);
- } else {
- Tcl_Obj *objPtr;
-
- objPtr = Tcl_NewListObj(objc - 1, objv);
- masterInterp = GetInterp(interp, objPtr);
- Tcl_DecrRefCount(objPtr);
- if (masterInterp == NULL) {
- return NULL;
- }
- path = TclGetString(objv[objc - 1]);
- }
- if (safe == 0) {
- safe = Tcl_IsSafe(masterInterp);
- }
-
- masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
- hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path,
- &isNew);
- if (isNew == 0) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "interpreter named \"%s\" already exists, cannot create",
- path));
- return NULL;
- }
-
- slaveInterp = Tcl_CreateInterp();
- slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
- slavePtr->masterInterp = masterInterp;
- slavePtr->slaveEntryPtr = hPtr;
- slavePtr->slaveInterp = slaveInterp;
- slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path,
- SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
- Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
- Tcl_SetHashValue(hPtr, slavePtr);
- Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
-
- /*
- * Inherit the recursion limit.
- */
-
- ((Interp *) slaveInterp)->maxNestingDepth =
- ((Interp *) masterInterp)->maxNestingDepth;
-
- if (safe) {
- if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
- goto error;
- }
- } else {
- if (Tcl_Init(slaveInterp) == TCL_ERROR) {
- goto error;
- }
-
- /*
- * This will create the "memory" command in slave interpreters if we
- * compiled with TCL_MEM_DEBUG, otherwise it does nothing.
- */
-
- Tcl_InitMemory(slaveInterp);
- }
-
- /*
- * Inherit the TIP#143 limits.
- */
-
- InheritLimitsFromMaster(slaveInterp, masterInterp);
-
- /*
- * The [clock] command presents a safe API, but uses unsafe features in
- * its implementation. This means it has to be implemented in safe interps
- * as an alias to a version in the (trusted) master.
- */
-
- if (safe) {
- Tcl_Obj *clockObj;
- int status;
-
- TclNewLiteralStringObj(clockObj, "clock");
- Tcl_IncrRefCount(clockObj);
- status = AliasCreate(interp, slaveInterp, masterInterp, clockObj,
- clockObj, 0, NULL);
- Tcl_DecrRefCount(clockObj);
- if (status != TCL_OK) {
- goto error2;
- }
- }
-
- return slaveInterp;
-
- error:
- Tcl_TransferResult(slaveInterp, TCL_ERROR, interp);
- error2:
- Tcl_DeleteInterp(slaveInterp);
-
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveObjCmd --
- *
- * Command to manipulate an interpreter, e.g. to send commands to it to
- * be evaluated. One such command exists for each slave interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See user documentation for details.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveObjCmd(
- ClientData clientData, /* Slave interpreter. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv);
-}
-
-static int
-NRSlaveCmd(
- ClientData clientData, /* Slave interpreter. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- Tcl_Interp *slaveInterp = clientData;
- int index;
- static const char *const options[] = {
- "alias", "aliases", "bgerror", "debug",
- "eval", "expose", "hide", "hidden",
- "issafe", "invokehidden", "limit", "marktrusted",
- "recursionlimit", NULL
- };
- enum options {
- OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG,
- OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN,
- OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED,
- OPT_RECLIMIT
- };
-
- if (slaveInterp == NULL) {
- Tcl_Panic("SlaveObjCmd: interpreter has been deleted");
- }
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
- &index) != TCL_OK) {
- return TCL_ERROR;
- }
-
- switch ((enum options) index) {
- case OPT_ALIAS:
- if (objc > 2) {
- if (objc == 3) {
- return AliasDescribe(interp, slaveInterp, objv[2]);
- }
- if (TclGetString(objv[3])[0] == '\0') {
- if (objc == 4) {
- return AliasDelete(interp, slaveInterp, objv[2]);
- }
- } else {
- return AliasCreate(interp, slaveInterp, interp, objv[2],
- objv[3], objc - 4, objv + 4);
- }
- }
- Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?arg ...?");
- return TCL_ERROR;
- case OPT_ALIASES:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
- return AliasList(interp, slaveInterp);
- case OPT_BGERROR:
- if (objc != 2 && objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?");
- return TCL_ERROR;
- }
- return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2);
- case OPT_DEBUG:
- /*
- * TIP #378
- * Currently only -frame supported, otherwise ?-option ?value? ...?
- */
- if (objc > 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??");
- return TCL_ERROR;
- }
- return SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2);
- case OPT_EVAL:
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
- return TCL_ERROR;
- }
- return SlaveEval(interp, slaveInterp, objc - 2, objv + 2);
- case OPT_EXPOSE:
- if ((objc < 3) || (objc > 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
- return TCL_ERROR;
- }
- return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2);
- case OPT_HIDE:
- if ((objc < 3) || (objc > 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
- return TCL_ERROR;
- }
- return SlaveHide(interp, slaveInterp, objc - 2, objv + 2);
- case OPT_HIDDEN:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
- return SlaveHidden(interp, slaveInterp);
- case OPT_ISSAFE:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
- return TCL_OK;
- case OPT_INVOKEHIDDEN: {
- int i;
- const char *namespaceName;
- static const char *const hiddenOptions[] = {
- "-global", "-namespace", "--", NULL
- };
- enum hiddenOption {
- OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST
- };
-
- namespaceName = NULL;
- for (i = 2; i < objc; i++) {
- if (TclGetString(objv[i])[0] != '-') {
- break;
- }
- if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option",
- 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- if (index == OPT_GLOBAL) {
- namespaceName = "::";
- } else if (index == OPT_NAMESPACE) {
- if (++i == objc) { /* There must be more arguments. */
- break;
- } else {
- namespaceName = TclGetString(objv[i]);
- }
- } else {
- i++;
- break;
- }
- }
- if (objc - i < 1) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "?-namespace ns? ?-global? ?--? cmd ?arg ..?");
- return TCL_ERROR;
- }
- return SlaveInvokeHidden(interp, slaveInterp, namespaceName,
- objc - i, objv + i);
- }
- case OPT_LIMIT: {
- static const char *const limitTypes[] = {
- "commands", "time", NULL
- };
- enum LimitTypes {
- LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME
- };
- int limitType;
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "limitType ?-option value ...?");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0,
- &limitType) != TCL_OK) {
- return TCL_ERROR;
- }
- switch ((enum LimitTypes) limitType) {
- case LIMIT_TYPE_COMMANDS:
- return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv);
- case LIMIT_TYPE_TIME:
- return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv);
- }
- }
- case OPT_MARKTRUSTED:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
- return SlaveMarkTrusted(interp, slaveInterp);
- case OPT_RECLIMIT:
- if (objc != 2 && objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
- return TCL_ERROR;
- }
- return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2);
- }
-
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveObjCmdDeleteProc --
- *
- * Invoked when an object command for a slave interpreter is deleted;
- * cleans up all state associated with the slave interpreter and destroys
- * the slave interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Cleans up all state associated with the slave interpreter and destroys
- * the slave interpreter.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-SlaveObjCmdDeleteProc(
- ClientData clientData) /* The SlaveRecord for the command. */
-{
- Slave *slavePtr; /* Interim storage for Slave record. */
- Tcl_Interp *slaveInterp = clientData;
- /* And for a slave interp. */
-
- slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
-
- /*
- * Unlink the slave from its master interpreter.
- */
-
- Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr);
-
- /*
- * Set to NULL so that when the InterpInfo is cleaned up in the slave it
- * does not try to delete the command causing all sorts of grief. See
- * SlaveRecordDeleteProc().
- */
-
- slavePtr->interpCmd = NULL;
-
- if (slavePtr->slaveInterp != NULL) {
- Tcl_DeleteInterp(slavePtr->slaveInterp);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveDebugCmd -- TIP #378
- *
- * Helper function to handle 'debug' command in a slave interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * May modify INTERP_DEBUG_FRAME flag in the slave.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveDebugCmd(
- Tcl_Interp *interp, /* Interp for error return. */
- Tcl_Interp *slaveInterp, /* The slave interpreter in which command
- * will be evaluated. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- static const char *const debugTypes[] = {
- "-frame", NULL
- };
- enum DebugTypes {
- DEBUG_TYPE_FRAME
- };
- int debugType;
- Interp *iPtr;
- Tcl_Obj *resultPtr;
-
- iPtr = (Interp *) slaveInterp;
- if (objc == 0) {
- resultPtr = Tcl_NewObj();
- Tcl_ListObjAppendElement(NULL, resultPtr,
- Tcl_NewStringObj("-frame", -1));
- Tcl_ListObjAppendElement(NULL, resultPtr,
- Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
- Tcl_SetObjResult(interp, resultPtr);
- } else {
- if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option",
- 0, &debugType) != TCL_OK) {
- return TCL_ERROR;
- }
- if (debugType == DEBUG_TYPE_FRAME) {
- if (objc == 2) { /* set */
- if (Tcl_GetBooleanFromObj(interp, objv[1], &debugType)
- != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Quietly ignore attempts to disable interp debugging. This
- * is a one-way switch as frame debug info is maintained in a
- * stack that must be consistent once turned on.
- */
-
- if (debugType) {
- iPtr->flags |= INTERP_DEBUG_FRAME;
- }
- }
- Tcl_SetObjResult(interp,
- Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
- }
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveEval --
- *
- * Helper function to evaluate a command in a slave interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Whatever the command does.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveEval(
- Tcl_Interp *interp, /* Interp for error return. */
- Tcl_Interp *slaveInterp, /* The slave interpreter in which command
- * will be evaluated. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- int result;
-
- /*
- * TIP #285: If necessary, reset the cancellation flags for the slave
- * interpreter now; otherwise, canceling a script in a master interpreter
- * can result in a situation where a slave interpreter can no longer
- * evaluate any scripts unless somebody calls the TclResetCancellation
- * function for that particular Tcl_Interp.
- */
-
- TclSetSlaveCancelFlags(slaveInterp, 0, 0);
-
- Tcl_Preserve(slaveInterp);
- Tcl_AllowExceptions(slaveInterp);
-
- if (objc == 1) {
- /*
- * TIP #280: Make actual argument location available to eval'd script.
- */
-
- Interp *iPtr = (Interp *) interp;
- CmdFrame *invoker = iPtr->cmdFramePtr;
- int word = 0;
-
- TclArgumentGet(interp, objv[0], &invoker, &word);
-
- result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word);
- } else {
- Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv);
- Tcl_IncrRefCount(objPtr);
- result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
- Tcl_DecrRefCount(objPtr);
- }
- Tcl_TransferResult(slaveInterp, result, interp);
-
- Tcl_Release(slaveInterp);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveExpose --
- *
- * Helper function to expose a command in a slave interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * After this call scripts in the slave will be able to invoke the newly
- * exposed command.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveExpose(
- Tcl_Interp *interp, /* Interp for error return. */
- Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument strings. */
-{
- const char *name;
-
- if (Tcl_IsSafe(interp)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "permission denied: safe interpreter cannot expose commands",
- -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
- NULL);
- return TCL_ERROR;
- }
-
- name = TclGetString(objv[(objc == 1) ? 0 : 1]);
- if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]),
- name) != TCL_OK) {
- Tcl_TransferResult(slaveInterp, TCL_ERROR, interp);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveRecursionLimit --
- *
- * Helper function to set/query the Recursion limit of an interp
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * When (objc == 1), slaveInterp will be set to a new recursion limit of
- * objv[0].
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveRecursionLimit(
- Tcl_Interp *interp, /* Interp for error return. */
- Tcl_Interp *slaveInterp, /* Interp in which limit is set/queried. */
- int objc, /* Set or Query. */
- Tcl_Obj *const objv[]) /* Argument strings. */
-{
- Interp *iPtr;
- int limit;
-
- if (objc) {
- if (Tcl_IsSafe(interp)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("permission denied: "
- "safe interpreters cannot change recursion limit", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
- NULL);
- return TCL_ERROR;
- }
- if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
- return TCL_ERROR;
- }
- if (limit <= 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "recursion limit must be > 0", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
- NULL);
- return TCL_ERROR;
- }
- Tcl_SetRecursionLimit(slaveInterp, limit);
- iPtr = (Interp *) slaveInterp;
- if (interp == slaveInterp && iPtr->numLevels > limit) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "falling back due to new recursion limit", -1));
- Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL);
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, objv[0]);
- return TCL_OK;
- } else {
- limit = Tcl_SetRecursionLimit(slaveInterp, 0);
- Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
- return TCL_OK;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveHide --
- *
- * Helper function to hide a command in a slave interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * After this call scripts in the slave will no longer be able to invoke
- * the named command.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveHide(
- Tcl_Interp *interp, /* Interp for error return. */
- Tcl_Interp *slaveInterp, /* Interp in which command will be exposed. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument strings. */
-{
- const char *name;
-
- if (Tcl_IsSafe(interp)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "permission denied: safe interpreter cannot hide commands",
- -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
- NULL);
- return TCL_ERROR;
- }
-
- name = TclGetString(objv[(objc == 1) ? 0 : 1]);
- if (Tcl_HideCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) {
- Tcl_TransferResult(slaveInterp, TCL_ERROR, interp);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveHidden --
- *
- * Helper function to compute list of hidden commands in a slave
- * interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveHidden(
- Tcl_Interp *interp, /* Interp for data return. */
- Tcl_Interp *slaveInterp) /* Interp whose hidden commands to query. */
-{
- Tcl_Obj *listObjPtr = Tcl_NewObj(); /* Local object pointer. */
- Tcl_HashTable *hTblPtr; /* For local searches. */
- Tcl_HashEntry *hPtr; /* For local searches. */
- Tcl_HashSearch hSearch; /* For local searches. */
-
- hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr;
- if (hTblPtr != NULL) {
- for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
- Tcl_ListObjAppendElement(NULL, listObjPtr,
- Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
- }
- }
- Tcl_SetObjResult(interp, listObjPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveInvokeHidden --
- *
- * Helper function to invoke a hidden command in a slave interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Whatever the hidden command does.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveInvokeHidden(
- Tcl_Interp *interp, /* Interp for error return. */
- Tcl_Interp *slaveInterp, /* The slave interpreter in which command will
- * be invoked. */
- const char *namespaceName, /* The namespace to use, if any. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- int result;
-
- if (Tcl_IsSafe(interp)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "not allowed to invoke hidden commands from safe interpreter",
- -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
- NULL);
- return TCL_ERROR;
- }
-
- Tcl_Preserve(slaveInterp);
- Tcl_AllowExceptions(slaveInterp);
-
- if (namespaceName == NULL) {
- NRE_callback *rootPtr = TOP_CB(slaveInterp);
-
- Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp,
- rootPtr, NULL, NULL);
- return TclNRInvoke(NULL, slaveInterp, objc, objv);
- } else {
- Namespace *nsPtr, *dummy1, *dummy2;
- const char *tail;
-
- result = TclGetNamespaceForQualName(slaveInterp, namespaceName, NULL,
- TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG
- | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
- if (result == TCL_OK) {
- result = TclObjInvokeNamespace(slaveInterp, objc, objv,
- (Tcl_Namespace *) nsPtr, TCL_INVOKE_HIDDEN);
- }
- }
-
- Tcl_TransferResult(slaveInterp, result, interp);
-
- Tcl_Release(slaveInterp);
- return result;
-}
-
-static int
-NRPostInvokeHidden(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0];
- NRE_callback *rootPtr = (NRE_callback *)data[1];
-
- if (interp != slaveInterp) {
- result = TclNRRunCallbacks(slaveInterp, result, rootPtr);
- Tcl_TransferResult(slaveInterp, result, interp);
- }
- Tcl_Release(slaveInterp);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveMarkTrusted --
- *
- * Helper function to mark a slave interpreter as trusted (unsafe).
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * After this call the hard-wired security checks in the core no longer
- * prevent the slave from performing certain operations.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveMarkTrusted(
- Tcl_Interp *interp, /* Interp for error return. */
- Tcl_Interp *slaveInterp) /* The slave interpreter which will be marked
- * trusted. */
-{
- if (Tcl_IsSafe(interp)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "permission denied: safe interpreter cannot mark trusted",
- -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
- NULL);
- return TCL_ERROR;
- }
- ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_IsSafe --
- *
- * Determines whether an interpreter is safe
- *
- * Results:
- * 1 if it is safe, 0 if it is not.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_IsSafe(
- Tcl_Interp *interp) /* Is this interpreter "safe" ? */
-{
- Interp *iPtr = (Interp *) interp;
-
- if (iPtr == NULL) {
- return 0;
- }
- return (iPtr->flags & SAFE_INTERP) ? 1 : 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_MakeSafe --
- *
- * Makes its argument interpreter contain only functionality that is
- * defined to be part of Safe Tcl. Unsafe commands are hidden, the env
- * array is unset, and the standard channels are removed.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Hides commands in its argument interpreter, and removes settings and
- * channels.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_MakeSafe(
- Tcl_Interp *interp) /* Interpreter to be made safe. */
-{
- Tcl_Channel chan; /* Channel to remove from safe interpreter. */
- Interp *iPtr = (Interp *) interp;
- Tcl_Interp *master = ((InterpInfo*) iPtr->interpInfo)->slave.masterInterp;
-
- TclHideUnsafeCommands(interp);
-
- if (master != NULL) {
- /*
- * Alias these function implementations in the slave to those in the
- * master; the overall implementations are safe, but they're normally
- * defined by init.tcl which is not sourced by safe interpreters.
- * Assume these functions all work. [Bug 2895741]
- */
-
- (void) Tcl_Eval(interp,
- "namespace eval ::tcl {namespace eval mathfunc {}}");
- (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master,
- "::tcl::mathfunc::min", 0, NULL);
- (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master,
- "::tcl::mathfunc::max", 0, NULL);
- }
-
- iPtr->flags |= SAFE_INTERP;
-
- /*
- * Unsetting variables : (which should not have been set in the first
- * place, but...)
- */
-
- /*
- * No env array in a safe slave.
- */
-
- Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
-
- /*
- * Remove unsafe parts of tcl_platform
- */
-
- Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);
-
- /*
- * Unset path informations variables (the only one remaining is [info
- * nameofexecutable])
- */
-
- Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
-
- /*
- * Remove the standard channels from the interpreter; safe interpreters do
- * not ordinarily have access to stdin, stdout and stderr.
- *
- * NOTE: These channels are not added to the interpreter by the
- * Tcl_CreateInterp call, but may be added later, by another I/O
- * operation. We want to ensure that the interpreter does not have these
- * channels even if it is being made safe after being used for some time..
- */
-
- chan = Tcl_GetStdChannel(TCL_STDIN);
- if (chan != NULL) {
- Tcl_UnregisterChannel(interp, chan);
- }
- chan = Tcl_GetStdChannel(TCL_STDOUT);
- if (chan != NULL) {
- Tcl_UnregisterChannel(interp, chan);
- }
- chan = Tcl_GetStdChannel(TCL_STDERR);
- if (chan != NULL) {
- Tcl_UnregisterChannel(interp, chan);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitExceeded --
- *
- * Tests whether any limit has been exceeded in the given interpreter
- * (i.e. whether the interpreter is currently unable to process further
- * scripts).
- *
- * Results:
- * A boolean value.
- *
- * Side effects:
- * None.
- *
- * Notes:
- * If you change this function, you MUST also update TclLimitExceeded() in
- * tclInt.h.
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_LimitExceeded(
- Tcl_Interp *interp)
-{
- register Interp *iPtr = (Interp *) interp;
-
- return iPtr->limit.exceeded != 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitReady --
- *
- * Find out whether any limit has been set on the interpreter, and if so
- * check whether the granularity of that limit is such that the full
- * limit check should be carried out.
- *
- * Results:
- * A boolean value that indicates whether to call Tcl_LimitCheck.
- *
- * Side effects:
- * Increments the limit granularity counter.
- *
- * Notes:
- * If you change this function, you MUST also update TclLimitReady() in
- * tclInt.h.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_LimitReady(
- Tcl_Interp *interp)
-{
- register Interp *iPtr = (Interp *) interp;
-
- if (iPtr->limit.active != 0) {
- register int ticker = ++iPtr->limit.granularityTicker;
-
- if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
- ((iPtr->limit.cmdGranularity == 1) ||
- (ticker % iPtr->limit.cmdGranularity == 0))) {
- return 1;
- }
- if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
- ((iPtr->limit.timeGranularity == 1) ||
- (ticker % iPtr->limit.timeGranularity == 0))) {
- return 1;
- }
- }
- return 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitCheck --
- *
- * Check all currently set limits in the interpreter (where permitted by
- * granularity). If a limit is exceeded, call its callbacks and, if the
- * limit is still exceeded after the callbacks have run, make the
- * interpreter generate an error that cannot be caught within the limited
- * interpreter.
- *
- * Results:
- * A Tcl result value (TCL_OK if no limit is exceeded, and TCL_ERROR if a
- * limit has been exceeded).
- *
- * Side effects:
- * May invoke system calls. May invoke other interpreters. May be
- * reentrant. May put the interpreter into a state where it can no longer
- * execute commands without outside intervention.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_LimitCheck(
- Tcl_Interp *interp)
-{
- Interp *iPtr = (Interp *) interp;
- register int ticker = iPtr->limit.granularityTicker;
-
- if (Tcl_InterpDeleted(interp)) {
- return TCL_OK;
- }
-
- if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
- ((iPtr->limit.cmdGranularity == 1) ||
- (ticker % iPtr->limit.cmdGranularity == 0)) &&
- (iPtr->limit.cmdCount < iPtr->cmdCount)) {
- iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS;
- Tcl_Preserve(interp);
- RunLimitHandlers(iPtr->limit.cmdHandlers, interp);
- if (iPtr->limit.cmdCount >= iPtr->cmdCount) {
- iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
- } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "command count limit exceeded", -1));
- Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL);
- Tcl_Release(interp);
- return TCL_ERROR;
- }
- Tcl_Release(interp);
- }
-
- if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
- ((iPtr->limit.timeGranularity == 1) ||
- (ticker % iPtr->limit.timeGranularity == 0))) {
- Tcl_Time now;
-
- Tcl_GetTime(&now);
- if (iPtr->limit.time.sec < now.sec ||
- (iPtr->limit.time.sec == now.sec &&
- iPtr->limit.time.usec < now.usec)) {
- iPtr->limit.exceeded |= TCL_LIMIT_TIME;
- Tcl_Preserve(interp);
- RunLimitHandlers(iPtr->limit.timeHandlers, interp);
- if (iPtr->limit.time.sec > now.sec ||
- (iPtr->limit.time.sec == now.sec &&
- iPtr->limit.time.usec >= now.usec)) {
- iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
- } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "time limit exceeded", -1));
- Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL);
- Tcl_Release(interp);
- return TCL_ERROR;
- }
- Tcl_Release(interp);
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * RunLimitHandlers --
- *
- * Invoke all the limit handlers in a list (for a particular limit).
- * Note that no particular limit handler callback will be invoked
- * reentrantly.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Depends on the limit handlers.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-RunLimitHandlers(
- LimitHandler *handlerPtr,
- Tcl_Interp *interp)
-{
- LimitHandler *nextPtr;
- for (; handlerPtr!=NULL ; handlerPtr=nextPtr) {
- if (handlerPtr->flags & (LIMIT_HANDLER_DELETED|LIMIT_HANDLER_ACTIVE)) {
- /*
- * Reentrant call or something seriously strange in the delete
- * code.
- */
-
- nextPtr = handlerPtr->nextPtr;
- continue;
- }
-
- /*
- * Set the ACTIVE flag while running the limit handler itself so we
- * cannot reentrantly call this handler and know to use the alternate
- * method of deletion if necessary.
- */
-
- handlerPtr->flags |= LIMIT_HANDLER_ACTIVE;
- handlerPtr->handlerProc(handlerPtr->clientData, interp);
- handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE;
-
- /*
- * Rediscover this value; it might have changed during the processing
- * of a limit handler. We have to record it here because we might
- * delete the structure below, and reading a value out of a deleted
- * structure is unsafe (even if actually legal with some
- * malloc()/free() implementations.)
- */
-
- nextPtr = handlerPtr->nextPtr;
-
- /*
- * If we deleted the current handler while we were executing it, we
- * will have spliced it out of the list and set the
- * LIMIT_HANDLER_DELETED flag.
- */
-
- if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
- if (handlerPtr->deleteProc != NULL) {
- handlerPtr->deleteProc(handlerPtr->clientData);
- }
- ckfree(handlerPtr);
- }
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitAddHandler --
- *
- * Add a callback handler for a particular resource limit.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Extends the internal linked list of handlers for a limit.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_LimitAddHandler(
- Tcl_Interp *interp,
- int type,
- Tcl_LimitHandlerProc *handlerProc,
- ClientData clientData,
- Tcl_LimitHandlerDeleteProc *deleteProc)
-{
- Interp *iPtr = (Interp *) interp;
- LimitHandler *handlerPtr;
-
- /*
- * Convert everything into a real deletion callback.
- */
-
- if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) {
- deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free;
- }
- if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) {
- deleteProc = NULL;
- }
-
- /*
- * Allocate a handler record.
- */
-
- handlerPtr = ckalloc(sizeof(LimitHandler));
- handlerPtr->flags = 0;
- handlerPtr->handlerProc = handlerProc;
- handlerPtr->clientData = clientData;
- handlerPtr->deleteProc = deleteProc;
- handlerPtr->prevPtr = NULL;
-
- /*
- * Prepend onto the front of the correct linked list.
- */
-
- switch (type) {
- case TCL_LIMIT_COMMANDS:
- handlerPtr->nextPtr = iPtr->limit.cmdHandlers;
- if (handlerPtr->nextPtr != NULL) {
- handlerPtr->nextPtr->prevPtr = handlerPtr;
- }
- iPtr->limit.cmdHandlers = handlerPtr;
- return;
-
- case TCL_LIMIT_TIME:
- handlerPtr->nextPtr = iPtr->limit.timeHandlers;
- if (handlerPtr->nextPtr != NULL) {
- handlerPtr->nextPtr->prevPtr = handlerPtr;
- }
- iPtr->limit.timeHandlers = handlerPtr;
- return;
- }
-
- Tcl_Panic("unknown type of resource limit");
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitRemoveHandler --
- *
- * Remove a callback handler for a particular resource limit.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The handler is spliced out of the internal linked list for the limit,
- * and if not currently being invoked, deleted. Otherwise it is just
- * marked for deletion and removed when the limit handler has finished
- * executing.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_LimitRemoveHandler(
- Tcl_Interp *interp,
- int type,
- Tcl_LimitHandlerProc *handlerProc,
- ClientData clientData)
-{
- Interp *iPtr = (Interp *) interp;
- LimitHandler *handlerPtr;
-
- switch (type) {
- case TCL_LIMIT_COMMANDS:
- handlerPtr = iPtr->limit.cmdHandlers;
- break;
- case TCL_LIMIT_TIME:
- handlerPtr = iPtr->limit.timeHandlers;
- break;
- default:
- Tcl_Panic("unknown type of resource limit");
- return;
- }
-
- for (; handlerPtr!=NULL ; handlerPtr=handlerPtr->nextPtr) {
- if ((handlerPtr->handlerProc != handlerProc) ||
- (handlerPtr->clientData != clientData)) {
- continue;
- }
-
- /*
- * We've found the handler to delete; mark it as doomed if not already
- * so marked (which shouldn't actually happen).
- */
-
- if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
- return;
- }
- handlerPtr->flags |= LIMIT_HANDLER_DELETED;
-
- /*
- * Splice the handler out of the doubly-linked list.
- */
-
- if (handlerPtr->prevPtr == NULL) {
- switch (type) {
- case TCL_LIMIT_COMMANDS:
- iPtr->limit.cmdHandlers = handlerPtr->nextPtr;
- break;
- case TCL_LIMIT_TIME:
- iPtr->limit.timeHandlers = handlerPtr->nextPtr;
- break;
- }
- } else {
- handlerPtr->prevPtr->nextPtr = handlerPtr->nextPtr;
- }
- if (handlerPtr->nextPtr != NULL) {
- handlerPtr->nextPtr->prevPtr = handlerPtr->prevPtr;
- }
-
- /*
- * If nothing is currently executing the handler, delete its client
- * data and the overall handler structure now. Otherwise it will all
- * go away when the handler returns.
- */
-
- if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
- if (handlerPtr->deleteProc != NULL) {
- handlerPtr->deleteProc(handlerPtr->clientData);
- }
- ckfree(handlerPtr);
- }
- return;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclLimitRemoveAllHandlers --
- *
- * Remove all limit callback handlers for an interpreter. This is invoked
- * as part of deleting the interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Limit handlers are deleted or marked for deletion (as with
- * Tcl_LimitRemoveHandler).
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclLimitRemoveAllHandlers(
- Tcl_Interp *interp)
-{
- Interp *iPtr = (Interp *) interp;
- LimitHandler *handlerPtr, *nextHandlerPtr;
-
- /*
- * Delete all command-limit handlers.
- */
-
- for (handlerPtr=iPtr->limit.cmdHandlers, iPtr->limit.cmdHandlers=NULL;
- handlerPtr!=NULL; handlerPtr=nextHandlerPtr) {
- nextHandlerPtr = handlerPtr->nextPtr;
-
- /*
- * Do not delete here if it has already been marked for deletion.
- */
-
- if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
- continue;
- }
- handlerPtr->flags |= LIMIT_HANDLER_DELETED;
- handlerPtr->prevPtr = NULL;
- handlerPtr->nextPtr = NULL;
-
- /*
- * If nothing is currently executing the handler, delete its client
- * data and the overall handler structure now. Otherwise it will all
- * go away when the handler returns.
- */
-
- if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
- if (handlerPtr->deleteProc != NULL) {
- handlerPtr->deleteProc(handlerPtr->clientData);
- }
- ckfree(handlerPtr);
- }
- }
-
- /*
- * Delete all time-limit handlers.
- */
-
- for (handlerPtr=iPtr->limit.timeHandlers, iPtr->limit.timeHandlers=NULL;
- handlerPtr!=NULL; handlerPtr=nextHandlerPtr) {
- nextHandlerPtr = handlerPtr->nextPtr;
-
- /*
- * Do not delete here if it has already been marked for deletion.
- */
-
- if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
- continue;
- }
- handlerPtr->flags |= LIMIT_HANDLER_DELETED;
- handlerPtr->prevPtr = NULL;
- handlerPtr->nextPtr = NULL;
-
- /*
- * If nothing is currently executing the handler, delete its client
- * data and the overall handler structure now. Otherwise it will all
- * go away when the handler returns.
- */
-
- if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
- if (handlerPtr->deleteProc != NULL) {
- handlerPtr->deleteProc(handlerPtr->clientData);
- }
- ckfree(handlerPtr);
- }
- }
-
- /*
- * Delete the timer callback that is used to trap limits that occur in
- * [vwait]s...
- */
-
- if (iPtr->limit.timeEvent != NULL) {
- Tcl_DeleteTimerHandler(iPtr->limit.timeEvent);
- iPtr->limit.timeEvent = NULL;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitTypeEnabled --
- *
- * Check whether a particular limit has been enabled for an interpreter.
- *
- * Results:
- * A boolean value.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_LimitTypeEnabled(
- Tcl_Interp *interp,
- int type)
-{
- Interp *iPtr = (Interp *) interp;
-
- return (iPtr->limit.active & type) != 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitTypeExceeded --
- *
- * Check whether a particular limit has been exceeded for an interpreter.
- *
- * Results:
- * A boolean value (note that Tcl_LimitExceeded will always return
- * non-zero when this function returns non-zero).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_LimitTypeExceeded(
- Tcl_Interp *interp,
- int type)
-{
- Interp *iPtr = (Interp *) interp;
-
- return (iPtr->limit.exceeded & type) != 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitTypeSet --
- *
- * Enable a particular limit for an interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The limit is turned on and will be checked in future at an interval
- * determined by the frequency of calling of Tcl_LimitReady and the
- * granularity of the limit in question.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_LimitTypeSet(
- Tcl_Interp *interp,
- int type)
-{
- Interp *iPtr = (Interp *) interp;
-
- iPtr->limit.active |= type;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitTypeReset --
- *
- * Disable a particular limit for an interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The limit is disabled. If the limit was exceeded when this function
- * was called, the limit will no longer be exceeded afterwards and the
- * interpreter will be free to execute further scripts (assuming it isn't
- * also deleted, of course).
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_LimitTypeReset(
- Tcl_Interp *interp,
- int type)
-{
- Interp *iPtr = (Interp *) interp;
-
- iPtr->limit.active &= ~type;
- iPtr->limit.exceeded &= ~type;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitSetCommands --
- *
- * Set the command limit for an interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Also resets whether the command limit was exceeded. This might permit
- * a small amount of further execution in the interpreter even if the
- * limit itself is theoretically exceeded.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_LimitSetCommands(
- Tcl_Interp *interp,
- int commandLimit)
-{
- Interp *iPtr = (Interp *) interp;
-
- iPtr->limit.cmdCount = commandLimit;
- iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitGetCommands --
- *
- * Get the number of commands that may be executed in the interpreter
- * before the command-limit is reached.
- *
- * Results:
- * An upper bound on the number of commands.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_LimitGetCommands(
- Tcl_Interp *interp)
-{
- Interp *iPtr = (Interp *) interp;
-
- return iPtr->limit.cmdCount;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitSetTime --
- *
- * Set the time limit for an interpreter by copying it from the value
- * pointed to by the timeLimitPtr argument.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Also resets whether the time limit was exceeded. This might permit a
- * small amount of further execution in the interpreter even if the limit
- * itself is theoretically exceeded.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_LimitSetTime(
- Tcl_Interp *interp,
- Tcl_Time *timeLimitPtr)
-{
- Interp *iPtr = (Interp *) interp;
- Tcl_Time nextMoment;
-
- memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time));
- if (iPtr->limit.timeEvent != NULL) {
- Tcl_DeleteTimerHandler(iPtr->limit.timeEvent);
- }
- nextMoment.sec = timeLimitPtr->sec;
- nextMoment.usec = timeLimitPtr->usec+10;
- if (nextMoment.usec >= 1000000) {
- nextMoment.sec++;
- nextMoment.usec -= 1000000;
- }
- iPtr->limit.timeEvent = TclCreateAbsoluteTimerHandler(&nextMoment,
- TimeLimitCallback, interp);
- iPtr->limit.exceeded &= ~TCL_LIMIT_TIME;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TimeLimitCallback --
- *
- * Callback that allows time limits to be enforced even when doing a
- * blocking wait for events.
- *
- * Results:
- * None.
- *
- * Side effects:
- * May put the interpreter into a state where it can no longer execute
- * commands. May make callbacks into other interpreters.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-TimeLimitCallback(
- ClientData clientData)
-{
- Tcl_Interp *interp = clientData;
- Interp *iPtr = clientData;
- int code;
-
- Tcl_Preserve(interp);
- iPtr->limit.timeEvent = NULL;
-
- /*
- * Must reset the granularity ticker here to force an immediate full
- * check. This is OK because we're swallowing the cost in the overall cost
- * of the event loop. [Bug 2891362]
- */
-
- iPtr->limit.granularityTicker = 0;
-
- code = Tcl_LimitCheck(interp);
- if (code != TCL_OK) {
- Tcl_AddErrorInfo(interp, "\n (while waiting for event)");
- Tcl_BackgroundException(interp, code);
- }
- Tcl_Release(interp);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitGetTime --
- *
- * Get the current time limit.
- *
- * Results:
- * The time limit (by it being copied into the variable pointed to by the
- * timeLimitPtr).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_LimitGetTime(
- Tcl_Interp *interp,
- Tcl_Time *timeLimitPtr)
-{
- Interp *iPtr = (Interp *) interp;
-
- memcpy(timeLimitPtr, &iPtr->limit.time, sizeof(Tcl_Time));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitSetGranularity --
- *
- * Set the granularity divisor (which must be positive) for a particular
- * limit.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The granularity is updated.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_LimitSetGranularity(
- Tcl_Interp *interp,
- int type,
- int granularity)
-{
- Interp *iPtr = (Interp *) interp;
- if (granularity < 1) {
- Tcl_Panic("limit granularity must be positive");
- }
-
- switch (type) {
- case TCL_LIMIT_COMMANDS:
- iPtr->limit.cmdGranularity = granularity;
- return;
- case TCL_LIMIT_TIME:
- iPtr->limit.timeGranularity = granularity;
- return;
- }
- Tcl_Panic("unknown type of resource limit");
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LimitGetGranularity --
- *
- * Get the granularity divisor for a particular limit.
- *
- * Results:
- * The granularity divisor for the given limit.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_LimitGetGranularity(
- Tcl_Interp *interp,
- int type)
-{
- Interp *iPtr = (Interp *) interp;
-
- switch (type) {
- case TCL_LIMIT_COMMANDS:
- return iPtr->limit.cmdGranularity;
- case TCL_LIMIT_TIME:
- return iPtr->limit.timeGranularity;
- }
- Tcl_Panic("unknown type of resource limit");
- return -1; /* NOT REACHED */
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DeleteScriptLimitCallback --
- *
- * Callback for when a script limit (a limit callback implemented as a
- * Tcl script in a master interpreter, as set up from Tcl) is deleted.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The reference to the script callback from the controlling interpreter
- * is removed.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DeleteScriptLimitCallback(
- ClientData clientData)
-{
- ScriptLimitCallback *limitCBPtr = clientData;
-
- Tcl_DecrRefCount(limitCBPtr->scriptObj);
- if (limitCBPtr->entryPtr != NULL) {
- Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
- }
- ckfree(limitCBPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CallScriptLimitCallback --
- *
- * Invoke a script limit callback. Used to implement limit callbacks set
- * at the Tcl level on child interpreters.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Depends on the callback script. Errors are reported as background
- * errors.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-CallScriptLimitCallback(
- ClientData clientData,
- Tcl_Interp *interp) /* Interpreter which failed the limit */
-{
- ScriptLimitCallback *limitCBPtr = clientData;
- int code;
-
- if (Tcl_InterpDeleted(limitCBPtr->interp)) {
- return;
- }
- Tcl_Preserve(limitCBPtr->interp);
- code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj,
- TCL_EVAL_GLOBAL);
- if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) {
- Tcl_BackgroundException(limitCBPtr->interp, code);
- }
- Tcl_Release(limitCBPtr->interp);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SetScriptLimitCallback --
- *
- * Install (or remove, if scriptObj is NULL) a limit callback script that
- * is called when the target interpreter exceeds the type of limit
- * specified. Each interpreter may only have one callback set on another
- * interpreter through this mechanism (though as many interpreters may be
- * limited as the programmer chooses overall).
- *
- * Results:
- * None.
- *
- * Side effects:
- * A limit callback implemented as an invokation of a Tcl script in
- * another interpreter is either installed or removed.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-SetScriptLimitCallback(
- Tcl_Interp *interp,
- int type,
- Tcl_Interp *targetInterp,
- Tcl_Obj *scriptObj)
-{
- ScriptLimitCallback *limitCBPtr;
- Tcl_HashEntry *hashPtr;
- int isNew;
- ScriptLimitCallbackKey key;
- Interp *iPtr = (Interp *) interp;
-
- if (interp == targetInterp) {
- Tcl_Panic("installing limit callback to the limited interpreter");
- }
-
- key.interp = targetInterp;
- key.type = type;
-
- if (scriptObj == NULL) {
- hashPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
- if (hashPtr != NULL) {
- Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback,
- Tcl_GetHashValue(hashPtr));
- }
- return;
- }
-
- hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key,
- &isNew);
- if (!isNew) {
- limitCBPtr = Tcl_GetHashValue(hashPtr);
- limitCBPtr->entryPtr = NULL;
- Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback,
- limitCBPtr);
- }
-
- limitCBPtr = ckalloc(sizeof(ScriptLimitCallback));
- limitCBPtr->interp = interp;
- limitCBPtr->scriptObj = scriptObj;
- limitCBPtr->entryPtr = hashPtr;
- limitCBPtr->type = type;
- Tcl_IncrRefCount(scriptObj);
-
- Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback,
- limitCBPtr, DeleteScriptLimitCallback);
- Tcl_SetHashValue(hashPtr, limitCBPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclRemoveScriptLimitCallbacks --
- *
- * Remove all script-implemented limit callbacks that make calls back
- * into the given interpreter. This invoked as part of deleting an
- * interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The script limit callbacks are removed or marked for later removal.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclRemoveScriptLimitCallbacks(
- Tcl_Interp *interp)
-{
- Interp *iPtr = (Interp *) interp;
- Tcl_HashEntry *hashPtr;
- Tcl_HashSearch search;
- ScriptLimitCallbackKey *keyPtr;
-
- hashPtr = Tcl_FirstHashEntry(&iPtr->limit.callbacks, &search);
- while (hashPtr != NULL) {
- keyPtr = (ScriptLimitCallbackKey *)
- Tcl_GetHashKey(&iPtr->limit.callbacks, hashPtr);
- Tcl_LimitRemoveHandler(keyPtr->interp, keyPtr->type,
- CallScriptLimitCallback, Tcl_GetHashValue(hashPtr));
- hashPtr = Tcl_NextHashEntry(&search);
- }
- Tcl_DeleteHashTable(&iPtr->limit.callbacks);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclInitLimitSupport --
- *
- * Initialise all the parts of the interpreter relating to resource limit
- * management. This allows an interpreter to both have limits set upon
- * itself and set limits upon other interpreters.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The resource limit subsystem is initialised for the interpreter.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclInitLimitSupport(
- Tcl_Interp *interp)
-{
- Interp *iPtr = (Interp *) interp;
-
- iPtr->limit.active = 0;
- iPtr->limit.granularityTicker = 0;
- iPtr->limit.exceeded = 0;
- iPtr->limit.cmdCount = 0;
- iPtr->limit.cmdHandlers = NULL;
- iPtr->limit.cmdGranularity = 1;
- memset(&iPtr->limit.time, 0, sizeof(Tcl_Time));
- iPtr->limit.timeHandlers = NULL;
- iPtr->limit.timeEvent = NULL;
- iPtr->limit.timeGranularity = 10;
- Tcl_InitHashTable(&iPtr->limit.callbacks,
- sizeof(ScriptLimitCallbackKey)/sizeof(int));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InheritLimitsFromMaster --
- *
- * Derive the interpreter limit configuration for a slave interpreter
- * from the limit config for the master.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The slave interpreter limits are set so that if the master has a
- * limit, it may not exceed it by handing off work to slave interpreters.
- * Note that this does not transfer limit callbacks from the master to
- * the slave.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-InheritLimitsFromMaster(
- Tcl_Interp *slaveInterp,
- Tcl_Interp *masterInterp)
-{
- Interp *slavePtr = (Interp *) slaveInterp;
- Interp *masterPtr = (Interp *) masterInterp;
-
- if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) {
- slavePtr->limit.active |= TCL_LIMIT_COMMANDS;
- slavePtr->limit.cmdCount = 0;
- slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity;
- }
- if (masterPtr->limit.active & TCL_LIMIT_TIME) {
- slavePtr->limit.active |= TCL_LIMIT_TIME;
- memcpy(&slavePtr->limit.time, &masterPtr->limit.time,
- sizeof(Tcl_Time));
- slavePtr->limit.timeGranularity = masterPtr->limit.timeGranularity;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveCommandLimitCmd --
- *
- * Implementation of the [interp limit $i commands] and [$i limit
- * commands] subcommands. See the interp manual page for a full
- * description.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Depends on the arguments.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveCommandLimitCmd(
- Tcl_Interp *interp, /* Current interpreter. */
- Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */
- int consumedObjc, /* Number of args already parsed. */
- int objc, /* Total number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- static const char *const options[] = {
- "-command", "-granularity", "-value", NULL
- };
- enum Options {
- OPT_CMD, OPT_GRAN, OPT_VAL
- };
- Interp *iPtr = (Interp *) interp;
- int index;
- ScriptLimitCallbackKey key;
- ScriptLimitCallback *limitCBPtr;
- Tcl_HashEntry *hPtr;
-
- /*
- * First, ensure that we are not reading or writing the calling
- * interpreter's limits; it may only manipulate its children. Note that
- * the low level API enforces this with Tcl_Panic, which we want to
- * avoid. [Bug 3398794]
- */
-
- if (interp == slaveInterp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "limits on current interpreter inaccessible", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
- return TCL_ERROR;
- }
-
- if (objc == consumedObjc) {
- Tcl_Obj *dictPtr;
-
- TclNewObj(dictPtr);
- key.interp = slaveInterp;
- key.type = TCL_LIMIT_COMMANDS;
- hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
- if (hPtr != NULL) {
- limitCBPtr = Tcl_GetHashValue(hPtr);
- if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
- Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
- limitCBPtr->scriptObj);
- } else {
- goto putEmptyCommandInDict;
- }
- } else {
- Tcl_Obj *empty;
-
- putEmptyCommandInDict:
- TclNewObj(empty);
- Tcl_DictObjPut(NULL, dictPtr,
- Tcl_NewStringObj(options[0], -1), empty);
- }
- Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
- Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp,
- TCL_LIMIT_COMMANDS)));
-
- if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) {
- Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
- Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp)));
- } else {
- Tcl_Obj *empty;
-
- TclNewObj(empty);
- Tcl_DictObjPut(NULL, dictPtr,
- Tcl_NewStringObj(options[2], -1), empty);
- }
- Tcl_SetObjResult(interp, dictPtr);
- return TCL_OK;
- } else if (objc == consumedObjc+1) {
- if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
- 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- switch ((enum Options) index) {
- case OPT_CMD:
- key.interp = slaveInterp;
- key.type = TCL_LIMIT_COMMANDS;
- hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
- if (hPtr != NULL) {
- limitCBPtr = Tcl_GetHashValue(hPtr);
- if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
- Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
- }
- }
- break;
- case OPT_GRAN:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
- Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS)));
- break;
- case OPT_VAL:
- if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) {
- Tcl_SetObjResult(interp,
- Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp)));
- }
- break;
- }
- return TCL_OK;
- } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
- Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
- return TCL_ERROR;
- } else {
- int i, scriptLen = 0, limitLen = 0;
- Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL;
- int gran = 0, limit = 0;
-
- for (i=consumedObjc ; i<objc ; i+=2) {
- if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
- &index) != TCL_OK) {
- return TCL_ERROR;
- }
- switch ((enum Options) index) {
- case OPT_CMD:
- scriptObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
- break;
- case OPT_GRAN:
- granObj = objv[i+1];
- if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
- return TCL_ERROR;
- }
- if (gran < 1) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "granularity must be at least 1", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADVALUE", NULL);
- return TCL_ERROR;
- }
- break;
- case OPT_VAL:
- limitObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
- if (limitLen == 0) {
- break;
- }
- if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
- return TCL_ERROR;
- }
- if (limit < 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "command limit value must be at least 0", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADVALUE", NULL);
- return TCL_ERROR;
- }
- break;
- }
- }
- if (scriptObj != NULL) {
- SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, slaveInterp,
- (scriptLen > 0 ? scriptObj : NULL));
- }
- if (granObj != NULL) {
- Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran);
- }
- if (limitObj != NULL) {
- if (limitLen > 0) {
- Tcl_LimitSetCommands(slaveInterp, limit);
- Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS);
- } else {
- Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS);
- }
- }
- return TCL_OK;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveTimeLimitCmd --
- *
- * Implementation of the [interp limit $i time] and [$i limit time]
- * subcommands. See the interp manual page for a full description.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Depends on the arguments.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveTimeLimitCmd(
- Tcl_Interp *interp, /* Current interpreter. */
- Tcl_Interp *slaveInterp, /* Interpreter being adjusted. */
- int consumedObjc, /* Number of args already parsed. */
- int objc, /* Total number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- static const char *const options[] = {
- "-command", "-granularity", "-milliseconds", "-seconds", NULL
- };
- enum Options {
- OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC
- };
- Interp *iPtr = (Interp *) interp;
- int index;
- ScriptLimitCallbackKey key;
- ScriptLimitCallback *limitCBPtr;
- Tcl_HashEntry *hPtr;
-
- /*
- * First, ensure that we are not reading or writing the calling
- * interpreter's limits; it may only manipulate its children. Note that
- * the low level API enforces this with Tcl_Panic, which we want to
- * avoid. [Bug 3398794]
- */
-
- if (interp == slaveInterp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "limits on current interpreter inaccessible", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "SELF", NULL);
- return TCL_ERROR;
- }
-
- if (objc == consumedObjc) {
- Tcl_Obj *dictPtr;
-
- TclNewObj(dictPtr);
- key.interp = slaveInterp;
- key.type = TCL_LIMIT_TIME;
- hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
- if (hPtr != NULL) {
- limitCBPtr = Tcl_GetHashValue(hPtr);
- if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
- Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1),
- limitCBPtr->scriptObj);
- } else {
- goto putEmptyCommandInDict;
- }
- } else {
- Tcl_Obj *empty;
- putEmptyCommandInDict:
- TclNewObj(empty);
- Tcl_DictObjPut(NULL, dictPtr,
- Tcl_NewStringObj(options[0], -1), empty);
- }
- Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1),
- Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp,
- TCL_LIMIT_TIME)));
-
- if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
- Tcl_Time limitMoment;
-
- Tcl_LimitGetTime(slaveInterp, &limitMoment);
- Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1),
- Tcl_NewLongObj(limitMoment.usec/1000));
- Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1),
- Tcl_NewLongObj(limitMoment.sec));
- } else {
- Tcl_Obj *empty;
-
- TclNewObj(empty);
- Tcl_DictObjPut(NULL, dictPtr,
- Tcl_NewStringObj(options[2], -1), empty);
- Tcl_DictObjPut(NULL, dictPtr,
- Tcl_NewStringObj(options[3], -1), empty);
- }
- Tcl_SetObjResult(interp, dictPtr);
- return TCL_OK;
- } else if (objc == consumedObjc+1) {
- if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option",
- 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- switch ((enum Options) index) {
- case OPT_CMD:
- key.interp = slaveInterp;
- key.type = TCL_LIMIT_TIME;
- hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
- if (hPtr != NULL) {
- limitCBPtr = Tcl_GetHashValue(hPtr);
- if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) {
- Tcl_SetObjResult(interp, limitCBPtr->scriptObj);
- }
- }
- break;
- case OPT_GRAN:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(
- Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME)));
- break;
- case OPT_MILLI:
- if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
- Tcl_Time limitMoment;
-
- Tcl_LimitGetTime(slaveInterp, &limitMoment);
- Tcl_SetObjResult(interp,
- Tcl_NewLongObj(limitMoment.usec/1000));
- }
- break;
- case OPT_SEC:
- if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) {
- Tcl_Time limitMoment;
-
- Tcl_LimitGetTime(slaveInterp, &limitMoment);
- Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec));
- }
- break;
- }
- return TCL_OK;
- } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
- Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
- return TCL_ERROR;
- } else {
- int i, scriptLen = 0, milliLen = 0, secLen = 0;
- Tcl_Obj *scriptObj = NULL, *granObj = NULL;
- Tcl_Obj *milliObj = NULL, *secObj = NULL;
- int gran = 0;
- Tcl_Time limitMoment;
- int tmp;
-
- Tcl_LimitGetTime(slaveInterp, &limitMoment);
- for (i=consumedObjc ; i<objc ; i+=2) {
- if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
- &index) != TCL_OK) {
- return TCL_ERROR;
- }
- switch ((enum Options) index) {
- case OPT_CMD:
- scriptObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
- break;
- case OPT_GRAN:
- granObj = objv[i+1];
- if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
- return TCL_ERROR;
- }
- if (gran < 1) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "granularity must be at least 1", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADVALUE", NULL);
- return TCL_ERROR;
- }
- break;
- case OPT_MILLI:
- milliObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &milliLen);
- if (milliLen == 0) {
- break;
- }
- if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
- return TCL_ERROR;
- }
- if (tmp < 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "milliseconds must be at least 0", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADVALUE", NULL);
- return TCL_ERROR;
- }
- limitMoment.usec = ((long) tmp)*1000;
- break;
- case OPT_SEC:
- secObj = objv[i+1];
- (void) Tcl_GetStringFromObj(objv[i+1], &secLen);
- if (secLen == 0) {
- break;
- }
- if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
- return TCL_ERROR;
- }
- if (tmp < 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "seconds must be at least 0", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADVALUE", NULL);
- return TCL_ERROR;
- }
- limitMoment.sec = tmp;
- break;
- }
- }
- if (milliObj != NULL || secObj != NULL) {
- if (milliObj != NULL) {
- /*
- * Setting -milliseconds but clearing -seconds, or resetting
- * -milliseconds but not resetting -seconds? Bad voodoo!
- */
-
- if (secObj != NULL && secLen == 0 && milliLen > 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "may only set -milliseconds if -seconds is not "
- "also being reset", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADUSAGE", NULL);
- return TCL_ERROR;
- }
- if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "may only reset -milliseconds if -seconds is "
- "also being reset", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
- "BADUSAGE", NULL);
- return TCL_ERROR;
- }
- }
-
- if (milliLen > 0 || secLen > 0) {
- /*
- * Force usec to be in range [0..1000000), possibly
- * incrementing sec in the process. This makes it much easier
- * for people to write scripts that do small time increments.
- */
-
- limitMoment.sec += limitMoment.usec / 1000000;
- limitMoment.usec %= 1000000;
-
- Tcl_LimitSetTime(slaveInterp, &limitMoment);
- Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME);
- } else {
- Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME);
- }
- }
- if (scriptObj != NULL) {
- SetScriptLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp,
- (scriptLen > 0 ? scriptObj : NULL));
- }
- if (granObj != NULL) {
- Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran);
- }
- return TCL_OK;
- }
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */