diff options
Diffstat (limited to 'generic/tclInterp.c')
| -rw-r--r-- | generic/tclInterp.c | 1291 |
1 files changed, 897 insertions, 394 deletions
diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b0d03ad..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.62 2005/12/12 23:00:08 dkf Exp $ */ #include "tclInt.h" @@ -21,7 +19,7 @@ * above. This variable can be modified by the function below. */ -static char *tclPreInitScript = NULL; +static const char *tclPreInitScript = NULL; /* Forward declaration */ struct Target; @@ -181,13 +179,44 @@ typedef struct ScriptLimitCallbackKey { } ScriptLimitCallbackKey; /* + * TIP#143 limit handler internal representation. + */ + +struct LimitHandler { + int flags; /* The state of this particular handler. */ + Tcl_LimitHandlerProc *handlerProc; + /* The handler callback. */ + ClientData clientData; /* Opaque argument to the handler callback. */ + Tcl_LimitHandlerDeleteProc *deleteProc; + /* How to delete the clientData. */ + LimitHandler *prevPtr; /* Previous item in linked list of + * handlers. */ + LimitHandler *nextPtr; /* Next item in linked list of handlers. */ +}; + +/* + * Values for the LimitHandler flags field. + * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being + * processed; handlers are never to be entered reentrantly. + * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This + * should not normally be observed because when a handler is + * deleted it is also spliced out of the list of handlers, but + * even so we will be careful. + */ + +#define LIMIT_HANDLER_ACTIVE 0x01 +#define LIMIT_HANDLER_DELETED 0x02 + + + +/* * Prototypes for local static functions: */ static int AliasCreate(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, @@ -195,45 +224,51 @@ static int AliasDescribe(Tcl_Interp *interp, static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); static int AliasObjCmd(ClientData dummy, Tcl_Interp *currentInterp, int objc, - Tcl_Obj *CONST objv[]); + 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[]); + 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[]); + 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[]); + int objc, Tcl_Obj *const objv[]); static int SlaveExpose(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, - Tcl_Obj *CONST objv[]); + Tcl_Obj *const objv[]); static int SlaveHide(Tcl_Interp *interp, Tcl_Interp *slaveInterp, - int objc, Tcl_Obj *CONST objv[]); + 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[]); + 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[]); + 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[]); + Tcl_Obj *const objv[]); static int SlaveCommandLimitCmd(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int consumedObjc, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static int SlaveTimeLimitCmd(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int consumedObjc, - int objc, Tcl_Obj *CONST objv[]); + int objc, Tcl_Obj *const objv[]); static void InheritLimitsFromMaster(Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp); static void SetScriptLimitCallback(Tcl_Interp *interp, int type, @@ -244,6 +279,12 @@ 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; + /* *---------------------------------------------------------------------- @@ -262,11 +303,11 @@ static void TimeLimitCallback(ClientData clientData); *---------------------------------------------------------------------- */ -char * +const char * TclSetPreInitScript( - char *string) /* Pointer to a script. */ + const char *string) /* Pointer to a script. */ { - char *prevString = tclPreInitScript; + const char *prevString = tclPreInitScript; tclPreInitScript = string; return(prevString); } @@ -296,8 +337,8 @@ Tcl_Init( { if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (TCL_ERROR); - }; + return TCL_ERROR; + } } /* @@ -338,11 +379,11 @@ Tcl_Init( * will be set as the value of tcl_library. * * Note that this entire search mechanism can be bypassed by defining an - * alternate tclInit function 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" @@ -432,8 +473,8 @@ TclInterpInit( 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); @@ -446,7 +487,8 @@ TclInterpInit( 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; @@ -528,7 +570,7 @@ InterpInfoDeleteProc( } Tcl_DeleteHashTable(&slavePtr->aliasTable); - ckfree((char *) interpInfoPtr); + ckfree(interpInfoPtr); } /* @@ -553,23 +595,36 @@ Tcl_InterpObjCmd( ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + 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) { @@ -582,30 +637,30 @@ Tcl_InterpObjCmd( } 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]); } @@ -616,18 +671,13 @@ Tcl_InterpObjCmd( } 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; @@ -637,13 +687,84 @@ Tcl_InterpObjCmd( 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 @@ -659,8 +780,8 @@ Tcl_InterpObjCmd( 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) { @@ -706,10 +827,23 @@ Tcl_InterpObjCmd( 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]); @@ -718,6 +852,8 @@ Tcl_InterpObjCmd( } 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; @@ -726,9 +862,7 @@ Tcl_InterpObjCmd( } 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; @@ -738,12 +872,9 @@ Tcl_InterpObjCmd( 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) { @@ -755,9 +886,7 @@ Tcl_InterpObjCmd( 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; @@ -767,45 +896,34 @@ Tcl_InterpObjCmd( 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 @@ -813,7 +931,7 @@ Tcl_InterpObjCmd( 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", @@ -826,7 +944,7 @@ Tcl_InterpObjCmd( if (++i == objc) { /* There must be more arguments. */ break; } else { - namespaceName = Tcl_GetString(objv[i]); + namespaceName = TclGetString(objv[i]); } } else { i++; @@ -839,15 +957,14 @@ Tcl_InterpObjCmd( 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 { @@ -856,7 +973,8 @@ Tcl_InterpObjCmd( 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]); @@ -874,9 +992,7 @@ Tcl_InterpObjCmd( 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; @@ -886,10 +1002,7 @@ Tcl_InterpObjCmd( 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; @@ -899,9 +1012,7 @@ Tcl_InterpObjCmd( 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; @@ -923,9 +1034,9 @@ Tcl_InterpObjCmd( 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) { @@ -936,9 +1047,9 @@ Tcl_InterpObjCmd( 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]); @@ -946,14 +1057,24 @@ Tcl_InterpObjCmd( 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"); @@ -965,50 +1086,25 @@ Tcl_InterpObjCmd( 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; @@ -1043,7 +1139,7 @@ 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. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc == 2) { return interp; @@ -1074,18 +1170,18 @@ GetInterp2( int Tcl_CreateAlias( Tcl_Interp *slaveInterp, /* Interpreter for source command. */ - CONST char *slaveCmd, /* Command to install in slave. */ + const char *slaveCmd, /* Command to install in slave. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ - CONST char *targetCmd, /* Name of target command. */ + const char *targetCmd, /* Name of target command. */ int argc, /* How many additional arguments? */ - CONST char *CONST *argv) /* These are the additional args. */ + 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]); @@ -1103,7 +1199,7 @@ Tcl_CreateAlias( for (i = 0; i < argc; i++) { Tcl_DecrRefCount(objv[i]); } - ckfree((char *) objv); + TclStackFree(slaveInterp, objv); Tcl_DecrRefCount(targetObjPtr); Tcl_DecrRefCount(slaveObjPtr); @@ -1129,11 +1225,11 @@ Tcl_CreateAlias( int Tcl_CreateAliasObj( Tcl_Interp *slaveInterp, /* Interpreter for source command. */ - CONST char *slaveCmd, /* Command to install in slave. */ + const char *slaveCmd, /* Command to install in slave. */ Tcl_Interp *targetInterp, /* Interpreter for target command. */ - CONST char *targetCmd, /* Name of target command. */ + const char *targetCmd, /* Name of target command. */ int objc, /* How many additional arguments? */ - Tcl_Obj *CONST objv[]) /* Argument vector. */ + Tcl_Obj *const objv[]) /* Argument vector. */ { Tcl_Obj *slaveObjPtr, *targetObjPtr; int result; @@ -1171,27 +1267,27 @@ Tcl_CreateAliasObj( int Tcl_GetAlias( Tcl_Interp *interp, /* Interp to start search from. */ - CONST char *aliasName, /* Name of alias to find. */ + const char *aliasName, /* Name of alias to find. */ Tcl_Interp **targetInterpPtr, /* (Return) target interpreter. */ - CONST char **targetNamePtr, /* (Return) name of target command. */ + const char **targetNamePtr, /* (Return) name of target command. */ int *argcPtr, /* (Return) count of addnl args. */ - CONST char ***argvPtr) /* (Return) additional arguments. */ + 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; @@ -1199,16 +1295,16 @@ Tcl_GetAlias( *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; @@ -1233,40 +1329,40 @@ Tcl_GetAlias( int Tcl_GetAliasObj( Tcl_Interp *interp, /* Interp to start search from. */ - CONST char *aliasName, /* Name of alias to find. */ + const char *aliasName, /* Name of alias to find. */ Tcl_Interp **targetInterpPtr, /* (Return) target interpreter. */ - CONST char **targetNamePtr, /* (Return) name of target command. */ + 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; @@ -1321,7 +1417,7 @@ TclPreventAliasLoop( * chain then we have a loop. */ - aliasPtr = (Alias *) cmdPtr->objClientData; + aliasPtr = cmdPtr->objClientData; nextAliasPtr = aliasPtr; while (1) { Tcl_Obj *cmdNamePtr; @@ -1337,24 +1433,26 @@ TclPreventAliasLoop( * [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; } @@ -1367,7 +1465,7 @@ TclPreventAliasLoop( if (aliasCmdPtr->objProc != AliasObjCmd) { return TCL_OK; } - nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; + nextAliasPtr = aliasCmdPtr->objClientData; } /* NOTREACHED */ @@ -1400,7 +1498,7 @@ AliasCreate( 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 *const objv[]) /* with alias. */ { Alias *aliasPtr; Tcl_HashEntry *hPtr; @@ -1408,10 +1506,9 @@ AliasCreate( 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; @@ -1429,9 +1526,15 @@ AliasCreate( 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) { @@ -1456,7 +1559,7 @@ AliasCreate( cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); - ckfree((char *) aliasPtr); + ckfree(aliasPtr); /* * The result was already set by TclPreventAliasLoop. @@ -1474,11 +1577,11 @@ AliasCreate( 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; } @@ -1494,7 +1597,7 @@ AliasCreate( * 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; @@ -1502,7 +1605,7 @@ AliasCreate( } 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, @@ -1513,11 +1616,11 @@ AliasCreate( * 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) { @@ -1566,13 +1669,15 @@ AliasDelete( */ 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; } @@ -1617,7 +1722,7 @@ AliasDescribe( 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; @@ -1654,7 +1759,7 @@ AliasList( 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); @@ -1684,20 +1789,84 @@ AliasList( */ static int +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. */ + 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 @@ -1710,34 +1879,74 @@ AliasObjCmd( 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 @@ -1765,13 +1974,11 @@ static void 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++) { @@ -1789,14 +1996,15 @@ AliasObjCmdDeleteProc( } 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); } /* @@ -1825,7 +2033,7 @@ AliasObjCmdDeleteProc( Tcl_Interp * Tcl_CreateSlave( Tcl_Interp *interp, /* Interpreter to start search at. */ - CONST char *slavePath, /* Name of slave to create. */ + const char *slavePath, /* Name of slave to create. */ int isSafe) /* Should new slave be "safe" ? */ { Tcl_Obj *pathPtr; @@ -1857,7 +2065,7 @@ Tcl_CreateSlave( Tcl_Interp * Tcl_GetSlave( Tcl_Interp *interp, /* Interpreter to start search from. */ - CONST char *slavePath) /* Path of slave to find. */ + const char *slavePath) /* Path of slave to find. */ { Tcl_Obj *pathPtr; Tcl_Interp *slaveInterp; @@ -1891,7 +2099,7 @@ Tcl_GetMaster( { Slave *slavePtr; /* Slave record of this interpreter. */ - if (interp == (Tcl_Interp *) NULL) { + if (interp == NULL) { return NULL; } slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; @@ -1901,6 +2109,72 @@ Tcl_GetMaster( /* *---------------------------------------------------------------------- * + * 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 @@ -1930,17 +2204,19 @@ Tcl_GetInterpPath( 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; } @@ -1974,7 +2250,7 @@ GetInterp( 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; } @@ -1982,20 +2258,22 @@ GetInterp( 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; } @@ -2023,20 +2301,22 @@ 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. */ + 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; } @@ -2069,8 +2349,8 @@ SlaveCreate( 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) { @@ -2078,7 +2358,7 @@ SlaveCreate( } if (objc < 2) { masterInterp = interp; - path = Tcl_GetString(pathPtr); + path = TclGetString(pathPtr); } else { Tcl_Obj *objPtr; @@ -2088,17 +2368,19 @@ SlaveCreate( 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; } @@ -2107,10 +2389,10 @@ SlaveCreate( 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); /* @@ -2150,12 +2432,13 @@ SlaveCreate( */ 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; @@ -2165,7 +2448,7 @@ SlaveCreate( return slaveInterp; error: - TclTransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_TransferResult(slaveInterp, TCL_ERROR, interp); error2: Tcl_DeleteInterp(slaveInterp); @@ -2194,22 +2477,33 @@ SlaveObjCmd( ClientData clientData, /* Slave interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + 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"); } @@ -2229,7 +2523,7 @@ SlaveObjCmd( 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]); } @@ -2238,11 +2532,11 @@ SlaveObjCmd( 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); @@ -2252,6 +2546,16 @@ SlaveObjCmd( 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 ...?"); @@ -2278,17 +2582,16 @@ SlaveObjCmd( 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 @@ -2296,7 +2599,7 @@ SlaveObjCmd( 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", @@ -2309,7 +2612,7 @@ SlaveObjCmd( if (++i == objc) { /* There must be more arguments. */ break; } else { - namespaceName = Tcl_GetString(objv[i]); + namespaceName = TclGetString(objv[i]); } } else { i++; @@ -2325,7 +2628,7 @@ SlaveObjCmd( objc - i, objv + i); } case OPT_LIMIT: { - static CONST char *limitTypes[] = { + static const char *const limitTypes[] = { "commands", "time", NULL }; enum LimitTypes { @@ -2334,7 +2637,7 @@ SlaveObjCmd( 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, @@ -2389,9 +2692,9 @@ SlaveObjCmdDeleteProc( ClientData clientData) /* The SlaveRecord for the command. */ { Slave *slavePtr; /* Interim storage for Slave record. */ - Tcl_Interp *slaveInterp; /* And for a slave interp. */ + Tcl_Interp *slaveInterp = clientData; + /* And for a slave interp. */ - slaveInterp = (Tcl_Interp *) clientData; slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; /* @@ -2416,6 +2719,77 @@ SlaveObjCmdDeleteProc( /* *---------------------------------------------------------------------- * + * 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. @@ -2435,25 +2809,44 @@ SlaveEval( Tcl_Interp *slaveInterp, /* The slave interpreter in which command * will be evaluated. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + 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; } @@ -2479,21 +2872,23 @@ 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. */ + 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; @@ -2521,24 +2916,27 @@ 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. */ + 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); @@ -2546,6 +2944,7 @@ SlaveRecursionLimit( 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]); @@ -2579,20 +2978,22 @@ 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. */ + 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; @@ -2626,9 +3027,9 @@ SlaveHidden( 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)); @@ -2659,9 +3060,9 @@ 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. */ + const char *namespaceName, /* The namespace to use, if any. */ int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int result; @@ -2669,31 +3070,53 @@ SlaveInvokeHidden( 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; } @@ -2724,6 +3147,8 @@ SlaveMarkTrusted( 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; @@ -2750,14 +3175,12 @@ int 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; } /* @@ -2785,9 +3208,26 @@ Tcl_MakeSafe( { 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; /* @@ -2830,15 +3270,15 @@ Tcl_MakeSafe( */ 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); } @@ -2860,6 +3300,9 @@ Tcl_MakeSafe( * Side effects: * None. * + * Notes: + * If you change this function, you MUST also update TclLimitExceeded() in + * tclInt.h. *---------------------------------------------------------------------- */ @@ -2887,6 +3330,10 @@ Tcl_LimitExceeded( * Side effects: * Increments the limit granularity counter. * + * Notes: + * If you change this function, you MUST also update TclLimitReady() in + * tclInt.h. + * *---------------------------------------------------------------------- */ @@ -2957,8 +3404,9 @@ Tcl_LimitCheck( 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; } @@ -2982,8 +3430,9 @@ Tcl_LimitCheck( 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; } @@ -3036,7 +3485,7 @@ RunLimitHandlers( */ handlerPtr->flags |= LIMIT_HANDLER_ACTIVE; - (handlerPtr->handlerProc)(handlerPtr->clientData, interp); + handlerPtr->handlerProc(handlerPtr->clientData, interp); handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE; /* @@ -3057,9 +3506,9 @@ RunLimitHandlers( if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { if (handlerPtr->deleteProc != NULL) { - (handlerPtr->deleteProc)(handlerPtr->clientData); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } } @@ -3099,14 +3548,14 @@ Tcl_LimitAddHandler( 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; @@ -3223,9 +3672,9 @@ Tcl_LimitRemoveHandler( if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { - (handlerPtr->deleteProc)(handlerPtr->clientData); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } return; } @@ -3283,9 +3732,9 @@ TclLimitRemoveAllHandlers( if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { - (handlerPtr->deleteProc)(handlerPtr->clientData); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } @@ -3316,9 +3765,9 @@ TclLimitRemoveAllHandlers( if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { if (handlerPtr->deleteProc != NULL) { - (handlerPtr->deleteProc)(handlerPtr->clientData); + handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } @@ -3537,7 +3986,7 @@ Tcl_LimitSetTime( nextMoment.usec -= 1000000; } iPtr->limit.timeEvent = TclCreateAbsoluteTimerHandler(&nextMoment, - TimeLimitCallback, (ClientData) interp); + TimeLimitCallback, interp); iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; } @@ -3563,15 +4012,27 @@ static void 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); } /* @@ -3695,13 +4156,13 @@ static void DeleteScriptLimitCallback( ClientData clientData) { - ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *) clientData; + ScriptLimitCallback *limitCBPtr = clientData; Tcl_DecrRefCount(limitCBPtr->scriptObj); if (limitCBPtr->entryPtr != NULL) { Tcl_DeleteHashEntry(limitCBPtr->entryPtr); } - ckfree((char *) limitCBPtr); + ckfree(limitCBPtr); } /* @@ -3727,7 +4188,7 @@ CallScriptLimitCallback( ClientData clientData, Tcl_Interp *interp) /* Interpreter which failed the limit */ { - ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *) clientData; + ScriptLimitCallback *limitCBPtr = clientData; int code; if (Tcl_InterpDeleted(limitCBPtr->interp)) { @@ -3737,7 +4198,7 @@ CallScriptLimitCallback( 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); } @@ -3792,16 +4253,16 @@ SetScriptLimitCallback( return; } - hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, (char *) &key, + hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key, &isNew); if (!isNew) { - limitCBPtr = (ScriptLimitCallback *) Tcl_GetHashValue(hashPtr); + limitCBPtr = Tcl_GetHashValue(hashPtr); limitCBPtr->entryPtr = NULL; Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, limitCBPtr); } - limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback)); + limitCBPtr = ckalloc(sizeof(ScriptLimitCallback)); limitCBPtr->interp = interp; limitCBPtr->scriptObj = scriptObj; limitCBPtr->entryPtr = hashPtr; @@ -3809,8 +4270,8 @@ SetScriptLimitCallback( Tcl_IncrRefCount(scriptObj); Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback, - (ClientData) limitCBPtr, DeleteScriptLimitCallback); - Tcl_SetHashValue(hashPtr, (ClientData) limitCBPtr); + limitCBPtr, DeleteScriptLimitCallback); + Tcl_SetHashValue(hashPtr, limitCBPtr); } /* @@ -3954,9 +4415,9 @@ SlaveCommandLimitCmd( 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. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - static CONST char *options[] = { + static const char *const options[] = { "-command", "-granularity", "-value", NULL }; enum Options { @@ -3968,6 +4429,20 @@ SlaveCommandLimitCmd( 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,7 +4451,7 @@ SlaveCommandLimitCmd( key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (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); @@ -4018,7 +4493,7 @@ SlaveCommandLimitCmd( key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (ScriptLimitCallback *) Tcl_GetHashValue(hPtr); + limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_SetObjResult(interp, limitCBPtr->scriptObj); } @@ -4037,8 +4512,7 @@ SlaveCommandLimitCmd( } 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; @@ -4057,12 +4531,14 @@ SlaveCommandLimitCmd( 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; @@ -4072,12 +4548,14 @@ SlaveCommandLimitCmd( 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; @@ -4125,9 +4603,9 @@ SlaveTimeLimitCmd( 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. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - static CONST char *options[] = { + static const char *const options[] = { "-command", "-granularity", "-milliseconds", "-seconds", NULL }; enum Options { @@ -4139,6 +4617,20 @@ SlaveTimeLimitCmd( 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; @@ -4147,7 +4639,7 @@ SlaveTimeLimitCmd( key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (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); @@ -4195,7 +4687,7 @@ SlaveTimeLimitCmd( key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = (ScriptLimitCallback *) Tcl_GetHashValue(hPtr); + limitCBPtr = Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_SetObjResult(interp, limitCBPtr->scriptObj); } @@ -4225,8 +4717,7 @@ SlaveTimeLimitCmd( } 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; @@ -4249,12 +4740,14 @@ SlaveTimeLimitCmd( 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; @@ -4264,15 +4757,17 @@ SlaveTimeLimitCmd( 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]; @@ -4280,12 +4775,14 @@ SlaveTimeLimitCmd( 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,13 +4797,19 @@ SlaveTimeLimitCmd( */ 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; } } |