diff options
Diffstat (limited to 'generic/tclInterp.c')
| -rw-r--r-- | generic/tclInterp.c | 1949 |
1 files changed, 1224 insertions, 725 deletions
diff --git a/generic/tclInterp.c b/generic/tclInterp.c index c521435..0da5d47 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclInterp.c,v 1.60 2005/07/17 21:17:42 dkf Exp $ */ #include "tclInt.h" @@ -18,11 +16,10 @@ /* * 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 procedure below. + * above. This variable can be modified by the function below. */ -static char * tclPreInitScript = NULL; - +static const char *tclPreInitScript = NULL; /* Forward declaration */ struct Target; @@ -50,9 +47,9 @@ typedef struct Alias { * 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 + 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 @@ -80,7 +77,7 @@ 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 + * slave interpreter. Used to find this * record, and used when deleting the slave * interpreter to delete it from the master's * table. */ @@ -156,98 +153,137 @@ typedef struct 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 + * 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. */ -struct ScriptLimitCallback { - Tcl_Interp *interp; - Tcl_Obj *scriptObj; - int type; - Tcl_HashEntry *entryPtr; -}; +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; -struct ScriptLimitCallbackKey { - Tcl_Interp *interp; - long type; +/* + * 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. */ }; /* - * Prototypes for local static procedures: + * 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 _ANSI_ARGS_((Tcl_Interp *interp, +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 _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Obj *namePtr)); -static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Tcl_Obj *objPtr)); -static int AliasList _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp)); -static int AliasObjCmd _ANSI_ARGS_((ClientData dummy, + 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 void AliasObjCmdDeleteProc _ANSI_ARGS_(( - ClientData clientData)); - -static Tcl_Interp * GetInterp _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr)); -static Tcl_Interp * GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static void InterpInfoDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); -static int SlaveBgerror _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, - Tcl_Obj *CONST objv[])); -static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr, int safe)); -static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, int objc, - Tcl_Obj *CONST objv[])); -static int SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp, + 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 int SlaveHide _ANSI_ARGS_((Tcl_Interp *interp, + 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 SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp)); -static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp, + 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 _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp)); -static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static void SlaveObjCmdDeleteProc _ANSI_ARGS_(( - ClientData clientData)); -static int SlaveRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, + 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 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *const objv[]); +static int SlaveCommandLimitCmd(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int consumedObjc, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveTimeLimitCmd _ANSI_ARGS_((Tcl_Interp *interp, + 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 _ANSI_ARGS_(( - Tcl_Interp *slaveInterp, - Tcl_Interp *masterInterp)); -static void SetScriptLimitCallback _ANSI_ARGS_((Tcl_Interp *interp, - int type, Tcl_Interp *targetInterp, - Tcl_Obj *scriptObj)); -static void CallScriptLimitCallback _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); -static void DeleteScriptLimitCallback _ANSI_ARGS_(( - ClientData clientData)); -static void RunLimitHandlers _ANSI_ARGS_((LimitHandler *handlerPtr, - Tcl_Interp *interp)); -static void TimeLimitCallback _ANSI_ARGS_((ClientData clientData)); + 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; /* @@ -267,11 +303,11 @@ static void TimeLimitCallback _ANSI_ARGS_((ClientData clientData)); *---------------------------------------------------------------------- */ -char * -TclSetPreInitScript (string) - char *string; /* Pointer to a script. */ +const char * +TclSetPreInitScript( + const char *string) /* Pointer to a script. */ { - char *prevString = tclPreInitScript; + const char *prevString = tclPreInitScript; tclPreInitScript = string; return(prevString); } @@ -281,7 +317,7 @@ TclSetPreInitScript (string) * * Tcl_Init -- * - * This procedure is typically invoked by Tcl_AppInit procedures to find + * 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. * @@ -296,40 +332,40 @@ TclSetPreInitScript (string) */ int -Tcl_Init(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ +Tcl_Init( + Tcl_Interp *interp) /* Interpreter to initialize. */ { if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (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: + * 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. + * 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 + * $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 + * 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 + * $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. @@ -343,11 +379,11 @@ Tcl_Init(interp) * will be set as the value of tcl_library. * * Note that this entire search mechanism can be bypassed by defining an - * alternate tclInit procedure before calling Tcl_Init(). + * alternate tclInit command before calling Tcl_Init(). */ return Tcl_Eval(interp, -"if {[info proc tclInit]==\"\"} {\n" +"if {[namespace which -command tclInit] eq \"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" " rename tclInit {}\n" @@ -417,8 +453,7 @@ Tcl_Init(interp) * TclInterpInit -- * * Initializes the invoking interpreter for using the master, slave and - * safe interp facilities. This is called from inside - * Tcl_CreateInterp(). + * safe interp facilities. This is called from inside Tcl_CreateInterp(). * * Results: * Always returns TCL_OK for backwards compatibility. @@ -431,15 +466,15 @@ Tcl_Init(interp) */ int -TclInterpInit(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ +TclInterpInit( + Tcl_Interp *interp) /* Interpreter to initialize. */ { InterpInfo *interpInfoPtr; Master *masterPtr; Slave *slavePtr; - interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); - ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr; + interpInfoPtr = ckalloc(sizeof(InterpInfo)); + ((Interp *) interp)->interpInfo = interpInfoPtr; masterPtr = &interpInfoPtr->master; Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS); @@ -452,7 +487,8 @@ TclInterpInit(interp) slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, + NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -463,7 +499,7 @@ TclInterpInit(interp) * * InterpInfoDeleteProc -- * - * Invoked when an interpreter is being deleted. It releases all storage + * Invoked when an interpreter is being deleted. It releases all storage * used by the master/slave/safe interpreter facilities. * * Results: @@ -476,9 +512,9 @@ TclInterpInit(interp) */ static void -InterpInfoDeleteProc(clientData, interp) - ClientData clientData; /* Ignored. */ - Tcl_Interp *interp; /* Interp being deleted. All commands for +InterpInfoDeleteProc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp) /* Interp being deleted. All commands for * slave interps should already be deleted. */ { InterpInfo *interpInfoPtr; @@ -534,7 +570,7 @@ InterpInfoDeleteProc(clientData, interp) } Tcl_DeleteHashTable(&slavePtr->aliasTable); - ckfree((char *) interpInfoPtr); + ckfree(interpInfoPtr); } /* @@ -542,8 +578,8 @@ InterpInfoDeleteProc(clientData, interp) * * Tcl_InterpObjCmd -- * - * This procedure is invoked to process the "interp" Tcl command. See - * the user documentation for details on what it does. + * 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. @@ -555,27 +591,40 @@ InterpInfoDeleteProc(clientData, interp) */ /* ARGSUSED */ int -Tcl_InterpObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Unused. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +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 *options[] = { - "alias", "aliases", "bgerror", "create", - "delete", "eval", "exists", "expose", - "hide", "hidden", "issafe", "invokehidden", - "limit", "marktrusted", "recursionlimit","slaves", - "share", "target", "transfer", + 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_CREATE, - 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 + 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) { @@ -588,30 +637,30 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) } switch ((enum option) index) { case OPT_ALIAS: { - Tcl_Interp *slaveInterp, *masterInterp; + Tcl_Interp *masterInterp; if (objc < 4) { aliasArgs: Tcl_WrongNumArgs(interp, 2, objv, - "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); + "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == (Tcl_Interp *) NULL) { + if (slaveInterp == NULL) { return TCL_ERROR; } if (objc == 4) { return AliasDescribe(interp, slaveInterp, objv[3]); } - if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) { + if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) { return AliasDelete(interp, slaveInterp, objv[3]); } if (objc > 5) { masterInterp = GetInterp(interp, objv[4]); - if (masterInterp == (Tcl_Interp *) NULL) { + if (masterInterp == NULL) { return TCL_ERROR; } - if (Tcl_GetString(objv[5])[0] == '\0') { + if (TclGetString(objv[5])[0] == '\0') { if (objc == 6) { return AliasDelete(interp, slaveInterp, objv[3]); } @@ -622,18 +671,13 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) } goto aliasArgs; } - case OPT_ALIASES: { - Tcl_Interp *slaveInterp; - + case OPT_ALIASES: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return AliasList(interp, slaveInterp); - } - case OPT_BGERROR: { - Tcl_Interp *slaveInterp; - + case OPT_BGERROR: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); return TCL_ERROR; @@ -643,13 +687,84 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) 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 + 2) < objc) { + 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 *options[] = { - "-safe", "--", NULL + static const char *const createOptions[] = { + "-safe", "--", NULL }; enum option { OPT_SAFE, OPT_LAST @@ -665,8 +780,8 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) last = 0; for (i = 2; i < objc; i++) { if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[i], createOptions, + "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (index == OPT_SAFE) { @@ -712,10 +827,23 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) 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; - Tcl_Interp *slaveInterp; for (i = 2; i < objc; i++) { slaveInterp = GetInterp(interp, objv[i]); @@ -724,6 +852,8 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) } 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; @@ -732,9 +862,7 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) } return TCL_OK; } - case OPT_EVAL: { - Tcl_Interp *slaveInterp; - + case OPT_EVAL: if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; @@ -744,12 +872,9 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_EXISTS: { - int exists; - Tcl_Interp *slaveInterp; + int exists = 1; - exists = 1; slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { if (objc > 3) { @@ -761,9 +886,7 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); return TCL_OK; } - case OPT_EXPOSE: { - Tcl_Interp *slaveInterp; - + case OPT_EXPOSE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); return TCL_ERROR; @@ -773,45 +896,34 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDE: { - Tcl_Interp *slaveInterp; /* A slave. */ - + 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 == (Tcl_Interp *) NULL) { + if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDDEN: { - Tcl_Interp *slaveInterp; /* A slave. */ - + case OPT_HIDDEN: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveHidden(interp, slaveInterp); - } - case OPT_ISSAFE: { - Tcl_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, index; - CONST char *namespaceName; - Tcl_Interp *slaveInterp; - static CONST char *hiddenOptions[] = { - "-global", "-namespace", "--", NULL + int i; + const char *namespaceName; + static const char *const hiddenOptions[] = { + "-global", "-namespace", "--", NULL }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST @@ -819,7 +931,7 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) namespaceName = NULL; for (i = 3; i < objc; i++) { - if (Tcl_GetString(objv[i])[0] != '-') { + if (TclGetString(objv[i])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", @@ -832,7 +944,7 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) if (++i == objc) { /* There must be more arguments. */ break; } else { - namespaceName = Tcl_GetString(objv[i]); + namespaceName = TclGetString(objv[i]); } } else { i++; @@ -845,15 +957,14 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == (Tcl_Interp *) NULL) { + if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, objv + i); } case OPT_LIMIT: { - Tcl_Interp *slaveInterp; - static CONST char *limitTypes[] = { + static const char *const limitTypes[] = { "commands", "time", NULL }; enum LimitTypes { @@ -862,7 +973,8 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) int limitType; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?"); + Tcl_WrongNumArgs(interp, 2, objv, + "path limitType ?-option value ...?"); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[2]); @@ -880,9 +992,7 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); } } - case OPT_MARKTRUSTED: { - Tcl_Interp *slaveInterp; - + case OPT_MARKTRUSTED: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; @@ -892,10 +1002,7 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } return SlaveMarkTrusted(interp, slaveInterp); - } - case OPT_RECLIMIT: { - Tcl_Interp *slaveInterp; - + case OPT_RECLIMIT: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); return TCL_ERROR; @@ -905,9 +1012,7 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_SLAVES: { - Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_Obj *resultPtr; Tcl_HashEntry *hPtr; @@ -929,9 +1034,9 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } + case OPT_TRANSFER: case OPT_SHARE: { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Interp *masterInterp; /* The master of the slave. */ Tcl_Channel chan; if (objc != 5) { @@ -942,9 +1047,9 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) if (masterInterp == NULL) { return TCL_ERROR; } - chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); + chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL); if (chan == NULL) { - TclTransferResult(masterInterp, TCL_OK, interp); + Tcl_TransferResult(masterInterp, TCL_OK, interp); return TCL_ERROR; } slaveInterp = GetInterp(interp, objv[4]); @@ -952,14 +1057,24 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) 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: { - Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; - char *aliasName; + const char *aliasName; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path alias"); @@ -971,50 +1086,25 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } - aliasName = Tcl_GetString(objv[3]); + aliasName = TclGetString(objv[3]); iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", - Tcl_GetString(objv[2]), "\" not found", (char *) 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 = (Alias *) Tcl_GetHashValue(hPtr); + aliasPtr = Tcl_GetHashValue(hPtr); if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "target interpreter for alias \"", - aliasName, "\" in path \"", Tcl_GetString(objv[2]), - "\" is not my descendant", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; - } - case OPT_TRANSFER: { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - 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, Tcl_GetString(objv[3]), NULL); - if (chan == NULL) { - TclTransferResult(masterInterp, TCL_OK, interp); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[4]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - TclTransferResult(masterInterp, TCL_OK, interp); + 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; @@ -1045,11 +1135,11 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) */ static Tcl_Interp * -GetInterp2(interp, objc, objv) - Tcl_Interp *interp; /* Default interp if no interp was specified +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. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc == 2) { return interp; @@ -1078,20 +1168,20 @@ GetInterp2(interp, objc, objv) */ int -Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) - 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_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 = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc); + 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]); @@ -1109,7 +1199,7 @@ Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) for (i = 0; i < argc; i++) { Tcl_DecrRefCount(objv[i]); } - ckfree((char *) objv); + TclStackFree(slaveInterp, objv); Tcl_DecrRefCount(targetObjPtr); Tcl_DecrRefCount(slaveObjPtr); @@ -1133,13 +1223,13 @@ Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) */ int -Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) - 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_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; @@ -1175,29 +1265,29 @@ Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) */ int -Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, - argvPtr) - 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. */ +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 *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; Tcl_HashEntry *hPtr; Alias *aliasPtr; int i, objc; Tcl_Obj **objv; - iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, - "\" not found", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + aliasPtr = Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; objv = &aliasPtr->objPtr; @@ -1205,16 +1295,16 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, *targetInterpPtr = aliasPtr->targetInterp; } if (targetNamePtr != NULL) { - *targetNamePtr = Tcl_GetString(objv[0]); + *targetNamePtr = TclGetString(objv[0]); } if (argcPtr != NULL) { *argcPtr = objc - 1; } if (argvPtr != NULL) { - *argvPtr = (CONST char **) - ckalloc((unsigned) sizeof(CONST char *) * (objc - 1)); + *argvPtr = (const char **) + ckalloc(sizeof(const char *) * (objc - 1)); for (i = 1; i < objc; i++) { - *argvPtr[i - 1] = Tcl_GetString(objv[i]); + (*argvPtr)[i - 1] = TclGetString(objv[i]); } } return TCL_OK; @@ -1237,42 +1327,42 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, */ int -Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, - objvPtr) - 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. */ +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 *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; Tcl_HashEntry *hPtr; Alias *aliasPtr; int objc; Tcl_Obj **objv; - iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", - (char *) NULL); + 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 = (Alias *) Tcl_GetHashValue(hPtr); + aliasPtr = Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; objv = &aliasPtr->objPtr; - if (targetInterpPtr != (Tcl_Interp **) NULL) { + if (targetInterpPtr != NULL) { *targetInterpPtr = aliasPtr->targetInterp; } - if (targetNamePtr != (CONST char **) NULL) { - *targetNamePtr = Tcl_GetString(objv[0]); + if (targetNamePtr != NULL) { + *targetNamePtr = TclGetString(objv[0]); } - if (objcPtr != (int *) NULL) { + if (objcPtr != NULL) { *objcPtr = objc - 1; } - if (objvPtr != (Tcl_Obj ***) NULL) { + if (objvPtr != NULL) { *objvPtr = objv + 1; } return TCL_OK; @@ -1301,12 +1391,11 @@ Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, */ int -TclPreventAliasLoop(interp, cmdInterp, cmd) - 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. */ +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; @@ -1328,7 +1417,7 @@ TclPreventAliasLoop(interp, cmdInterp, cmd) * chain then we have a loop. */ - aliasPtr = (Alias *) cmdPtr->objClientData; + aliasPtr = cmdPtr->objClientData; nextAliasPtr = aliasPtr; while (1) { Tcl_Obj *cmdNamePtr; @@ -1344,24 +1433,26 @@ TclPreventAliasLoop(interp, cmdInterp, cmd) * [Bug #641195] */ - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": interpreter deleted", (char *) NULL); + 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, - Tcl_GetString(cmdNamePtr), + TclGetString(cmdNamePtr), Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), /*flags*/ 0); - if (aliasCmd == (Tcl_Command) NULL) { + if (aliasCmd == NULL) { return TCL_OK; } aliasCmdPtr = (Command *) aliasCmd; if (aliasCmdPtr == cmdPtr) { - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": would create a loop", (char *) NULL); + 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; } @@ -1374,7 +1465,7 @@ TclPreventAliasLoop(interp, cmdInterp, cmd) if (aliasCmdPtr->objProc != AliasObjCmd) { return TCL_OK; } - nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; + nextAliasPtr = aliasCmdPtr->objClientData; } /* NOTREACHED */ @@ -1398,17 +1489,16 @@ TclPreventAliasLoop(interp, cmdInterp, cmd) */ static int -AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, - objc, objv) - Tcl_Interp *interp; /* Interp for error reporting. */ - Tcl_Interp *slaveInterp; /* Interp where alias cmd will live or from +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 + 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. */ + 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; @@ -1416,10 +1506,9 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, Slave *slavePtr; Master *masterPtr; Tcl_Obj **prefv; - int new, i; + int isNew, i; - aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) - + objc * sizeof(Tcl_Obj *))); + aliasPtr = ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); aliasPtr->targetInterp = masterInterp; @@ -1437,17 +1526,23 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, 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, - Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr, + 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. + * 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; @@ -1464,7 +1559,7 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); - ckfree((char *) aliasPtr); + ckfree(aliasPtr); /* * The result was already set by TclPreventAliasLoop. @@ -1482,11 +1577,11 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; while (1) { Tcl_Obj *newToken; - char *string; + const char *string; - string = Tcl_GetString(aliasPtr->token); - hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new); - if (new != 0) { + string = TclGetString(aliasPtr->token); + hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew); + if (isNew != 0) { break; } @@ -1502,7 +1597,7 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, * on the precise definition of these tokens. */ - newToken = Tcl_NewStringObj("::",-1); + TclNewLiteralStringObj(newToken, "::"); Tcl_AppendObjToObj(newToken, aliasPtr->token); Tcl_DecrRefCount(aliasPtr->token); aliasPtr->token = newToken; @@ -1510,7 +1605,7 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, } aliasPtr->aliasEntryPtr = hPtr; - Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); + Tcl_SetHashValue(hPtr, aliasPtr); /* * Create the new command. We must do it after deleting any old command, @@ -1521,11 +1616,11 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, * interp alias {} foo {} zop # Now recreate "foo"... */ - targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); + targetPtr = ckalloc(sizeof(Target)); targetPtr->slaveCmd = aliasPtr->slaveCmd; targetPtr->slaveInterp = slaveInterp; - masterPtr = &((InterpInfo *) ((Interp*) masterInterp)->interpInfo)->master; + masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master; targetPtr->nextPtr = masterPtr->targetsPtr; targetPtr->prevPtr = NULL; if (masterPtr->targetsPtr != NULL) { @@ -1558,10 +1653,10 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, */ static int -AliasDelete(interp, slaveInterp, namePtr) - Tcl_Interp *interp; /* Interpreter for result & errors. */ - Tcl_Interp *slaveInterp; /* Interpreter containing alias. */ - Tcl_Obj *namePtr; /* Name of alias to delete. */ +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; @@ -1574,13 +1669,15 @@ AliasDelete(interp, slaveInterp, namePtr) */ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; - hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); + hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", Tcl_GetString(namePtr), - "\" not found", 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 = (Alias *) Tcl_GetHashValue(hPtr); + aliasPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); return TCL_OK; } @@ -1604,10 +1701,10 @@ AliasDelete(interp, slaveInterp, namePtr) */ static int -AliasDescribe(interp, slaveInterp, namePtr) - Tcl_Interp *interp; /* Interpreter for result & errors. */ - Tcl_Interp *slaveInterp; /* Interpreter containing alias. */ - Tcl_Obj *namePtr; /* Name of alias to describe. */ +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; @@ -1625,7 +1722,7 @@ AliasDescribe(interp, slaveInterp, namePtr) if (hPtr == NULL) { return TCL_OK; } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + aliasPtr = Tcl_GetHashValue(hPtr); prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr); Tcl_SetObjResult(interp, prefixPtr); return TCL_OK; @@ -1648,9 +1745,9 @@ AliasDescribe(interp, slaveInterp, namePtr) */ static int -AliasList(interp, slaveInterp) - Tcl_Interp *interp; /* Interp for data return. */ - Tcl_Interp *slaveInterp; /* Interp whose aliases to compute. */ +AliasList( + Tcl_Interp *interp, /* Interp for data return. */ + Tcl_Interp *slaveInterp) /* Interp whose aliases to compute. */ { Tcl_HashEntry *entryPtr; Tcl_HashSearch hashSearch; @@ -1662,7 +1759,7 @@ AliasList(interp, slaveInterp) entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { - aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr); + aliasPtr = Tcl_GetHashValue(entryPtr); Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); } Tcl_SetObjResult(interp, resultPtr); @@ -1674,9 +1771,9 @@ AliasList(interp, slaveInterp) * * AliasObjCmd -- * - * This is the procedure that services invocations of aliases in a slave + * This is the function that services invocations of aliases in a slave * interpreter. One such command exists for each alias. When invoked, - * this procedure redirects the invocation to the target command in the + * this function redirects the invocation to the target command in the * master interpreter as designated by the Alias record associated with * this command. * @@ -1692,20 +1789,84 @@ AliasList(interp, slaveInterp) */ static int -AliasObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Alias record. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument vector. */ +AliasNRCmd( + ClientData clientData, /* Alias record. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument vector. */ +{ + Interp *iPtr = (Interp *) interp; + Alias *aliasPtr = clientData; + int prefc, cmdc, i; + Tcl_Obj **prefv, **cmdv; + int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); + 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 (isRootEnsemble) { + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = 1; + iPtr->ensembleRewrite.numInsertedObjs = prefc; + } else { + iPtr->ensembleRewrite.numInsertedObjs += prefc - 1; + } + + /* + * We are sending a 0-refCount obj, do not need a callback: it will be + * cleaned up automatically. But we may need to clear the rootEnsemble + * stuff ... + */ + + if (isRootEnsemble) { + 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 - Tcl_Interp *targetInterp; - Alias *aliasPtr; + Alias *aliasPtr = clientData; + Tcl_Interp *targetInterp = aliasPtr->targetInterp; int result, prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; - aliasPtr = (Alias *) clientData; - targetInterp = aliasPtr->targetInterp; + Interp *tPtr = (Interp *) targetInterp; + int isRootEnsemble = (tPtr->ensembleRewrite.sourceObjs == NULL); /* * Append the arguments to the command prefix and invoke the command in @@ -1718,34 +1879,74 @@ AliasObjCmd(clientData, interp, objc, objv) if (cmdc <= ALIAS_CMDV_PREALLOC) { cmdv = cmdArr; } else { - cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *))); + cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); } prefv = &aliasPtr->objPtr; - memcpy((VOID *) cmdv, (VOID *) prefv, - (size_t) (prefc * sizeof(Tcl_Obj *))); - memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), - (size_t) ((objc-1) * 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]); } - if (targetInterp != interp) { - Tcl_Preserve((ClientData) targetInterp); - result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); - TclTransferResult(targetInterp, result, interp); - Tcl_Release((ClientData) targetInterp); + + /* + * Use the ensemble rewriting machinery to ensure correct error messages: + * only the source command should show, not the full target prefix. + */ + + if (isRootEnsemble) { + tPtr->ensembleRewrite.sourceObjs = objv; + tPtr->ensembleRewrite.numRemovedObjs = 1; + tPtr->ensembleRewrite.numInsertedObjs = prefc; } else { - result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); + tPtr->ensembleRewrite.numInsertedObjs += prefc - 1; + } + + /* + * 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) { + tPtr->ensembleRewrite.sourceObjs = NULL; + tPtr->ensembleRewrite.numRemovedObjs = 0; + tPtr->ensembleRewrite.numInsertedObjs = 0; + } + + /* + * 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) { - ckfree((char *) cmdv); + TclStackFree(interp, cmdv); } return result; #undef ALIAS_CMDV_PREALLOC @@ -1770,16 +1971,14 @@ AliasObjCmd(clientData, interp, objc, objv) */ static void -AliasObjCmdDeleteProc(clientData) - ClientData clientData; /* The alias record for this alias. */ +AliasObjCmdDeleteProc( + ClientData clientData) /* The alias record for this alias. */ { - Alias *aliasPtr; + Alias *aliasPtr = clientData; Target *targetPtr; int i; Tcl_Obj **objv; - aliasPtr = (Alias *) clientData; - Tcl_DecrRefCount(aliasPtr->token); objv = &aliasPtr->objPtr; for (i = 0; i < aliasPtr->objc; i++) { @@ -1797,14 +1996,15 @@ AliasObjCmdDeleteProc(clientData) } else { Master *masterPtr = &((InterpInfo *) ((Interp *) aliasPtr->targetInterp)->interpInfo)->master; + masterPtr->targetsPtr = targetPtr->nextPtr; } if (targetPtr->nextPtr != NULL) { targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; } - ckfree((char *) targetPtr); - ckfree((char *) aliasPtr); + ckfree(targetPtr); + ckfree(aliasPtr); } /* @@ -1831,10 +2031,10 @@ AliasObjCmdDeleteProc(clientData) */ Tcl_Interp * -Tcl_CreateSlave(interp, slavePath, isSafe) - Tcl_Interp *interp; /* Interpreter to start search at. */ - CONST char *slavePath; /* Name of slave to create. */ - int isSafe; /* Should new slave be "safe" ? */ +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; @@ -1863,9 +2063,9 @@ Tcl_CreateSlave(interp, slavePath, isSafe) */ Tcl_Interp * -Tcl_GetSlave(interp, slavePath) - Tcl_Interp *interp; /* Interpreter to start search from. */ - CONST char *slavePath; /* Path of slave to find. */ +Tcl_GetSlave( + Tcl_Interp *interp, /* Interpreter to start search from. */ + const char *slavePath) /* Path of slave to find. */ { Tcl_Obj *pathPtr; Tcl_Interp *slaveInterp; @@ -1894,12 +2094,12 @@ Tcl_GetSlave(interp, slavePath) */ Tcl_Interp * -Tcl_GetMaster(interp) - Tcl_Interp *interp; /* Get the master of this interpreter. */ +Tcl_GetMaster( + Tcl_Interp *interp) /* Get the master of this interpreter. */ { Slave *slavePtr; /* Slave record of this interpreter. */ - if (interp == (Tcl_Interp *) NULL) { + if (interp == NULL) { return NULL; } slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; @@ -1909,6 +2109,72 @@ Tcl_GetMaster(interp) /* *---------------------------------------------------------------------- * + * 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 @@ -1931,24 +2197,26 @@ Tcl_GetMaster(interp) */ int -Tcl_GetInterpPath(askingInterp, targetInterp) - Tcl_Interp *askingInterp; /* Interpreter to start search from. */ - Tcl_Interp *targetInterp; /* Interpreter to find. */ +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) { + if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){ return TCL_ERROR; } - Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable, - iiPtr->slave.slaveEntryPtr)); + Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp), + Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->master.slaveTable, + iiPtr->slave.slaveEntryPtr), -1)); return TCL_OK; } @@ -1970,9 +2238,9 @@ Tcl_GetInterpPath(askingInterp, targetInterp) */ static Tcl_Interp * -GetInterp(interp, pathPtr) - Tcl_Interp *interp; /* Interp. to start search from. */ - Tcl_Obj *pathPtr; /* List object containing name of interp. to +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. */ @@ -1982,7 +2250,7 @@ GetInterp(interp, pathPtr) Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ InterpInfo *masterInfoPtr; - if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { + if (TclListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; } @@ -1990,20 +2258,22 @@ GetInterp(interp, pathPtr) for (i = 0; i < objc; i++) { masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, - Tcl_GetString(objv[i])); + TclGetString(objv[i])); if (hPtr == NULL) { searchInterp = NULL; break; } - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + slavePtr = Tcl_GetHashValue(hPtr); searchInterp = slavePtr->slaveInterp; if (searchInterp == NULL) { break; } } if (searchInterp == NULL) { - Tcl_AppendResult(interp, "could not find interpreter \"", - Tcl_GetString(pathPtr), "\"", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not find interpreter \"%s\"", TclGetString(pathPtr))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP", + TclGetString(pathPtr), NULL); } return searchInterp; } @@ -2027,24 +2297,26 @@ GetInterp(interp, pathPtr) */ static int -SlaveBgerror(interp, slaveInterp, objc, objv) - 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. */ +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 == Tcl_ListObjLength(NULL, objv[0], &length) + if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { - Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", - (char *) NULL); + 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(interp, objv[0]); + TclSetBgErrorHandler(slaveInterp, objv[0]); } - Tcl_SetObjResult(interp, TclGetBgErrorHandler(interp)); + Tcl_SetObjResult(interp, TclGetBgErrorHandler(slaveInterp)); return TCL_OK; } @@ -2068,17 +2340,17 @@ SlaveBgerror(interp, slaveInterp, objc, objv) */ static Tcl_Interp * -SlaveCreate(interp, pathPtr, safe) - Tcl_Interp *interp; /* Interp. to start search from. */ - Tcl_Obj *pathPtr; /* Path (name) of slave to create. */ - int safe; /* Should we make it "safe"? */ +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; - char *path; - int new, objc; + const char *path; + int isNew, objc; Tcl_Obj **objv; if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { @@ -2086,7 +2358,7 @@ SlaveCreate(interp, pathPtr, safe) } if (objc < 2) { masterInterp = interp; - path = Tcl_GetString(pathPtr); + path = TclGetString(pathPtr); } else { Tcl_Obj *objPtr; @@ -2096,17 +2368,19 @@ SlaveCreate(interp, pathPtr, safe) if (masterInterp == NULL) { return NULL; } - path = Tcl_GetString(objv[objc - 1]); + path = TclGetString(objv[objc - 1]); } if (safe == 0) { safe = Tcl_IsSafe(masterInterp); } masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; - hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new); - if (new == 0) { - Tcl_AppendResult(interp, "interpreter named \"", path, - "\" already exists, cannot create", (char *) NULL); + 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; } @@ -2115,10 +2389,10 @@ SlaveCreate(interp, pathPtr, safe) slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc); + slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, + SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_SetHashValue(hPtr, (ClientData) slavePtr); + Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); /* @@ -2151,13 +2425,20 @@ SlaveCreate(interp, pathPtr, safe) 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 = Tcl_NewStringObj("clock", -1); + Tcl_Obj *clockObj; int status; + TclNewLiteralStringObj(clockObj, "clock"); Tcl_IncrRefCount(clockObj); status = AliasCreate(interp, slaveInterp, masterInterp, clockObj, - clockObj, 0, (Tcl_Obj *CONST *) NULL); + clockObj, 0, NULL); Tcl_DecrRefCount(clockObj); if (status != TCL_OK) { goto error2; @@ -2166,9 +2447,9 @@ SlaveCreate(interp, pathPtr, safe) return slaveInterp; - error: - TclTransferResult(slaveInterp, TCL_ERROR, interp); - error2: + error: + Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); + error2: Tcl_DeleteInterp(slaveInterp); return NULL; @@ -2192,26 +2473,37 @@ SlaveCreate(interp, pathPtr, safe) */ static int -SlaveObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Slave interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +SlaveObjCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Interp *slaveInterp; + 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 *options[] = { - "alias", "aliases", "bgerror", "eval", - "expose", "hide", "hidden", "issafe", - "invokehidden", "limit", "marktrusted", "recursionlimit", NULL + 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_EVAL, - OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, - OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT + 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 }; - slaveInterp = (Tcl_Interp *) clientData; if (slaveInterp == NULL) { Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); } @@ -2231,7 +2523,7 @@ SlaveObjCmd(clientData, interp, objc, objv) if (objc == 3) { return AliasDescribe(interp, slaveInterp, objv[2]); } - if (Tcl_GetString(objv[3])[0] == '\0') { + if (TclGetString(objv[3])[0] == '\0') { if (objc == 4) { return AliasDelete(interp, slaveInterp, objv[2]); } @@ -2240,11 +2532,11 @@ SlaveObjCmd(clientData, interp, objc, objv) objv[3], objc - 4, objv + 4); } } - Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?args..?"); + Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?arg ...?"); return TCL_ERROR; case OPT_ALIASES: if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); + Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } return AliasList(interp, slaveInterp); @@ -2254,6 +2546,16 @@ SlaveObjCmd(clientData, interp, objc, objv) 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 ...?"); @@ -2280,17 +2582,16 @@ SlaveObjCmd(clientData, interp, objc, objv) return SlaveHidden(interp, slaveInterp); case OPT_ISSAFE: if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); + 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, index; - CONST char *namespaceName; - static CONST char *hiddenOptions[] = { - "-global", "-namespace", "--", - NULL + int i; + const char *namespaceName; + static const char *const hiddenOptions[] = { + "-global", "-namespace", "--", NULL }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST @@ -2298,7 +2599,7 @@ SlaveObjCmd(clientData, interp, objc, objv) namespaceName = NULL; for (i = 2; i < objc; i++) { - if (Tcl_GetString(objv[i])[0] != '-') { + if (TclGetString(objv[i])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", @@ -2311,7 +2612,7 @@ SlaveObjCmd(clientData, interp, objc, objv) if (++i == objc) { /* There must be more arguments. */ break; } else { - namespaceName = Tcl_GetString(objv[i]); + namespaceName = TclGetString(objv[i]); } } else { i++; @@ -2327,7 +2628,7 @@ SlaveObjCmd(clientData, interp, objc, objv) objc - i, objv + i); } case OPT_LIMIT: { - static CONST char *limitTypes[] = { + static const char *const limitTypes[] = { "commands", "time", NULL }; enum LimitTypes { @@ -2336,7 +2637,7 @@ SlaveObjCmd(clientData, interp, objc, objv) int limitType; if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?"); + Tcl_WrongNumArgs(interp, 2, objv, "limitType ?-option value ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, @@ -2387,13 +2688,13 @@ SlaveObjCmd(clientData, interp, objc, objv) */ static void -SlaveObjCmdDeleteProc(clientData) - ClientData clientData; /* The SlaveRecord for the command. */ +SlaveObjCmdDeleteProc( + ClientData clientData) /* The SlaveRecord for the command. */ { - Slave *slavePtr; /* Interim storage for Slave record. */ - Tcl_Interp *slaveInterp; /* And for a slave interp. */ + Slave *slavePtr; /* Interim storage for Slave record. */ + Tcl_Interp *slaveInterp = clientData; + /* And for a slave interp. */ - slaveInterp = (Tcl_Interp *) clientData; slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; /* @@ -2404,7 +2705,7 @@ SlaveObjCmdDeleteProc(clientData) /* * 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 + * does not try to delete the command causing all sorts of grief. See * SlaveRecordDeleteProc(). */ @@ -2418,6 +2719,77 @@ SlaveObjCmdDeleteProc(clientData) /* *---------------------------------------------------------------------- * + * 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. @@ -2432,30 +2804,49 @@ SlaveObjCmdDeleteProc(clientData) */ static int -SlaveEval(interp, slaveInterp, objc, objv) - Tcl_Interp *interp; /* Interp for error return. */ - Tcl_Interp *slaveInterp; /* The slave interpreter in which command +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 objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int result; - Tcl_Obj *objPtr; - Tcl_Preserve((ClientData) slaveInterp); + /* + * 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) { - result = Tcl_EvalObjEx(slaveInterp, objv[0], 0); + /* + * 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 { - objPtr = Tcl_ConcatObj(objc, objv); + Tcl_Obj *objPtr = Tcl_ConcatObj(objc, objv); Tcl_IncrRefCount(objPtr); result = Tcl_EvalObjEx(slaveInterp, objPtr, 0); Tcl_DecrRefCount(objPtr); } - TclTransferResult(slaveInterp, result, interp); + Tcl_TransferResult(slaveInterp, result, interp); - Tcl_Release((ClientData) slaveInterp); + Tcl_Release(slaveInterp); return result; } @@ -2477,25 +2868,27 @@ SlaveEval(interp, slaveInterp, objc, objv) */ static int -SlaveExpose(interp, slaveInterp, objc, objv) - 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. */ +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. */ { - char *name; + 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 = Tcl_GetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_ExposeCommand(slaveInterp, Tcl_GetString(objv[0]), + name = TclGetString(objv[(objc == 1) ? 0 : 1]); + if (Tcl_ExposeCommand(slaveInterp, TclGetString(objv[0]), name) != TCL_OK) { - TclTransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); return TCL_ERROR; } return TCL_OK; @@ -2519,28 +2912,31 @@ SlaveExpose(interp, slaveInterp, objc, objv) */ static int -SlaveRecursionLimit(interp, slaveInterp, objc, objv) - 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. */ +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_AppendResult(interp, "permission denied: ", - "safe interpreters cannot change recursion limit", - (char *) NULL); + 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 (Tcl_GetIntFromObj(interp, objv[0], &limit) == 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); @@ -2548,6 +2944,7 @@ SlaveRecursionLimit(interp, slaveInterp, objc, objv) 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]); @@ -2577,24 +2974,26 @@ SlaveRecursionLimit(interp, slaveInterp, objc, objv) */ static int -SlaveHide(interp, slaveInterp, objc, objv) - 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. */ +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. */ { - char *name; + 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 = Tcl_GetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]), name) != TCL_OK) { - TclTransferResult(slaveInterp, TCL_ERROR, interp); + 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; @@ -2618,9 +3017,9 @@ SlaveHide(interp, slaveInterp, objc, objv) */ static int -SlaveHidden(interp, slaveInterp) - Tcl_Interp *interp; /* Interp for data return. */ - Tcl_Interp *slaveInterp; /* Interp whose hidden commands to query. */ +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. */ @@ -2628,9 +3027,9 @@ SlaveHidden(interp, slaveInterp) Tcl_HashSearch hSearch; /* For local searches. */ hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; - if (hTblPtr != (Tcl_HashTable *) NULL) { + if (hTblPtr != NULL) { for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; + hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { Tcl_ListObjAppendElement(NULL, listObjPtr, Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); @@ -2657,13 +3056,13 @@ SlaveHidden(interp, slaveInterp) */ static int -SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) - Tcl_Interp *interp; /* Interp for error return. */ - Tcl_Interp *slaveInterp; /* The slave interpreter in which command will +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. */ + const char *namespaceName, /* The namespace to use, if any. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int result; @@ -2671,31 +3070,53 @@ SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) 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((ClientData) slaveInterp); + Tcl_Preserve(slaveInterp); Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + 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; + const char *tail; - result = TclGetNamespaceForQualName(slaveInterp, namespaceName, - (Namespace *) NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY - | TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, - &dummy1, &dummy2, &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_Namespace *) nsPtr, TCL_INVOKE_HIDDEN); } } - TclTransferResult(slaveInterp, result, interp); + 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]; - Tcl_Release((ClientData) slaveInterp); + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } + Tcl_Release(slaveInterp); return result; } @@ -2717,15 +3138,17 @@ SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) */ static int -SlaveMarkTrusted(interp, slaveInterp) - Tcl_Interp *interp; /* Interp for error return. */ - Tcl_Interp *slaveInterp; /* The slave interpreter which will be marked +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; @@ -2749,17 +3172,15 @@ SlaveMarkTrusted(interp, slaveInterp) */ int -Tcl_IsSafe(interp) - Tcl_Interp *interp; /* Is this interpreter "safe" ? */ +Tcl_IsSafe( + Tcl_Interp *interp) /* Is this interpreter "safe" ? */ { - Interp *iPtr; + Interp *iPtr = (Interp *) interp; - if (interp == (Tcl_Interp *) NULL) { + if (iPtr == NULL) { return 0; } - iPtr = (Interp *) interp; - - return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ; + return (iPtr->flags & SAFE_INTERP) ? 1 : 0; } /* @@ -2782,14 +3203,31 @@ Tcl_IsSafe(interp) */ int -Tcl_MakeSafe(interp) - Tcl_Interp *interp; /* Interpreter to be made safe. */ +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; /* @@ -2832,15 +3270,15 @@ Tcl_MakeSafe(interp) */ chan = Tcl_GetStdChannel(TCL_STDIN); - if (chan != (Tcl_Channel) NULL) { + if (chan != NULL) { Tcl_UnregisterChannel(interp, chan); } chan = Tcl_GetStdChannel(TCL_STDOUT); - if (chan != (Tcl_Channel) NULL) { + if (chan != NULL) { Tcl_UnregisterChannel(interp, chan); } chan = Tcl_GetStdChannel(TCL_STDERR); - if (chan != (Tcl_Channel) NULL) { + if (chan != NULL) { Tcl_UnregisterChannel(interp, chan); } @@ -2862,12 +3300,15 @@ Tcl_MakeSafe(interp) * Side effects: * None. * + * Notes: + * If you change this function, you MUST also update TclLimitExceeded() in + * tclInt.h. *---------------------------------------------------------------------- */ int -Tcl_LimitExceeded(interp) - Tcl_Interp *interp; +Tcl_LimitExceeded( + Tcl_Interp *interp) { register Interp *iPtr = (Interp *) interp; @@ -2889,12 +3330,16 @@ Tcl_LimitExceeded(interp) * Side effects: * Increments the limit granularity counter. * + * Notes: + * If you change this function, you MUST also update TclLimitReady() in + * tclInt.h. + * *---------------------------------------------------------------------- */ int -Tcl_LimitReady(interp) - Tcl_Interp *interp; +Tcl_LimitReady( + Tcl_Interp *interp) { register Interp *iPtr = (Interp *) interp; @@ -2921,7 +3366,7 @@ Tcl_LimitReady(interp) * 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 + * 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. @@ -2939,8 +3384,8 @@ Tcl_LimitReady(interp) */ int -Tcl_LimitCheck(interp) - Tcl_Interp *interp; +Tcl_LimitCheck( + Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; register int ticker = iPtr->limit.granularityTicker; @@ -2959,8 +3404,9 @@ Tcl_LimitCheck(interp) if (iPtr->limit.cmdCount >= iPtr->cmdCount) { iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "command count limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command count limit exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -2984,8 +3430,9 @@ Tcl_LimitCheck(interp) iPtr->limit.time.usec >= now.usec)) { iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "time limit exceeded", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "time limit exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -3015,9 +3462,9 @@ Tcl_LimitCheck(interp) */ static void -RunLimitHandlers(handlerPtr, interp) - LimitHandler *handlerPtr; - Tcl_Interp *interp; +RunLimitHandlers( + LimitHandler *handlerPtr, + Tcl_Interp *interp) { LimitHandler *nextPtr; for (; handlerPtr!=NULL ; handlerPtr=nextPtr) { @@ -3038,12 +3485,12 @@ RunLimitHandlers(handlerPtr, interp) */ handlerPtr->flags |= LIMIT_HANDLER_ACTIVE; - (handlerPtr->handlerProc)(handlerPtr->clientData, interp); + 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 + * 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.) @@ -3059,9 +3506,9 @@ RunLimitHandlers(handlerPtr, interp) if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { if (handlerPtr->deleteProc != NULL) { - (handlerPtr->deleteProc)(handlerPtr->clientData); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } } @@ -3083,12 +3530,12 @@ RunLimitHandlers(handlerPtr, interp) */ void -Tcl_LimitAddHandler(interp, type, handlerProc, clientData, deleteProc) - Tcl_Interp *interp; - int type; - Tcl_LimitHandlerProc *handlerProc; - ClientData clientData; - Tcl_LimitHandlerDeleteProc *deleteProc; +Tcl_LimitAddHandler( + Tcl_Interp *interp, + int type, + Tcl_LimitHandlerProc *handlerProc, + ClientData clientData, + Tcl_LimitHandlerDeleteProc *deleteProc) { Interp *iPtr = (Interp *) interp; LimitHandler *handlerPtr; @@ -3101,14 +3548,14 @@ Tcl_LimitAddHandler(interp, type, handlerProc, clientData, deleteProc) deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free; } if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) { - deleteProc = (Tcl_LimitHandlerDeleteProc *) NULL; + deleteProc = NULL; } /* * Allocate a handler record. */ - handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler)); + handlerPtr = ckalloc(sizeof(LimitHandler)); handlerPtr->flags = 0; handlerPtr->handlerProc = handlerProc; handlerPtr->clientData = clientData; @@ -3152,7 +3599,7 @@ Tcl_LimitAddHandler(interp, type, handlerProc, clientData, deleteProc) * * 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 + * and if not currently being invoked, deleted. Otherwise it is just * marked for deletion and removed when the limit handler has finished * executing. * @@ -3160,11 +3607,11 @@ Tcl_LimitAddHandler(interp, type, handlerProc, clientData, deleteProc) */ void -Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData) - Tcl_Interp *interp; - int type; - Tcl_LimitHandlerProc *handlerProc; - ClientData clientData; +Tcl_LimitRemoveHandler( + Tcl_Interp *interp, + int type, + Tcl_LimitHandlerProc *handlerProc, + ClientData clientData) { Interp *iPtr = (Interp *) interp; LimitHandler *handlerPtr; @@ -3219,15 +3666,15 @@ Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData) /* * If nothing is currently executing the handler, delete its client - * data and the overall handler structure now. Otherwise it will all + * 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); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } return; } @@ -3252,8 +3699,8 @@ Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData) */ void -TclLimitRemoveAllHandlers(interp) - Tcl_Interp *interp; +TclLimitRemoveAllHandlers( + Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; LimitHandler *handlerPtr, *nextHandlerPtr; @@ -3279,15 +3726,15 @@ TclLimitRemoveAllHandlers(interp) /* * If nothing is currently executing the handler, delete its client - * data and the overall handler structure now. Otherwise it will all + * 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); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } @@ -3312,15 +3759,15 @@ TclLimitRemoveAllHandlers(interp) /* * If nothing is currently executing the handler, delete its client - * data and the overall handler structure now. Otherwise it will all + * 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); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } @@ -3352,9 +3799,9 @@ TclLimitRemoveAllHandlers(interp) */ int -Tcl_LimitTypeEnabled(interp, type) - Tcl_Interp *interp; - int type; +Tcl_LimitTypeEnabled( + Tcl_Interp *interp, + int type) { Interp *iPtr = (Interp *) interp; @@ -3379,9 +3826,9 @@ Tcl_LimitTypeEnabled(interp, type) */ int -Tcl_LimitTypeExceeded(interp, type) - Tcl_Interp *interp; - int type; +Tcl_LimitTypeExceeded( + Tcl_Interp *interp, + int type) { Interp *iPtr = (Interp *) interp; @@ -3407,9 +3854,9 @@ Tcl_LimitTypeExceeded(interp, type) */ void -Tcl_LimitTypeSet(interp, type) - Tcl_Interp *interp; - int type; +Tcl_LimitTypeSet( + Tcl_Interp *interp, + int type) { Interp *iPtr = (Interp *) interp; @@ -3427,7 +3874,7 @@ Tcl_LimitTypeSet(interp, type) * None. * * Side effects: - * The limit is disabled. If the limit was exceeded when this function + * 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). @@ -3436,9 +3883,9 @@ Tcl_LimitTypeSet(interp, type) */ void -Tcl_LimitTypeReset(interp, type) - Tcl_Interp *interp; - int type; +Tcl_LimitTypeReset( + Tcl_Interp *interp, + int type) { Interp *iPtr = (Interp *) interp; @@ -3457,7 +3904,7 @@ Tcl_LimitTypeReset(interp, type) * None. * * Side effects: - * Also resets whether the command limit was exceeded. This might permit + * 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. * @@ -3465,9 +3912,9 @@ Tcl_LimitTypeReset(interp, type) */ void -Tcl_LimitSetCommands(interp, commandLimit) - Tcl_Interp *interp; - int commandLimit; +Tcl_LimitSetCommands( + Tcl_Interp *interp, + int commandLimit) { Interp *iPtr = (Interp *) interp; @@ -3493,8 +3940,8 @@ Tcl_LimitSetCommands(interp, commandLimit) */ int -Tcl_LimitGetCommands(interp) - Tcl_Interp *interp; +Tcl_LimitGetCommands( + Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; @@ -3513,7 +3960,7 @@ Tcl_LimitGetCommands(interp) * None. * * Side effects: - * Also resets whether the time limit was exceeded. This might permit a + * 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. * @@ -3521,9 +3968,9 @@ Tcl_LimitGetCommands(interp) */ void -Tcl_LimitSetTime(interp, timeLimitPtr) - Tcl_Interp *interp; - Tcl_Time *timeLimitPtr; +Tcl_LimitSetTime( + Tcl_Interp *interp, + Tcl_Time *timeLimitPtr) { Interp *iPtr = (Interp *) interp; Tcl_Time nextMoment; @@ -3539,8 +3986,8 @@ Tcl_LimitSetTime(interp, timeLimitPtr) nextMoment.usec -= 1000000; } iPtr->limit.timeEvent = TclCreateAbsoluteTimerHandler(&nextMoment, - TimeLimitCallback, (ClientData) interp); - iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; + TimeLimitCallback, interp); + iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } /* @@ -3562,18 +4009,30 @@ Tcl_LimitSetTime(interp, timeLimitPtr) */ static void -TimeLimitCallback(clientData) - ClientData clientData; +TimeLimitCallback( + ClientData clientData) { - Tcl_Interp *interp = (Tcl_Interp *) 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] + */ - Tcl_Preserve((ClientData) interp); - ((Interp *)interp)->limit.timeEvent = NULL; - if (Tcl_LimitCheck(interp) != TCL_OK) { + iPtr->limit.granularityTicker = 0; + + code = Tcl_LimitCheck(interp); + if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (while waiting for event)"); - Tcl_BackgroundError(interp); + Tcl_BackgroundException(interp, code); } - Tcl_Release((ClientData) interp); + Tcl_Release(interp); } /* @@ -3594,9 +4053,9 @@ TimeLimitCallback(clientData) */ void -Tcl_LimitGetTime(interp, timeLimitPtr) - Tcl_Interp *interp; - Tcl_Time *timeLimitPtr; +Tcl_LimitGetTime( + Tcl_Interp *interp, + Tcl_Time *timeLimitPtr) { Interp *iPtr = (Interp *) interp; @@ -3621,10 +4080,10 @@ Tcl_LimitGetTime(interp, timeLimitPtr) */ void -Tcl_LimitSetGranularity(interp, type, granularity) - Tcl_Interp *interp; - int type; - int granularity; +Tcl_LimitSetGranularity( + Tcl_Interp *interp, + int type, + int granularity) { Interp *iPtr = (Interp *) interp; if (granularity < 1) { @@ -3659,9 +4118,9 @@ Tcl_LimitSetGranularity(interp, type, granularity) */ int -Tcl_LimitGetGranularity(interp, type) - Tcl_Interp *interp; - int type; +Tcl_LimitGetGranularity( + Tcl_Interp *interp, + int type) { Interp *iPtr = (Interp *) interp; @@ -3694,15 +4153,16 @@ Tcl_LimitGetGranularity(interp, type) */ static void -DeleteScriptLimitCallback(clientData) - ClientData clientData; +DeleteScriptLimitCallback( + ClientData clientData) { - struct ScriptLimitCallback *limitCBPtr = - (struct ScriptLimitCallback *) clientData; + ScriptLimitCallback *limitCBPtr = clientData; Tcl_DecrRefCount(limitCBPtr->scriptObj); - Tcl_DeleteHashEntry(limitCBPtr->entryPtr); - ckfree((char *) limitCBPtr); + if (limitCBPtr->entryPtr != NULL) { + Tcl_DeleteHashEntry(limitCBPtr->entryPtr); + } + ckfree(limitCBPtr); } /* @@ -3710,26 +4170,25 @@ DeleteScriptLimitCallback(clientData) * * CallScriptLimitCallback -- * - * Invoke a script limit callback. Used to implement limit callbacks set + * 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 + * Depends on the callback script. Errors are reported as background * errors. * *---------------------------------------------------------------------- */ static void -CallScriptLimitCallback(clientData, interp) - ClientData clientData; - Tcl_Interp *interp; /* Interpreter which failed the limit */ +CallScriptLimitCallback( + ClientData clientData, + Tcl_Interp *interp) /* Interpreter which failed the limit */ { - struct ScriptLimitCallback *limitCBPtr = - (struct ScriptLimitCallback *) clientData; + ScriptLimitCallback *limitCBPtr = clientData; int code; if (Tcl_InterpDeleted(limitCBPtr->interp)) { @@ -3739,7 +4198,7 @@ CallScriptLimitCallback(clientData, interp) code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj, TCL_EVAL_GLOBAL); if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) { - Tcl_BackgroundError(limitCBPtr->interp); + Tcl_BackgroundException(limitCBPtr->interp, code); } Tcl_Release(limitCBPtr->interp); } @@ -3751,7 +4210,7 @@ CallScriptLimitCallback(clientData, interp) * * 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 + * 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). * @@ -3766,16 +4225,16 @@ CallScriptLimitCallback(clientData, interp) */ static void -SetScriptLimitCallback(interp, type, targetInterp, scriptObj) - Tcl_Interp *interp; - int type; - Tcl_Interp *targetInterp; - Tcl_Obj *scriptObj; +SetScriptLimitCallback( + Tcl_Interp *interp, + int type, + Tcl_Interp *targetInterp, + Tcl_Obj *scriptObj) { - struct ScriptLimitCallback *limitCBPtr; + ScriptLimitCallback *limitCBPtr; Tcl_HashEntry *hashPtr; int isNew; - struct ScriptLimitCallbackKey key; + ScriptLimitCallbackKey key; Interp *iPtr = (Interp *) interp; if (interp == targetInterp) { @@ -3794,15 +4253,16 @@ SetScriptLimitCallback(interp, type, targetInterp, scriptObj) return; } - hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, (char *) &key, + hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key, &isNew); if (!isNew) { + limitCBPtr = Tcl_GetHashValue(hashPtr); + limitCBPtr->entryPtr = NULL; Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, - Tcl_GetHashValue(hashPtr)); + limitCBPtr); } - limitCBPtr = (struct ScriptLimitCallback *) - ckalloc(sizeof(struct ScriptLimitCallback)); + limitCBPtr = ckalloc(sizeof(ScriptLimitCallback)); limitCBPtr->interp = interp; limitCBPtr->scriptObj = scriptObj; limitCBPtr->entryPtr = hashPtr; @@ -3810,8 +4270,8 @@ SetScriptLimitCallback(interp, type, targetInterp, scriptObj) Tcl_IncrRefCount(scriptObj); Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback, - (ClientData) limitCBPtr, DeleteScriptLimitCallback); - Tcl_SetHashValue(hashPtr, (ClientData) limitCBPtr); + limitCBPtr, DeleteScriptLimitCallback); + Tcl_SetHashValue(hashPtr, limitCBPtr); } /* @@ -3820,7 +4280,7 @@ SetScriptLimitCallback(interp, type, targetInterp, scriptObj) * TclRemoveScriptLimitCallbacks -- * * Remove all script-implemented limit callbacks that make calls back - * into the given interpreter. This invoked as part of deleting an + * into the given interpreter. This invoked as part of deleting an * interpreter. * * Results: @@ -3833,17 +4293,17 @@ SetScriptLimitCallback(interp, type, targetInterp, scriptObj) */ void -TclRemoveScriptLimitCallbacks(interp) - Tcl_Interp *interp; +TclRemoveScriptLimitCallbacks( + Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hashPtr; Tcl_HashSearch search; - struct ScriptLimitCallbackKey *keyPtr; + ScriptLimitCallbackKey *keyPtr; hashPtr = Tcl_FirstHashEntry(&iPtr->limit.callbacks, &search); while (hashPtr != NULL) { - keyPtr = (struct ScriptLimitCallbackKey *) + keyPtr = (ScriptLimitCallbackKey *) Tcl_GetHashKey(&iPtr->limit.callbacks, hashPtr); Tcl_LimitRemoveHandler(keyPtr->interp, keyPtr->type, CallScriptLimitCallback, Tcl_GetHashValue(hashPtr)); @@ -3858,7 +4318,7 @@ TclRemoveScriptLimitCallbacks(interp) * TclInitLimitSupport -- * * Initialise all the parts of the interpreter relating to resource limit - * management. This allows an interpreter to both have limits set upon + * management. This allows an interpreter to both have limits set upon * itself and set limits upon other interpreters. * * Results: @@ -3871,8 +4331,8 @@ TclRemoveScriptLimitCallbacks(interp) */ void -TclInitLimitSupport(interp) - Tcl_Interp *interp; +TclInitLimitSupport( + Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; @@ -3887,7 +4347,7 @@ TclInitLimitSupport(interp) iPtr->limit.timeEvent = NULL; iPtr->limit.timeGranularity = 10; Tcl_InitHashTable(&iPtr->limit.callbacks, - sizeof(struct ScriptLimitCallbackKey)/sizeof(int)); + sizeof(ScriptLimitCallbackKey)/sizeof(int)); } /* @@ -3911,8 +4371,9 @@ TclInitLimitSupport(interp) */ static void -InheritLimitsFromMaster(slaveInterp, masterInterp) - Tcl_Interp *slaveInterp, *masterInterp; +InheritLimitsFromMaster( + Tcl_Interp *slaveInterp, + Tcl_Interp *masterInterp) { Interp *slavePtr = (Interp *) slaveInterp; Interp *masterPtr = (Interp *) masterInterp; @@ -3936,7 +4397,7 @@ InheritLimitsFromMaster(slaveInterp, masterInterp) * SlaveCommandLimitCmd -- * * Implementation of the [interp limit $i commands] and [$i limit - * commands] subcommands. See the interp manual page for a full + * commands] subcommands. See the interp manual page for a full * description. * * Results: @@ -3949,14 +4410,14 @@ InheritLimitsFromMaster(slaveInterp, masterInterp) */ static int -SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) - 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. */ +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 *options[] = { + static const char *const options[] = { "-command", "-granularity", "-value", NULL }; enum Options { @@ -3964,10 +4425,24 @@ SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) }; Interp *iPtr = (Interp *) interp; int index; - struct ScriptLimitCallbackKey key; - struct ScriptLimitCallback *limitCBPtr; + 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; @@ -3976,8 +4451,7 @@ SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (struct ScriptLimitCallback *) - Tcl_GetHashValue(hPtr); + limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), limitCBPtr->scriptObj); @@ -4019,8 +4493,7 @@ SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (struct ScriptLimitCallback *) - Tcl_GetHashValue(hPtr); + limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_SetObjResult(interp, limitCBPtr->scriptObj); } @@ -4039,8 +4512,7 @@ SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option? ?value? ?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, limitLen = 0; @@ -4059,12 +4531,14 @@ SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) break; case OPT_GRAN: granObj = objv[i+1]; - if (Tcl_GetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { + if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { return TCL_ERROR; } if (gran < 1) { - Tcl_AppendResult(interp, "granularity must be at ", - "least 1", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "granularity must be at least 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4074,12 +4548,14 @@ SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) if (limitLen == 0) { break; } - if (Tcl_GetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) { + if (TclGetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) { return TCL_ERROR; } if (limit < 0) { - Tcl_AppendResult(interp, "command limit value must be at ", - "least 0", NULL); + 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; @@ -4110,7 +4586,7 @@ SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) * SlaveTimeLimitCmd -- * * Implementation of the [interp limit $i time] and [$i limit time] - * subcommands. See the interp manual page for a full description. + * subcommands. See the interp manual page for a full description. * * Results: * A standard Tcl result. @@ -4122,14 +4598,14 @@ SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) */ static int -SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) - 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. */ +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 *options[] = { + static const char *const options[] = { "-command", "-granularity", "-milliseconds", "-seconds", NULL }; enum Options { @@ -4137,10 +4613,24 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) }; Interp *iPtr = (Interp *) interp; int index; - struct ScriptLimitCallbackKey key; - struct ScriptLimitCallback *limitCBPtr; + 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; @@ -4149,8 +4639,7 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (struct ScriptLimitCallback *) - Tcl_GetHashValue(hPtr); + limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), limitCBPtr->scriptObj); @@ -4198,8 +4687,7 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (struct ScriptLimitCallback *) - Tcl_GetHashValue(hPtr); + limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_SetObjResult(interp, limitCBPtr->scriptObj); } @@ -4229,8 +4717,7 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option? ?value? ?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, milliLen = 0, secLen = 0; @@ -4253,12 +4740,14 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) break; case OPT_GRAN: granObj = objv[i+1]; - if (Tcl_GetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { + if (TclGetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) { return TCL_ERROR; } if (gran < 1) { - Tcl_AppendResult(interp, "granularity must be at ", - "least 1", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "granularity must be at least 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4268,15 +4757,17 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) if (milliLen == 0) { break; } - if (Tcl_GetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { + if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } if (tmp < 0) { - Tcl_AppendResult(interp, "milliseconds must be at least 0", - NULL); + 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; + limitMoment.usec = ((long) tmp)*1000; break; case OPT_SEC: secObj = objv[i+1]; @@ -4284,12 +4775,14 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) if (secLen == 0) { break; } - if (Tcl_GetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { + if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } if (tmp < 0) { - Tcl_AppendResult(interp, "seconds must be at least 0", - NULL); + 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; @@ -4300,17 +4793,23 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) if (milliObj != NULL) { /* * Setting -milliseconds but clearing -seconds, or resetting - * -milliseconds but not resetting -seconds? Bad voodoo! + * -milliseconds but not resetting -seconds? Bad voodoo! */ if (secObj != NULL && secLen == 0 && milliLen > 0) { - Tcl_AppendResult(interp, "may only set -milliseconds ", - "if -seconds is not also being reset", NULL); + 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_AppendResult(interp, "may only reset -milliseconds ", - "if -seconds is also being reset", NULL); + 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; } } @@ -4318,7 +4817,7 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) if (milliLen > 0 || secLen > 0) { /* * Force usec to be in range [0..1000000), possibly - * incrementing sec in the process. This makes it much easier + * incrementing sec in the process. This makes it much easier * for people to write scripts that do small time increments. */ |