diff options
Diffstat (limited to 'generic/tclInterp.c')
| -rw-r--r-- | generic/tclInterp.c | 1915 |
1 files changed, 854 insertions, 1061 deletions
diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 7c1b5ba..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.101 2009/01/29 14:45:13 dgp 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,6 +179,37 @@ 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: */ @@ -210,6 +239,9 @@ static int SlaveBgerror(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, @@ -248,60 +280,10 @@ static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); -/* - * Table of interp subcommand names and implementations. - */ - -static Tcl_ObjCmdProc InterpAliasCmd; -static Tcl_ObjCmdProc InterpAliasesCmd; -static Tcl_ObjCmdProc InterpBgErrorCmd; -static Tcl_ObjCmdProc InterpCancelCmd; -static Tcl_ObjCmdProc InterpCreateCmd; -static Tcl_ObjCmdProc InterpDeleteCmd; -static Tcl_ObjCmdProc InterpEvalCmd; -static Tcl_ObjCmdProc InterpExistsCmd; -static Tcl_ObjCmdProc InterpExposeCmd; -static Tcl_ObjCmdProc InterpHiddenCmd; -static Tcl_ObjCmdProc InterpHideCmd; -static Tcl_ObjCmdProc InterpInvokeHiddenCmd; -static Tcl_ObjCmdProc InterpIsSafeCmd; -static Tcl_ObjCmdProc InterpLimitCmd; -static Tcl_ObjCmdProc InterpMarkTrustedCmd; -static Tcl_ObjCmdProc InterpRecursionLimitCmd; -static Tcl_ObjCmdProc InterpShareCmd; -static Tcl_ObjCmdProc InterpSlavesCmd; -static Tcl_ObjCmdProc InterpTargetCmd; -static Tcl_ObjCmdProc InterpTransferCmd; - -static int InterpShareTransferCommon(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int transfer); -/* -static Tcl_ObjCmdProc InterpNREvalCmd; -static Tcl_ObjCmdProc InterpNRInvokeHiddenCmd; -*/ -static const EnsembleImplMap implementationMap[] = { - {"alias", InterpAliasCmd }, - {"aliases", InterpAliasesCmd }, - {"bgerror", InterpBgErrorCmd }, - {"cancel", InterpCancelCmd }, - {"create", InterpCreateCmd }, - {"delete", InterpDeleteCmd }, - {"eval", InterpEvalCmd, NULL, /*InterpNREvalCmd*/ }, - {"exists", InterpExistsCmd }, - {"expose", InterpExposeCmd }, - {"hidden", InterpHiddenCmd }, - {"hide", InterpHideCmd }, - {"invokehidden", InterpInvokeHiddenCmd, NULL, /*InterpNRInvokeHiddenCmd*/ }, - {"issafe", InterpIsSafeCmd }, - {"limit", InterpLimitCmd }, - {"marktrusted", InterpMarkTrustedCmd }, - {"recursionlimit", InterpRecursionLimitCmd }, - {"share", InterpShareCmd }, - {"slaves", InterpSlavesCmd }, - {"target", InterpTargetCmd }, - {"transfer", InterpTransferCmd }, - {NULL} -}; +/* NRE enabling */ +static Tcl_NRPostProc NRPostInvokeHidden; +static Tcl_ObjCmdProc NRInterpCmd; +static Tcl_ObjCmdProc NRSlaveCmd; /* @@ -321,11 +303,11 @@ static const EnsembleImplMap implementationMap[] = { *---------------------------------------------------------------------- */ -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); } @@ -355,8 +337,8 @@ Tcl_Init( { if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (TCL_ERROR); - }; + return TCL_ERROR; + } } /* @@ -491,7 +473,7 @@ TclInterpInit( Master *masterPtr; Slave *slavePtr; - interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); + interpInfoPtr = ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = interpInfoPtr; masterPtr = &interpInfoPtr->master; @@ -505,7 +487,8 @@ TclInterpInit( slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - TclMakeEnsemble(interp, "interp", implementationMap); + Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, + NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -587,78 +570,16 @@ InterpInfoDeleteProc( } Tcl_DeleteHashTable(&slavePtr->aliasTable); - ckfree((char *) interpInfoPtr); -} - -/* - *---------------------------------------------------------------------- - * - * InterpAliasCmd-- - * - * Implements the "interp alias" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpAliasCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ - -{ - Tcl_Interp *slaveInterp; - - if (objc < 3) { - aliasArgs: - Tcl_WrongNumArgs(interp, 1, objv, - "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - if (objc == 3) { - return AliasDescribe(interp, slaveInterp, objv[2]); - } - if ((objc == 4) && (TclGetString(objv[3])[0] == '\0')) { - return AliasDelete(interp, slaveInterp, objv[2]); - } - if (objc > 4) { - Tcl_Interp *masterInterp = GetInterp(interp, objv[3]); - if (masterInterp == NULL) { - return TCL_ERROR; - } - if (TclGetString(objv[4])[0] == '\0') { - if (objc == 5) { - return AliasDelete(interp, slaveInterp, objv[2]); - } - goto aliasArgs; - } else { - return AliasCreate(interp, slaveInterp, masterInterp, objv[2], - objv[4], objc - 5, objv + 5); - } - } - /* NOTREACHED */ - return TCL_ERROR; + ckfree(interpInfoPtr); } /* *---------------------------------------------------------------------- * - * InterpAliasesCmd-- + * Tcl_InterpObjCmd -- * - * Implements the "interp aliases" 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. @@ -669,927 +590,530 @@ InterpAliasCmd( *---------------------------------------------------------------------- */ /* ARGSUSED */ -static int -InterpAliasesCmd( +int +Tcl_InterpObjCmd( ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ - { - Tcl_Interp *slaveInterp = GetInterp2(interp, objc, objv); - - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return AliasList(interp, slaveInterp); + return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); } - -/* - *---------------------------------------------------------------------- - * - * InterpBgErrorCmd-- - * - * Implements the "interp bgerror" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpBgErrorCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path ?cmdPrefix?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); -} - -/* - *---------------------------------------------------------------------- - * - * InterpCancelCmd-- - * - * Implements the "interp cancel" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ static int -InterpCancelCmd( +NRInterpCmd( ClientData clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, flags, index; Tcl_Interp *slaveInterp; - Tcl_Obj *resultObjPtr; + int index; static const char *const options[] = { - "-unwind", "--", NULL + "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_UNWIND, OPT_LAST + 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 > 5) { - Tcl_WrongNumArgs(interp, 1, objv, "?-unwind? ?--? ?path? ?result?"); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); return TCL_ERROR; } + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum option) index) { + case OPT_ALIAS: { + Tcl_Interp *masterInterp; - flags = 0; - - for (i = 1; i < objc; i++) { - if (TclGetString(objv[i])[0] != '-') { - break; + if (objc < 4) { + aliasArgs: + Tcl_WrongNumArgs(interp, 2, objv, + "slavePath slaveCmd ?masterPath masterCmd? ?arg ...?"); + return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) - != TCL_OK) { + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { 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; + if (objc == 4) { + return AliasDescribe(interp, slaveInterp, objv[3]); + } + if ((objc == 5) && (TclGetString(objv[4])[0] == '\0')) { + return AliasDelete(interp, slaveInterp, objv[3]); + } + if (objc > 5) { + masterInterp = GetInterp(interp, objv[4]); + if (masterInterp == NULL) { + return TCL_ERROR; + } + if (TclGetString(objv[5])[0] == '\0') { + if (objc == 6) { + return AliasDelete(interp, slaveInterp, objv[3]); + } + } else { + return AliasCreate(interp, slaveInterp, masterInterp, objv[3], + objv[5], objc - 6, objv + 6); + } } + goto aliasArgs; } - - endOfForLoop: - - /* - * 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]); + case OPT_ALIASES: + slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } - i++; - } else { - slaveInterp = interp; - } + return AliasList(interp, slaveInterp); + case OPT_BGERROR: + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); + case OPT_CANCEL: { + int i, flags; + Tcl_Obj *resultObjPtr; + static const char *const cancelOptions[] = { + "-unwind", "--", NULL + }; + enum option { + OPT_UNWIND, OPT_LAST + }; - if (i < objc) { - resultObjPtr = objv[i]; - Tcl_IncrRefCount(resultObjPtr); /* Tcl_CancelEval removes this ref. */ - } else { - resultObjPtr = NULL; - } + flags = 0; - return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); -} - -/* - *---------------------------------------------------------------------- - * - * InterpCreateCmd-- - * - * Implements the "interp create" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpCreateCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i, last, safe, index; - Tcl_Obj *slavePtr; - char buf[16 + TCL_INTEGER_SPACE]; - static const char *const options[] = { - "-safe", "--", NULL - }; - enum option { - OPT_SAFE, OPT_LAST - }; + 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; + } - safe = Tcl_IsSafe(interp); + switch ((enum option) index) { + case OPT_UNWIND: + /* + * The evaluation stack in the target interp is to be unwound. + */ - /* - * TODO: Get rid of this nonsense. - * Weird historical rules: "-safe" is accepted at the end, too. - */ + flags |= TCL_CANCEL_UNWIND; + break; + case OPT_LAST: + i++; + goto endOfForLoop; + } + } - slavePtr = NULL; - last = 0; - for (i = 1; i < objc; i++) { - if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, - &index) != TCL_OK) { + 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; } - if (index == OPT_SAFE) { - safe = 1; - continue; - } i++; - last = 1; - } - if (slavePtr != NULL) { - Tcl_WrongNumArgs(interp, 1, objv, "?-safe? ?--? ?path?"); - return TCL_ERROR; + } else { + slaveInterp = interp; } + if (i < objc) { - slavePtr = objv[i]; + resultObjPtr = objv[i]; + + /* + * Tcl_CancelEval removes this reference. + */ + + Tcl_IncrRefCount(resultObjPtr); + i++; + } else { + resultObjPtr = NULL; } + + return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); } - buf[0] = '\0'; - if (slavePtr == NULL) { + case OPT_CREATE: { + int i, last, safe; + Tcl_Obj *slavePtr; + char buf[16 + TCL_INTEGER_SPACE]; + static const char *const createOptions[] = { + "-safe", "--", NULL + }; + enum option { + OPT_SAFE, OPT_LAST + }; + + safe = Tcl_IsSafe(interp); + /* - * Create an anonymous interpreter -- we choose its name and the - * name of the command. We check that the command name that we use - * for the interpreter does not collide with an existing command - * in the master interpreter. + * Weird historical rules: "-safe" is accepted at the end, too. */ - for (i = 0; ; i++) { - Tcl_CmdInfo cmdInfo; - + slavePtr = NULL; + last = 0; + for (i = 2; i < objc; i++) { + if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { + if (Tcl_GetIndexFromObj(interp, objv[i], createOptions, + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == OPT_SAFE) { + safe = 1; + continue; + } + i++; + last = 1; + } + if (slavePtr != NULL) { + Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); + return TCL_ERROR; + } + if (i < objc) { + slavePtr = objv[i]; + } + } + buf[0] = '\0'; + if (slavePtr == NULL) { /* - * TODO: Better scheme than this?! Also, verify that - * [interp create] in non-global namespace contexts can't - * lead to a situation where a global command isn't detected, - * and gets stomped on. + * Create an anonymous interpreter -- we choose its name and the + * name of the command. We check that the command name that we use + * for the interpreter does not collide with an existing command + * in the master interpreter. */ - sprintf(buf, "interp%d", i); - if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { - break; + + for (i = 0; ; i++) { + Tcl_CmdInfo cmdInfo; + + sprintf(buf, "interp%d", i); + if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { + break; + } } + slavePtr = Tcl_NewStringObj(buf, -1); } - slavePtr = Tcl_NewStringObj(buf, -1); - } - if (SlaveCreate(interp, slavePtr, safe) == NULL) { - if (buf[0] != '\0') { - Tcl_DecrRefCount(slavePtr); + if (SlaveCreate(interp, slavePtr, safe) == NULL) { + if (buf[0] != '\0') { + Tcl_DecrRefCount(slavePtr); + } + return TCL_ERROR; } - return TCL_ERROR; + Tcl_SetObjResult(interp, slavePtr); + return TCL_OK; } - Tcl_SetObjResult(interp, slavePtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpDeleteCmd-- - * - * Implements the "interp delete" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpDeleteCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i; - InterpInfo *iiPtr; - Tcl_Interp *slaveInterp; + case OPT_DEBUG: /* TIP #378 */ + /* + * Currently only -frame supported, otherwise ?-option ?value?? + */ - for (i = 1; i < objc; i++) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); return TCL_ERROR; - } else if (slaveInterp == interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot delete the current interpreter", -1)); + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { return TCL_ERROR; } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, - iiPtr->slave.interpCmd); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpEvalCmd-- - * - * Implements the "interp eval" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpEvalCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; + return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); + case OPT_DELETE: { + int i; + InterpInfo *iiPtr; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path arg ?arg ...?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; + for (i = 2; i < objc; i++) { + slaveInterp = GetInterp(interp, objv[i]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } else if (slaveInterp == interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot delete the current interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "DELETESELF", NULL); + return TCL_ERROR; + } + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, + iiPtr->slave.interpCmd); + } + return TCL_OK; } - return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); -} - -/* - *---------------------------------------------------------------------- - * - * InterpExistsCmd-- - * - * Implements the "interp exists" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpExistsCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int exists = 1; - Tcl_Interp *slaveInterp = GetInterp2(interp, objc, objv); - - if (slaveInterp == NULL) { - if (objc > 2) { + case OPT_EVAL: + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; } - Tcl_ResetResult(interp); - exists = 0; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpExposeCmd-- - * - * Implements the "interp expose" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpExposeCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "path hiddenCmdName ?cmdName?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); -} - -/* - *---------------------------------------------------------------------- - * - * InterpHiddenCmd-- - * - * Implements the "interp hidden" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpHiddenCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp = GetInterp2(interp, objc, objv); - - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveHidden(interp, slaveInterp); -} - -/* - *---------------------------------------------------------------------- - * - * InterpHideCmd-- - * - * Implements the "interp hide" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpHideCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); + case OPT_EXISTS: { + int exists = 1; - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "path cmdName ?hiddenCmdName?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + if (objc > 3) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + exists = 0; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); + return TCL_OK; } - return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); -} - -/* - *---------------------------------------------------------------------- - * - * InterpInvokeHiddenCmd-- - * - * Implements the "interp invokehidden" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpInvokeHiddenCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i, index; - const char *namespaceName; - Tcl_Interp *slaveInterp; - static const char *const hiddenOptions[] = { - "-global", "-namespace", "--", NULL - }; - enum hiddenOption { - OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - }; - - namespaceName = NULL; - for (i = 2; i < objc; i++) { - if (TclGetString(objv[i])[0] != '-') { - break; + case OPT_EXPOSE: + if ((objc < 4) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); + case OPT_HIDE: + if ((objc < 4) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); + case OPT_HIDDEN: + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", 0, - &index) != TCL_OK) { + return SlaveHidden(interp, slaveInterp); + case OPT_ISSAFE: + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { return TCL_ERROR; } - if (index == OPT_GLOBAL) { - namespaceName = "::"; - } else if (index == OPT_NAMESPACE) { - if (++i == objc) { /* There must be more arguments. */ + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + return TCL_OK; + case OPT_INVOKEHID: { + int i; + const char *namespaceName; + static const char *const hiddenOptions[] = { + "-global", "-namespace", "--", NULL + }; + enum hiddenOption { + OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST + }; + + namespaceName = NULL; + for (i = 3; i < objc; i++) { + if (TclGetString(objv[i])[0] != '-') { break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == OPT_GLOBAL) { + namespaceName = "::"; + } else if (index == OPT_NAMESPACE) { + if (++i == objc) { /* There must be more arguments. */ + break; + } else { + namespaceName = TclGetString(objv[i]); + } } else { - namespaceName = TclGetString(objv[i]); + i++; + break; } - } else { - i++; - break; } + if (objc - i < 1) { + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, + objv + i); } - if (objc - i < 1) { - Tcl_WrongNumArgs(interp, 1, objv, - "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, - objv + i); -} - -/* - *---------------------------------------------------------------------- - * - * InterpIsSafeCmd-- - * - * Implements the "interp issafe" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpIsSafeCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp = GetInterp2(interp, objc, objv); - - if (slaveInterp == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpLimitCmd-- - * - * Implements the "interp limit" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpLimitCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - static const char *const limitTypes[] = { - "commands", "time", NULL - }; - enum LimitTypes { - LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME - }; - int limitType; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path limitType ?-option value ...?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, - &limitType) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum LimitTypes) limitType) { - case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); - case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); - } - /* NOTREACHED */ - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * InterpMarkTrustedCmd-- - * - * Implements the "interp marktrusted" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpMarkTrustedCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "path"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveMarkTrusted(interp, slaveInterp); -} - -/* - *---------------------------------------------------------------------- - * - * InterpRecursionLimitCmd-- - * - * Implements the "interp recursionlimit" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpRecursionLimitCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path ?newlimit?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); -} - -/* - *---------------------------------------------------------------------- - * - * InterpShareCmd-- - * - * Implements the "interp share" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpShareCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return InterpShareTransferCommon(interp, objc, objv, 0); -} - -/* - *---------------------------------------------------------------------- - * - * InterpSlavesCmd-- - * - * Implements the "interp slaves" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpSlavesCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp = GetInterp2(interp, objc, objv); - InterpInfo *iiPtr; - Tcl_Obj *resultPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hashSearch; + case OPT_LIMIT: { + static const char *const limitTypes[] = { + "commands", "time", NULL + }; + enum LimitTypes { + LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME + }; + int limitType; - if (slaveInterp == NULL) { - return TCL_ERROR; - } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - resultPtr = Tcl_NewObj(); - hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); - for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj( - Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr), -1)); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "path limitType ?-option value ...?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, + &limitType) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LimitTypes) limitType) { + case LIMIT_TYPE_COMMANDS: + return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); + case LIMIT_TYPE_TIME: + return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); + } } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpShareTransferCommon-- - * - * The common portion of the "interp slaves" and "interp transfer" - * Tcl commands. See the user documentation for details. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpShareTransferCommon( - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[], /* Argument objects. */ - int transfer) /* 1 for transfer, 0 for share */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - Tcl_Channel chan; + case OPT_MARKTRUSTED: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveMarkTrusted(interp, slaveInterp); + case OPT_RECLIMIT: + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + case OPT_SLAVES: { + InterpInfo *iiPtr; + Tcl_Obj *resultPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hashSearch; + char *string; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "srcPath channelId destPath"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, objv[1]); - if (masterInterp == NULL) { - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, TclGetString(objv[2]), NULL); - if (chan == NULL) { - /* TODO: pass TCL_ERROR */ - Tcl_TransferResult(masterInterp, TCL_OK, interp); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[3]); - if (slaveInterp == NULL) { - return TCL_ERROR; + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + resultPtr = Tcl_NewObj(); + hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { + string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj(string, -1)); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; } - Tcl_RegisterChannel(slaveInterp, chan); - if (transfer) { - /* - * When transferring, as opposed to sharing, we must unhitch the - * channel from the interpreter where it started. - */ + case OPT_TRANSFER: + case OPT_SHARE: { + Tcl_Interp *masterInterp; /* The master of the slave. */ + Tcl_Channel chan; - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - /* TODO: pass TCL_ERROR */ + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, objv[2]); + if (masterInterp == NULL) { + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, TclGetString(objv[3]), NULL); + if (chan == NULL) { Tcl_TransferResult(masterInterp, TCL_OK, interp); return TCL_ERROR; } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpTargetCmd-- - * - * Implements the "interp target" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpTargetCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; - InterpInfo *iiPtr; - Tcl_HashEntry *hPtr; - Alias *aliasPtr; - char *aliasName; + slaveInterp = GetInterp(interp, objv[4]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + if (index == OPT_TRANSFER) { + /* + * When transferring, as opposed to sharing, we must unhitch the + * channel from the interpreter where it started. + */ - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "path alias"); - return TCL_ERROR; + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + Tcl_TransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; + } + } + return TCL_OK; } + case OPT_TARGET: { + InterpInfo *iiPtr; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; + const char *aliasName; - slaveInterp = GetInterp(interp, objv[1]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path alias"); + return TCL_ERROR; + } - aliasName = TclGetString(objv[2]); + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } - 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[1]), "\" not found", NULL); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); - return TCL_ERROR; + aliasName = TclGetString(objv[3]); + + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + if (hPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" in path \"%s\" not found", + aliasName, Tcl_GetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, + NULL); + return TCL_ERROR; + } + aliasPtr = Tcl_GetHashValue(hPtr); + if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "target interpreter for alias \"%s\" in path \"%s\" is " + "not my descendant", aliasName, Tcl_GetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "TARGETSHROUDED", NULL); + return TCL_ERROR; + } + return TCL_OK; } - 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[1]), - "\" is not my descendant", NULL); - return TCL_ERROR; } return TCL_OK; } /* - *---------------------------------------------------------------------- - * - * InterpTransferCmd-- - * - * Implements the "interp transfer" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -InterpTransferCmd( - ClientData clientData, /* Unused. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return InterpShareTransferCommon(interp, objc, objv, 1); -} - -/* *--------------------------------------------------------------------------- * * GetInterp2 -- @@ -1617,12 +1141,12 @@ GetInterp2( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc == 1) { + if (objc == 2) { return interp; - } else if (objc == 2) { - return GetInterp(interp, objv[1]); + } else if (objc == 3) { + return GetInterp(interp, objv[2]); } else { - Tcl_WrongNumArgs(interp, 1, objv, "?path?"); + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); return NULL; } } @@ -1657,8 +1181,7 @@ Tcl_CreateAlias( int i; int result; - objv = (Tcl_Obj **) - TclStackAlloc(slaveInterp, (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]); @@ -1759,7 +1282,8 @@ Tcl_GetAlias( hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } @@ -1778,7 +1302,7 @@ Tcl_GetAlias( } if (argvPtr != NULL) { *argvPtr = (const char **) - ckalloc((unsigned) sizeof(const char *) * (objc - 1)); + ckalloc(sizeof(const char *) * (objc - 1)); for (i = 1; i < objc; i++) { (*argvPtr)[i - 1] = TclGetString(objv[i]); } @@ -1820,7 +1344,8 @@ Tcl_GetAliasObj( hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } @@ -1908,9 +1433,9 @@ TclPreventAliasLoop( * [Bug #641195] */ - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": interpreter deleted", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot define or rename alias \"%s\": interpreter deleted", + Tcl_GetCommandName(cmdInterp, cmd))); return TCL_ERROR; } cmdNamePtr = nextAliasPtr->objPtr; @@ -1923,9 +1448,11 @@ TclPreventAliasLoop( } aliasCmdPtr = (Command *) aliasCmd; if (aliasCmdPtr == cmdPtr) { - Tcl_AppendResult(interp, "cannot define or rename alias \"", - Tcl_GetCommandName(cmdInterp, cmd), - "\": would create a loop", 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; } @@ -1981,8 +1508,7 @@ AliasCreate( Tcl_Obj **prefv; 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; @@ -2033,7 +1559,7 @@ AliasCreate( cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); - ckfree((char *) aliasPtr); + ckfree(aliasPtr); /* * The result was already set by TclPreventAliasLoop. @@ -2051,7 +1577,7 @@ AliasCreate( slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; while (1) { Tcl_Obj *newToken; - char *string; + const char *string; string = TclGetString(aliasPtr->token); hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &isNew); @@ -2090,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) { @@ -2145,8 +1671,8 @@ AliasDelete( slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, TclGetString(namePtr)); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", TclGetString(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; @@ -2322,6 +1848,7 @@ AliasNRCmd( if (isRootEnsemble) { TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } + TclSkipTailcall(interp); return Tcl_NREvalObj(interp, listPtr, flags); } @@ -2352,7 +1879,7 @@ AliasObjCmd( if (cmdc <= ALIAS_CMDV_PREALLOC) { cmdv = cmdArr; } else { - cmdv = (Tcl_Obj **) TclStackAlloc(interp, cmdc*(int)sizeof(Tcl_Obj*)); + cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); } prefv = &aliasPtr->objPtr; @@ -2476,8 +2003,8 @@ AliasObjCmdDeleteProc( targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; } - ckfree((char *) targetPtr); - ckfree((char *) aliasPtr); + ckfree(targetPtr); + ckfree(aliasPtr); } /* @@ -2582,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 @@ -2611,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; } @@ -2675,8 +2270,8 @@ GetInterp( } } if (searchInterp == NULL) { - Tcl_AppendResult(interp, "could not find interpreter \"", - TclGetString(pathPtr), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not find interpreter \"%s\"", TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INTERP", TclGetString(pathPtr), NULL); } @@ -2713,8 +2308,10 @@ SlaveBgerror( if (TCL_ERROR == TclListObjLength(NULL, objv[0], &length) || (length < 1)) { - Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", - 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(slaveInterp, objv[0]); @@ -2752,7 +2349,7 @@ SlaveCreate( Slave *slavePtr; InterpInfo *masterInfoPtr; Tcl_HashEntry *hPtr; - char *path; + const char *path; int isNew, objc; Tcl_Obj **objv; @@ -2781,8 +2378,9 @@ SlaveCreate( hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &isNew); if (isNew == 0) { - Tcl_AppendResult(interp, "interpreter named \"", path, - "\" already exists, cannot create", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "interpreter named \"%s\" already exists, cannot create", + path)); return NULL; } @@ -2791,8 +2389,8 @@ SlaveCreate( slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, + SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); @@ -2881,17 +2479,29 @@ SlaveObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); +} + +static int +NRSlaveCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { - "alias", "aliases", "bgerror", "eval", - "expose", "hide", "hidden", "issafe", - "invokehidden", "limit", "marktrusted", "recursionlimit", NULL + "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 }; if (slaveInterp == NULL) { @@ -2936,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 ...?"); @@ -2968,7 +2588,7 @@ SlaveObjCmd( Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); return TCL_OK; case OPT_INVOKEHIDDEN: { - int i, index; + int i; const char *namespaceName; static const char *const hiddenOptions[] = { "-global", "-namespace", "--", NULL @@ -3099,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. @@ -3121,7 +2812,16 @@ SlaveEval( Tcl_Obj *const objv[]) /* Argument objects. */ { int result; - Tcl_Obj *objPtr; + + /* + * 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); @@ -3129,29 +2829,17 @@ SlaveEval( if (objc == 1) { /* * TIP #280: Make actual argument location available to eval'd script. - * - * Do not let any intReps accross, with the exception of - * bytecodes. The intrep spoiling is due to happen anyway when - * compiling. */ Interp *iPtr = (Interp *) interp; CmdFrame *invoker = iPtr->cmdFramePtr; int word = 0; - objPtr = objv[0]; - if (objPtr->typePtr && (objPtr->typePtr != &tclByteCodeType) - && objPtr->typePtr->freeIntRepProc) { - (void) TclGetString(objPtr); - TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; - } - - TclArgumentGet(interp, objPtr, &invoker, &word); + TclArgumentGet(interp, objv[0], &invoker, &word); - result = TclEvalObjEx(slaveInterp, objPtr, 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); @@ -3186,12 +2874,14 @@ SlaveExpose( 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; } @@ -3233,8 +2923,10 @@ SlaveRecursionLimit( if (objc) { if (Tcl_IsSafe(interp)) { - Tcl_AppendResult(interp, "permission denied: " - "safe interpreters cannot change recursion limit", 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 (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { @@ -3243,6 +2935,8 @@ SlaveRecursionLimit( 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); @@ -3250,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]); @@ -3285,12 +2980,14 @@ SlaveHide( 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; } @@ -3373,6 +3070,8 @@ 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; } @@ -3380,7 +3079,11 @@ SlaveInvokeHidden( 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; @@ -3399,6 +3102,23 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return result; } + +static int +NRPostInvokeHidden( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + NRE_callback *rootPtr = (NRE_callback *)data[1]; + + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } + Tcl_Release(slaveInterp); + return result; +} /* *---------------------------------------------------------------------- @@ -3427,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; @@ -3486,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; /* @@ -3665,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; } @@ -3690,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; } @@ -3767,7 +3508,7 @@ RunLimitHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } } @@ -3814,7 +3555,7 @@ Tcl_LimitAddHandler( * Allocate a handler record. */ - handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler)); + handlerPtr = ckalloc(sizeof(LimitHandler)); handlerPtr->flags = 0; handlerPtr->handlerProc = handlerProc; handlerPtr->clientData = clientData; @@ -3933,7 +3674,7 @@ Tcl_LimitRemoveHandler( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } return; } @@ -3993,7 +3734,7 @@ TclLimitRemoveAllHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } @@ -4026,7 +3767,7 @@ TclLimitRemoveAllHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - ckfree((char *) handlerPtr); + ckfree(handlerPtr); } } @@ -4272,10 +4013,20 @@ TimeLimitCallback( ClientData clientData) { Tcl_Interp *interp = clientData; + Interp *iPtr = clientData; int code; Tcl_Preserve(interp); - ((Interp *) interp)->limit.timeEvent = NULL; + iPtr->limit.timeEvent = NULL; + + /* + * Must reset the granularity ticker here to force an immediate full + * check. This is OK because we're swallowing the cost in the overall cost + * of the event loop. [Bug 2891362] + */ + + iPtr->limit.granularityTicker = 0; + code = Tcl_LimitCheck(interp); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (while waiting for event)"); @@ -4411,7 +4162,7 @@ DeleteScriptLimitCallback( if (limitCBPtr->entryPtr != NULL) { Tcl_DeleteHashEntry(limitCBPtr->entryPtr); } - ckfree((char *) limitCBPtr); + ckfree(limitCBPtr); } /* @@ -4502,7 +4253,7 @@ SetScriptLimitCallback( return; } - hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, (char *) &key, + hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key, &isNew); if (!isNew) { limitCBPtr = Tcl_GetHashValue(hashPtr); @@ -4511,7 +4262,7 @@ SetScriptLimitCallback( limitCBPtr); } - limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback)); + limitCBPtr = ckalloc(sizeof(ScriptLimitCallback)); limitCBPtr->interp = interp; limitCBPtr->scriptObj = scriptObj; limitCBPtr->entryPtr = hashPtr; @@ -4678,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; @@ -4747,8 +4512,7 @@ SlaveCommandLimitCmd( } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, limitLen = 0; @@ -4771,8 +4535,10 @@ SlaveCommandLimitCmd( 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; @@ -4786,8 +4552,10 @@ SlaveCommandLimitCmd( 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; @@ -4849,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; @@ -4935,8 +4717,7 @@ SlaveTimeLimitCmd( } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, milliLen = 0, secLen = 0; @@ -4963,8 +4744,10 @@ SlaveTimeLimitCmd( 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; @@ -4978,11 +4761,13 @@ SlaveTimeLimitCmd( 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]; @@ -4994,8 +4779,10 @@ SlaveTimeLimitCmd( 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; @@ -5010,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; } } |