From 81bf158695e5ecff209636d52392ca7f21675f23 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 13 May 2004 12:59:04 +0000 Subject: TIP#143 implementation; still needs docs and more tests... --- ChangeLog | 8 + generic/tcl.decls | 52 ++- generic/tcl.h | 20 +- generic/tclBasic.c | 16 +- generic/tclCmdAH.c | 15 +- generic/tclEvent.c | 8 +- generic/tclExecute.c | 81 ++-- generic/tclHistory.c | 10 +- generic/tclInt.h | 68 +++- generic/tclInterp.c | 1027 +++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclMain.c | 34 +- generic/tclTrace.c | 11 +- tests/interp.test | 299 +++++++-------- 13 files changed, 1445 insertions(+), 204 deletions(-) diff --git a/ChangeLog b/ChangeLog index 71efe32..a37faf1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,13 @@ 2004-05-13 Donal K. Fellows + TIP#143 IMPLEMENTATION + + * generic/tclExecute.c (TclCompEvalObj, TclExecuteByteCode): + * generic/tclBasic.c (TclEvalObjvInternal): Enable limit checking. + * generic/tclInterp.c (Tcl_Limit*): Public limit API. + * generic/tcl.decls: + * tests/interp.test: Basic tests of command limits. + * doc/binary.n: TIP#129 IMPLEMENTATION [Patch 858211] * generic/tclBinary.c: Note that the test suite probably has many more * tests/binary.test: failures now due to alterations in constraints. diff --git a/generic/tcl.decls b/generic/tcl.decls index c2dec83..97550e3 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.103 2004/03/17 18:14:12 das Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.104 2004/05/13 12:59:20 dkf Exp $ library tcl @@ -1860,6 +1860,56 @@ declare 519 generic { Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc) } +# TIP#143 API +declare 520 generic { + void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, + Tcl_LimitHandlerProc *handlerProc, ClientData clientData, + Tcl_LimitHandlerDeleteProc *deleteProc) +} +declare 521 generic { + void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type, + Tcl_LimitHandlerProc *handlerProc, ClientData clientData) +} +declare 522 generic { + int Tcl_LimitReady(Tcl_Interp *interp) +} +declare 523 generic { + int Tcl_LimitCheck(Tcl_Interp *interp) +} +declare 524 generic { + int Tcl_LimitExceeded(Tcl_Interp *interp) +} +declare 525 generic { + void Tcl_LimitSetCommands(Tcl_Interp *interp, int commandLimit) +} +declare 526 generic { + void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr) +} +declare 527 generic { + void Tcl_LimitSetGranularity(Tcl_Interp *interp, int type, int granularity) +} +declare 528 generic { + int Tcl_LimitTypeEnabled(Tcl_Interp *interp, int type) +} +declare 529 generic { + int Tcl_LimitTypeExceeded(Tcl_Interp *interp, int type) +} +declare 530 generic { + void Tcl_LimitTypeSet(Tcl_Interp *interp, int type) +} +declare 531 generic { + void Tcl_LimitTypeReset(Tcl_Interp *interp, int type) +} +declare 532 generic { + int Tcl_LimitGetCommands(Tcl_Interp *interp) +} +declare 533 generic { + void Tcl_LimitGetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr) +} +declare 534 generic { + int Tcl_LimitGetGranularity(Tcl_Interp *interp, int type) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tcl.h b/generic/tcl.h index c82a22e..1416b66 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.177 2004/04/25 20:15:57 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.178 2004/05/13 12:59:21 dkf Exp $ */ #ifndef _TCL @@ -2220,6 +2220,24 @@ typedef struct Tcl_Config { } Tcl_Config; +/* + * Flags for TIP#143 limits, detailing which limits are active in an + * interpreter. Used for Tcl_{Add,Remove}LimitHandler type argument. + */ + +#define TCL_LIMIT_COMMANDS 0x01 +#define TCL_LIMIT_TIME 0x02 + +/* + * Structure containing information about a limit handler to be called + * when a command- or time-limit is exceeded by an interpreter. + */ + +typedef void (Tcl_LimitHandlerProc) _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +typedef void (Tcl_LimitHandlerDeleteProc) _ANSI_ARGS_((ClientData clientData)); + + #ifndef TCL_NO_DEPRECATED /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a01f57b..71f377d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.99 2004/04/06 22:25:48 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.100 2004/05/13 12:59:21 dkf Exp $ */ #include "tclInt.h" @@ -411,7 +411,12 @@ Tcl_CreateInterp() iPtr->stubTable = &tclStubs; - + /* + * TIP#143: Initialise the resource limit support. + */ + + TclInitLimitSupport(interp); + /* * Create the core commands. Do it here, rather than calling * Tcl_CreateCommand, because it's faster (there's no need to check for @@ -3121,7 +3126,7 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) */ cmdPtr->refCount++; iPtr->cmdCount++; - if ( code == TCL_OK && traceCode == TCL_OK) { + if (code == TCL_OK && traceCode == TCL_OK && !Tcl_LimitExceeded(interp)) { savedVarFramePtr = iPtr->varFramePtr; if (flags & TCL_EVAL_GLOBAL) { iPtr->varFramePtr = NULL; @@ -3132,6 +3137,9 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) if (Tcl_AsyncReady()) { code = Tcl_AsyncInvoke(interp, code); } + if (code == TCL_OK && Tcl_LimitReady(interp)) { + code = Tcl_LimitCheck(interp); + } /* * Call 'leave' command traces @@ -3142,7 +3150,7 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) Tcl_Obj *saveOptions = iPtr->returnOpts; Tcl_IncrRefCount(saveOptions); if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces (interp, command, length, + traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); } if (iPtr->tracePtr != NULL && traceCode == TCL_OK) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index d80e32f..66ed491 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.44 2004/04/06 22:25:48 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.45 2004/05/13 12:59:21 dkf Exp $ */ #include "tclInt.h" @@ -256,7 +256,18 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) } result = Tcl_EvalObjEx(interp, objv[1], 0); - + + /* + * We disable catch in interpreters where the limit has been exceeded. + */ + if (Tcl_LimitExceeded(interp)) { + char msg[32 + TCL_INTEGER_SPACE]; + + sprintf(msg, "\n (\"catch\" body line %d)", interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + return TCL_ERROR; + } + if (objc >= 3) { if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, Tcl_GetObjResult(interp), 0)) { diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 029d297..bc307dc 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.36 2004/05/04 13:27:26 dkf Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.37 2004/05/13 12:59:21 dkf Exp $ */ #include "tclInt.h" @@ -1114,6 +1114,9 @@ Tcl_VwaitObjCmd(clientData, interp, objc, objv) foundEvent = 1; while (!done && foundEvent) { foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); + if (Tcl_LimitExceeded(interp)) { + return TCL_ERROR; + } } Tcl_UntraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, @@ -1200,6 +1203,9 @@ Tcl_UpdateObjCmd(clientData, interp, objc, objv) } while (Tcl_DoOneEvent(flags) != 0) { + if (Tcl_LimitExceeded(interp)) { + return TCL_ERROR; + } } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6182a51..dd527fb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.125 2004/05/12 17:43:55 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.126 2004/05/13 12:59:22 dkf Exp $ */ #include "tclInt.h" @@ -1011,26 +1011,39 @@ TclCompEvalObj(interp, objPtr) } iPtr->numLevels--; - /* * If no commands at all were executed, check for asynchronous - * handlers so that they at least get one change to execute. - * This is needed to handle event loops written in Tcl with - * empty bodies. + * handlers and resource limits so that they at least get one + * change to execute. This is needed to handle event loops + * written in Tcl with empty bodies. */ - if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) { - result = Tcl_AsyncInvoke(interp, result); - + if (oldCount == iPtr->cmdCount) { + if (Tcl_AsyncReady()) { + result = Tcl_AsyncInvoke(interp, result); - /* - * If an error occurred, record information about what was being - * executed when the error occurred. - */ - - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - Tcl_LogCommandInfo(interp, script, script, numSrcBytes); + /* + * If an error occurred, record information about what was + * being executed when the error occurred. + */ + + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); + } + } + if (result==TCL_OK && Tcl_LimitReady(interp)) { + result = Tcl_LimitCheck(interp); + + /* + * If an error occurred, record information about what was + * being executed when the error occurred. + */ + + if (result==TCL_ERROR && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + Tcl_LogCommandInfo(interp, script, script, numSrcBytes); + } } } @@ -1229,12 +1242,22 @@ TclExecuteByteCode(interp, codePtr) * of the form (2**n-1). */ - if (!(instructionCount++ & ASYNC_CHECK_COUNT_MASK) && Tcl_AsyncReady()) { - DECACHE_STACK_INFO(); - result = Tcl_AsyncInvoke(interp, result); - CACHE_STACK_INFO(); - if (result == TCL_ERROR) { - goto checkForCatch; + if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { + if (Tcl_AsyncReady()) { + DECACHE_STACK_INFO(); + result = Tcl_AsyncInvoke(interp, result); + CACHE_STACK_INFO(); + if (result == TCL_ERROR) { + goto checkForCatch; + } + } + if (Tcl_LimitReady(interp)) { + DECACHE_STACK_INFO(); + result = Tcl_LimitCheck(interp); + CACHE_STACK_INFO(); + if (result == TCL_ERROR) { + goto checkForCatch; + } } } @@ -4558,6 +4581,20 @@ TclExecuteByteCode(interp, codePtr) iPtr->flags |= ERR_ALREADY_LOGGED; } } + /* + * We must not catch an exceeded limit. Instead, it blows + * outwards until we either hit another interpreter (presumably + * where the limit is not exceeded) or we get to the top-level. + */ + if (Tcl_LimitExceeded(interp)) { +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... limit exceeded, returning %s\n", + StringForResultCode(result)); + } +#endif + goto abnormalReturn; + } if (catchTop == initCatchTop) { #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 90ef855..4598a6a 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclHistory.c,v 1.5 2004/04/06 22:25:51 dgp Exp $ + * RCS: @(#) $Id: tclHistory.c,v 1.6 2004/05/13 12:59:22 dkf Exp $ */ #include "tclInt.h" @@ -133,6 +133,14 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags) Tcl_DecrRefCount(objPtr); /* + * One possible failure mode above: exceeding a resource limit + */ + + if (Tcl_LimitExceeded(interp)) { + return TCL_ERROR; + } + + /* * Execute the command. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 4b74c7b..b6a0dab 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.158 2004/05/06 04:41:53 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.159 2004/05/13 12:59:22 dkf Exp $ */ #ifndef _TCLINT @@ -1126,6 +1126,12 @@ typedef struct ResolverScheme { } ResolverScheme; /* + * Forward declaration of the TIP#143 limit handler structure. + */ + +typedef struct LimitHandler LimitHandler; + +/* *---------------------------------------------------------------- * This structure defines an interpreter, which is a collection of * commands plus other state information related to interpreting @@ -1325,6 +1331,39 @@ typedef struct Interp { Tcl_Obj *returnOptionsKey; /* holds "-options" */ /* + * Resource limiting framework support (TIP#143). + */ + + struct { + int active; /* Flag values defining which limits have + * been set. */ + int granularityTicker; /* Counter used to determine how often to + * check the limits. */ + int exceeded; /* Which limits have been exceeded, described + * as flag values the same as the 'active' + * field. */ + + int cmdCount; /* Limit for how many commands to execute + * in the interpreter. */ + LimitHandler *cmdHandlers; /* Handlers to execute when the limit + * is reached. */ + int cmdGranularity; /* Mod factor used to determine how often + * to evaluate the limit check. */ + + Tcl_Time time; /* Time limit for execution within the + * interpreter (in seconds from epoch). */ + LimitHandler *timeHandlers; /* Handlers to execute when the limit + * is reached. */ + int timeGranularity; /* Mod factor used to determine how often + * to evaluate the limit check. */ + + Tcl_HashTable callbacks; /* Mapping from (interp,type) pair to data + * used to install a limit handler callback + * to run in _this_ interp when the limit + * is exceeded. */ + } limit; + + /* * Statistical information about the bytecode compiler and interpreter's * operation. */ @@ -1403,6 +1442,32 @@ typedef struct Interp { #define MAX_NESTING_DEPTH 1000 /* + * 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 + +/* * The macro below is used to modify a "char" value (e.g. by casting * it to an unsigned character) so that it can be used safely with * macros such as isspace. @@ -1694,6 +1759,7 @@ EXTERN int TclIsLocalScalar _ANSI_ARGS_((CONST char *src, int len)); EXTERN int TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id, int* result)); +EXTERN void TclInitLimitSupport _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN Tcl_Obj * TclLindexList _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* listPtr, Tcl_Obj* argPtr )); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 56ab62b..edb5bbc 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -9,7 +9,7 @@ * 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.26 2004/04/06 22:25:53 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.27 2004/05/13 12:59:23 dkf Exp $ */ #include "tclInt.h" @@ -145,6 +145,24 @@ typedef struct InterpInfo { } InterpInfo; /* + * Limit callbacks handled by scripts are modelled as structures which + * are stored in hashes indexed by a two-word key. Note that the type + * of the 'type' field in the key is not int; this is to make sure + * that things work properly on 64-bit architectures. + */ + +struct ScriptLimitCallback { + Tcl_Interp *interp; + Tcl_Obj *scriptObj; + int type; +}; + +struct ScriptLimitCallbackKey { + Tcl_Interp *interp; + long type; +}; + +/* * Prototypes for local static procedures: */ @@ -196,6 +214,23 @@ static void SlaveObjCmdDeleteProc _ANSI_ARGS_(( static int SlaveRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *CONST objv[])); +static int SlaveCommandLimit _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int consumedObjc, + int objc, Tcl_Obj *CONST objv[])); +static int SlaveTimeLimit _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int consumedObjc, + int objc, Tcl_Obj *CONST objv[])); +static void InheritLimits _ANSI_ARGS_((Tcl_Interp *slaveInterp, + Tcl_Interp *masterInterp)); +static void SetLimitCallback _ANSI_ARGS_((Tcl_Interp *interp, + int type, Tcl_Interp *targetInterp, + Tcl_Obj *scriptObj)); +static void CallScriptLimitCallback _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void DeleteScriptLimitCallback _ANSI_ARGS_(( + ClientData clientData)); +static void RunLimitHandlers _ANSI_ARGS_((LimitHandler *handlerPtr, + Tcl_Interp *interp)); /* @@ -357,16 +392,16 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) static CONST char *options[] = { "alias", "aliases", "create", "delete", "eval", "exists", "expose", "hide", - "hidden", "issafe", "invokehidden", "marktrusted", - "recursionlimit", "slaves", "share", + "hidden", "issafe", "invokehidden", "limit", + "marktrusted", "recursionlimit","slaves", "share", "target", "transfer", NULL }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, - OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_MARKTRUSTED, - OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE, + OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_LIMIT, + OPT_MARKTRUSTED,OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER }; @@ -628,6 +663,35 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) return SlaveInvokeHidden(interp, slaveInterp, global, objc - i, objv + i); } + case OPT_LIMIT: { + Tcl_Interp *slaveInterp; + static CONST char *limitTypes[] = { + "commands", "time", NULL + }; + enum LimitTypes { + LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME + }; + int limitType; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?"); + 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 SlaveCommandLimit(interp, slaveInterp, 4, objc, objv); + case LIMIT_TYPE_TIME: + return SlaveTimeLimit(interp, slaveInterp, 4, objc, objv); + } + } case OPT_MARKTRUSTED: { Tcl_Interp *slaveInterp; @@ -1838,6 +1902,12 @@ SlaveCreate(interp, pathPtr, safe) */ Tcl_InitMemory(slaveInterp); } + + /* + * Inherit the TIP#143 limits. + */ + InheritLimits(slaveInterp, masterInterp); + return slaveInterp; error: @@ -1874,14 +1944,14 @@ SlaveObjCmd(clientData, interp, objc, objv) Tcl_Interp *slaveInterp; int index; static CONST char *options[] = { - "alias", "aliases", "eval", "expose", - "hide", "hidden", "issafe", "invokehidden", - "marktrusted", "recursionlimit", NULL + "alias", "aliases", "eval", "expose", + "hide", "hidden", "issafe", "invokehidden", + "limit", "marktrusted", "recursionlimit", NULL }; enum options { OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, - OPT_MARKTRUSTED, OPT_RECLIMIT + OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT }; slaveInterp = (Tcl_Interp *) clientData; @@ -1992,6 +2062,30 @@ SlaveObjCmd(clientData, interp, objc, objv) return SlaveInvokeHidden(interp, slaveInterp, global, objc - i, objv + i); } + case OPT_LIMIT: { + static CONST char *limitTypes[] = { + "commands", "time", NULL + }; + enum LimitTypes { + LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME + }; + int limitType; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?"); + 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 SlaveCommandLimit(interp, slaveInterp, 3, objc, objv); + case LIMIT_TYPE_TIME: + return SlaveTimeLimit(interp, slaveInterp, 3, objc, objv); + } + } case OPT_MARKTRUSTED: { if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -2486,3 +2580,918 @@ Tcl_MakeSafe(interp) return TCL_OK; } + +int +Tcl_LimitExceeded(interp) + Tcl_Interp *interp; +{ + register Interp *iPtr = (Interp *) interp; + + return iPtr->limit.exceeded != 0; +} + +int +Tcl_LimitReady(interp) + Tcl_Interp *interp; +{ + register Interp *iPtr = (Interp *) interp; + + if (iPtr->limit.active != 0) { + register int ticker = ++iPtr->limit.granularityTicker; + + if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && + ((iPtr->limit.cmdGranularity == 1) || + (ticker % iPtr->limit.cmdGranularity == 0))) { + return 1; + } + if ((iPtr->limit.active & TCL_LIMIT_TIME) && + ((iPtr->limit.timeGranularity == 1) || + (ticker % iPtr->limit.timeGranularity == 0))) { + return 1; + } + } + return 0; +} + +int +Tcl_LimitCheck(interp) + Tcl_Interp *interp; +{ + Interp *iPtr = (Interp *) interp; + register int ticker = iPtr->limit.granularityTicker; + + if (Tcl_InterpDeleted(interp)) { + return TCL_OK; + } + + if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && + ((iPtr->limit.cmdGranularity == 1) || + (ticker % iPtr->limit.cmdGranularity == 0)) && + (iPtr->limit.cmdCount < iPtr->cmdCount)) { + iPtr->limit.exceeded |= TCL_LIMIT_COMMANDS; + Tcl_Preserve(interp); + RunLimitHandlers(iPtr->limit.cmdHandlers, interp); + if (iPtr->limit.cmdCount >= iPtr->cmdCount) { + iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; + } else { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "command count limit exceeded", NULL); + Tcl_Release(interp); + return TCL_ERROR; + } + } + + if ((iPtr->limit.active & TCL_LIMIT_TIME) && + ((iPtr->limit.timeGranularity == 1) || + (ticker % iPtr->limit.timeGranularity == 0))) { + Tcl_Time now; + + Tcl_GetTime(&now); + if (iPtr->limit.time.sec < now.sec || + (iPtr->limit.time.sec == now.sec && + iPtr->limit.time.usec < now.usec)) { + iPtr->limit.exceeded |= TCL_LIMIT_TIME; + Tcl_Preserve(interp); + RunLimitHandlers(iPtr->limit.timeHandlers, interp); + if (iPtr->limit.time.sec < now.sec || + (iPtr->limit.time.sec == now.sec && + iPtr->limit.time.usec < now.usec)) { + iPtr->limit.exceeded &= ~TCL_LIMIT_TIME; + } else { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "time limit exceeded", NULL); + Tcl_Release(interp); + return TCL_ERROR; + } + } + } + + return TCL_OK; +} + +static void +RunLimitHandlers(handlerPtr, interp) + LimitHandler *handlerPtr; + Tcl_Interp *interp; +{ + LimitHandler *nextPtr; + for (; handlerPtr!=NULL ; handlerPtr=nextPtr) { + if (handlerPtr->flags & (LIMIT_HANDLER_DELETED|LIMIT_HANDLER_ACTIVE)) { + /* + * Reentrant call or something seriously strange in the + * delete code. + */ + nextPtr = handlerPtr->nextPtr; + continue; + } + + /* + * Set the ACTIVE flag while running the limit handler itself + * so we cannot reentrantly call this handler and know to use + * the alternate method of deletion if necessary. + */ + + handlerPtr->flags |= LIMIT_HANDLER_ACTIVE; + (handlerPtr->handlerProc)(handlerPtr->clientData, interp); + handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE; + + /* + * Rediscover this value; it might have changed during the + * processing of a limit handler. We have to record it here + * because we might delete the structure below, and reading a + * value out of a deleted structure is unsafe (even if + * actually legal with some malloc()/free() implementations.) + */ + + nextPtr = handlerPtr->nextPtr; + + /* + * If we deleted the current handler while we were executing + * it, we will have spliced it out of the list and set the + * LIMIT_HANDLER_DELETED flag. + */ + if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { + if (handlerPtr->deleteProc != NULL) { + (handlerPtr->deleteProc)(handlerPtr->clientData); + } + ckfree((char *) handlerPtr); + } + } +} + +void +Tcl_LimitAddHandler(interp, type, handlerProc, clientData, deleteProc) + Tcl_Interp *interp; + int type; + Tcl_LimitHandlerProc *handlerProc; + ClientData clientData; + Tcl_LimitHandlerDeleteProc *deleteProc; +{ + Interp *iPtr = (Interp *) interp; + LimitHandler *handlerPtr; + + if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) { + deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Alloc; + } + if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) { + deleteProc = (Tcl_LimitHandlerDeleteProc *) NULL; + } + + switch (type) { + case TCL_LIMIT_COMMANDS: + handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler)); + + handlerPtr->flags = 0; + handlerPtr->handlerProc = handlerProc; + handlerPtr->clientData = clientData; + handlerPtr->deleteProc = deleteProc; + handlerPtr->prevPtr = NULL; + handlerPtr->nextPtr = iPtr->limit.cmdHandlers; + if (handlerPtr->nextPtr != NULL) { + handlerPtr->nextPtr->prevPtr = handlerPtr; + } + iPtr->limit.cmdHandlers = handlerPtr; + return; + + case TCL_LIMIT_TIME: + handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler)); + + handlerPtr->flags = 0; + handlerPtr->handlerProc = handlerProc; + handlerPtr->clientData = clientData; + handlerPtr->deleteProc = deleteProc; + handlerPtr->prevPtr = NULL; + handlerPtr->nextPtr = iPtr->limit.timeHandlers; + if (handlerPtr->nextPtr != NULL) { + handlerPtr->nextPtr->prevPtr = handlerPtr; + } + iPtr->limit.timeHandlers = handlerPtr; + return; + } + + Tcl_Panic("unknown type of resource limit"); +} + +void +Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData) + Tcl_Interp *interp; + int type; + Tcl_LimitHandlerProc *handlerProc; + ClientData clientData; +{ + Interp *iPtr = (Interp *) interp; + LimitHandler *handlerPtr; + + switch (type) { + case TCL_LIMIT_COMMANDS: + handlerPtr = iPtr->limit.cmdHandlers; + break; + case TCL_LIMIT_TIME: + handlerPtr = iPtr->limit.timeHandlers; + break; + default: + Tcl_Panic("unknown type of resource limit"); + } + + for (; handlerPtr!=NULL ; handlerPtr=handlerPtr->nextPtr) { + if ((handlerPtr->handlerProc != handlerProc) || + (handlerPtr->clientData != clientData)) { + continue; + } + + /* + * We've found the handler to delete; mark it as doomed if not + * already so marked (which shouldn't actually happen). + */ + + if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { + return; + } + handlerPtr->flags |= LIMIT_HANDLER_DELETED; + + /* + * Splice the handler out of the doubly-linked list. + */ + + if (handlerPtr->prevPtr == NULL) { + switch (type) { + case TCL_LIMIT_COMMANDS: + iPtr->limit.cmdHandlers = handlerPtr->nextPtr; + break; + case TCL_LIMIT_TIME: + iPtr->limit.timeHandlers = handlerPtr->nextPtr; + break; + } + } else { + handlerPtr->prevPtr->nextPtr = handlerPtr->nextPtr; + } + if (handlerPtr->nextPtr != NULL) { + handlerPtr->nextPtr->prevPtr = handlerPtr->prevPtr; + } + + /* + * If nothing is currently executing the handler, delete its + * client data and the overall handler structure now. + * Otherwise it will all go away when the handler returns. + */ + + if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { + if (handlerPtr->deleteProc != NULL) { + (handlerPtr->deleteProc)(handlerPtr->clientData); + } + ckfree((char *) handlerPtr); + } + return; + } +} + +int +Tcl_LimitTypeEnabled(interp, type) + Tcl_Interp *interp; + int type; +{ + Interp *iPtr = (Interp *) interp; + + return (iPtr->limit.active & type) != 0; +} + +int +Tcl_LimitTypeExceeded(interp, type) + Tcl_Interp *interp; + int type; +{ + Interp *iPtr = (Interp *) interp; + + return (iPtr->limit.exceeded & type) != 0; +} + +void +Tcl_LimitTypeSet(interp, type) + Tcl_Interp *interp; + int type; +{ + Interp *iPtr = (Interp *) interp; + + iPtr->limit.active |= type; +} + +void +Tcl_LimitTypeReset(interp, type) + Tcl_Interp *interp; + int type; +{ + Interp *iPtr = (Interp *) interp; + + iPtr->limit.active &= ~type; +} + +void +Tcl_LimitSetCommands(interp, commandLimit) + Tcl_Interp *interp; + int commandLimit; +{ + Interp *iPtr = (Interp *) interp; + + iPtr->limit.cmdCount = commandLimit; + iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; +} + +int +Tcl_LimitGetCommands(interp) + Tcl_Interp *interp; +{ + Interp *iPtr = (Interp *) interp; + + return iPtr->limit.cmdCount; +} + +void +Tcl_LimitSetTime(interp, timeLimitPtr) + Tcl_Interp *interp; + Tcl_Time *timeLimitPtr; +{ + Interp *iPtr = (Interp *) interp; + + memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time)); + iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS; +} + +void +Tcl_LimitGetTime(interp, timeLimitPtr) + Tcl_Interp *interp; + Tcl_Time *timeLimitPtr; +{ + Interp *iPtr = (Interp *) interp; + + memcpy(timeLimitPtr, &iPtr->limit.time, sizeof(Tcl_Time)); +} + +void +Tcl_LimitSetGranularity(interp, type, granularity) + Tcl_Interp *interp; + int type; + int granularity; +{ + Interp *iPtr = (Interp *) interp; + if (granularity < 1) { + Tcl_Panic("limit granularity must be positive"); + } + + switch (type) { + case TCL_LIMIT_COMMANDS: + iPtr->limit.cmdGranularity = granularity; + return; + case TCL_LIMIT_TIME: + iPtr->limit.timeGranularity = granularity; + return; + } + Tcl_Panic("unknown type of resource limit"); +} + +int +Tcl_LimitGetGranularity(interp, type) + Tcl_Interp *interp; + int type; +{ + Interp *iPtr = (Interp *) interp; + + switch (type) { + case TCL_LIMIT_COMMANDS: + return iPtr->limit.cmdGranularity; + case TCL_LIMIT_TIME: + return iPtr->limit.timeGranularity; + } + Tcl_Panic("unknown type of resource limit"); + return -1; /* NOT REACHED */ +} + +/* + * Callback for when a script limit is deleted. + */ +static void +DeleteScriptLimitCallback(clientData) + ClientData clientData; +{ + struct ScriptLimitCallback *limitCBPtr = + (struct ScriptLimitCallback *) clientData; + + Tcl_DecrRefCount(limitCBPtr->scriptObj); + ckfree((char *) limitCBPtr); +} + +/* + * Callback for when a script limit is invoked. + */ +static void +CallScriptLimitCallback(clientData, interp) + ClientData clientData; + Tcl_Interp *interp; /* Interpreter which failed the limit */ +{ + struct ScriptLimitCallback *limitCBPtr = + (struct ScriptLimitCallback *) clientData; + int code; + + if (Tcl_InterpDeleted(limitCBPtr->interp)) { + return; + } + Tcl_Preserve(limitCBPtr->interp); + code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj, + TCL_EVAL_GLOBAL); + if (code != TCL_OK && !Tcl_InterpDeleted(limitCBPtr->interp)) { + Tcl_BackgroundError(limitCBPtr->interp); + } + Tcl_Release(limitCBPtr->interp); +} + +/* + * Install (or remove, if scriptObj is NULL) a limit callback script + * that is called when the target interpreter exceeds the type of + * limit specified. + */ +static void +SetLimitCallback(interp, type, targetInterp, scriptObj) + Tcl_Interp *interp; + int type; + Tcl_Interp *targetInterp; + Tcl_Obj *scriptObj; +{ + struct ScriptLimitCallback *limitCBPtr; + Tcl_HashEntry *hashPtr; + int isNew; + struct ScriptLimitCallbackKey key; + Interp *iPtr = (Interp *) interp; + + if (interp == targetInterp) { + Tcl_Panic("installing limit callback to the limited interpreter"); + } + + key.interp = targetInterp; + key.type = type; + + if (scriptObj == NULL) { + hashPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); + if (hashPtr != NULL) { + Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, + Tcl_GetHashValue(hashPtr)); + Tcl_DeleteHashEntry(hashPtr); + } + return; + } + + limitCBPtr = (struct ScriptLimitCallback *) + ckalloc(sizeof(struct ScriptLimitCallback)); + limitCBPtr->interp = interp; + limitCBPtr->scriptObj = scriptObj; + limitCBPtr->type = type; + Tcl_IncrRefCount(scriptObj); + + hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, (char *) &key, + &isNew); + if (!isNew) { + Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, + Tcl_GetHashValue(hashPtr)); + } + Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback, + (ClientData) limitCBPtr, DeleteScriptLimitCallback); + Tcl_SetHashValue(hashPtr, (ClientData) limitCBPtr); +} + +/* + * Remove all limit callback scripts that make callbacks into the + * given interpreter. + */ + +void +TclDecommissionLimitCallbacks(interp) + Tcl_Interp *interp; +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hashPtr; + Tcl_HashSearch search; + struct ScriptLimitCallbackKey *keyPtr; + + hashPtr = Tcl_FirstHashEntry(&iPtr->limit.callbacks, &search); + while (hashPtr != NULL) { + keyPtr = (struct ScriptLimitCallbackKey *) + Tcl_GetHashKey(&iPtr->limit.callbacks, hashPtr); + Tcl_LimitRemoveHandler(keyPtr->interp, keyPtr->type, + CallScriptLimitCallback, Tcl_GetHashValue(hashPtr)); + hashPtr = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(&iPtr->limit.callbacks); +} + +void +TclInitLimitSupport(interp) + Tcl_Interp *interp; +{ + Interp *iPtr = (Interp *) interp; + + iPtr->limit.active = 0; + iPtr->limit.granularityTicker = 0; + iPtr->limit.exceeded = 0; + iPtr->limit.cmdCount = 0; + iPtr->limit.cmdHandlers = NULL; + iPtr->limit.cmdGranularity = 1; + memset(&iPtr->limit.time, 0, sizeof(Tcl_Time)); + iPtr->limit.timeHandlers = NULL; + iPtr->limit.timeGranularity = 10; + Tcl_InitHashTable(&iPtr->limit.callbacks, + sizeof(struct ScriptLimitCallbackKey)/sizeof(ClientData)); +} + +static void +InheritLimits(slaveInterp, masterInterp) + Tcl_Interp *slaveInterp, *masterInterp; +{ + Interp *slavePtr = (Interp *) slaveInterp; + Interp *masterPtr = (Interp *) masterInterp; + + if (masterPtr->limit.active & TCL_LIMIT_COMMANDS) { + slavePtr->limit.active |= TCL_LIMIT_COMMANDS; + slavePtr->limit.cmdCount = 0; + slavePtr->limit.cmdGranularity = masterPtr->limit.cmdGranularity; + } + if (masterPtr->limit.active & TCL_LIMIT_TIME) { + slavePtr->limit.active |= TCL_LIMIT_TIME; + memcpy(&slavePtr->limit.time, &masterPtr->limit.time, + sizeof(Tcl_Time)); + slavePtr->limit.timeGranularity = masterPtr->limit.timeGranularity; + } +} + +static int +SlaveCommandLimit(interp, slaveInterp, consumedObjc, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* Interpreter being adjusted. */ + int consumedObjc; /* Number of args already parsed. */ + int objc; /* Total number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + static CONST char *options[] = { + "-command", "-granularity", "-value", NULL + }; + enum Options { + OPT_CMD, OPT_GRAN, OPT_VAL + }; + Interp *iPtr = (Interp *) interp; + int index; + struct ScriptLimitCallbackKey key; + struct ScriptLimitCallback *limitCBPtr; + Tcl_HashEntry *hPtr; + + if (objc == consumedObjc) { + Tcl_Obj *dictPtr; + + TclNewObj(dictPtr); + key.interp = slaveInterp; + key.type = TCL_LIMIT_COMMANDS; + hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); + if (hPtr != NULL) { + limitCBPtr = (struct ScriptLimitCallback *) + Tcl_GetHashValue(hPtr); + if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { + Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), + limitCBPtr->scriptObj); + } else { + goto putEmptyCommandInDict; + } + } else { + Tcl_Obj *empty; + putEmptyCommandInDict: + TclNewObj(empty); + Tcl_DictObjPut(NULL, dictPtr, + Tcl_NewStringObj(options[0], -1), empty); + } + Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), + Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, + TCL_LIMIT_COMMANDS))); + + if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { + Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), + Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); + } else { + Tcl_Obj *empty; + + TclNewObj(empty); + Tcl_DictObjPut(NULL, dictPtr, + Tcl_NewStringObj(options[2], -1), empty); + } + Tcl_SetObjResult(interp, dictPtr); + return TCL_OK; + } else if (objc == consumedObjc+1) { + if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum Options) index) { + case OPT_CMD: + key.interp = slaveInterp; + key.type = TCL_LIMIT_COMMANDS; + hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); + if (hPtr != NULL) { + limitCBPtr = (struct ScriptLimitCallback *) + Tcl_GetHashValue(hPtr); + if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { + Tcl_SetObjResult(interp, limitCBPtr->scriptObj); + } + } + break; + case OPT_GRAN: + Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); + break; + case OPT_VAL: + if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { + Tcl_SetObjResult(interp, + Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); + } + break; + } + return TCL_OK; + } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { + Tcl_WrongNumArgs(interp, consumedObjc, objv, + "?-option? ?value? ?-option value ...?"); + return TCL_ERROR; + } else { + int i, scriptLen = 0, limitLen = 0; + Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL; + int gran = 0, limit = 0; + + for (i=consumedObjc ; i 0 ? scriptObj : NULL)); + } + if (granObj != NULL) { + Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran); + } + if (limitObj != NULL) { + if (limitLen > 0) { + Tcl_LimitSetCommands(slaveInterp, limit); + Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS); + } else { + Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS); + } + } + return TCL_OK; + } +} + +static int +SlaveTimeLimit(interp, slaveInterp, consumedObjc, objc, objv) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Interp *slaveInterp; /* Interpreter being adjusted. */ + int consumedObjc; /* Number of args already parsed. */ + int objc; /* Total number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + static CONST char *options[] = { + "-command", "-granularity", "-milliseconds", "-seconds", NULL + }; + enum Options { + OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC + }; + Interp *iPtr = (Interp *) interp; + int index; + struct ScriptLimitCallbackKey key; + struct ScriptLimitCallback *limitCBPtr; + Tcl_HashEntry *hPtr; + + if (objc == consumedObjc) { + Tcl_Obj *dictPtr; + + TclNewObj(dictPtr); + key.interp = slaveInterp; + key.type = TCL_LIMIT_TIME; + hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); + if (hPtr != NULL) { + limitCBPtr = (struct ScriptLimitCallback *) + Tcl_GetHashValue(hPtr); + if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { + Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), + limitCBPtr->scriptObj); + } else { + goto putEmptyCommandInDict; + } + } else { + Tcl_Obj *empty; + putEmptyCommandInDict: + TclNewObj(empty); + Tcl_DictObjPut(NULL, dictPtr, + Tcl_NewStringObj(options[0], -1), empty); + } + Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), + Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, + TCL_LIMIT_TIME))); + + if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + Tcl_Time limitMoment; + + Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), + Tcl_NewLongObj(limitMoment.usec/1000)); + Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1), + Tcl_NewLongObj(limitMoment.sec)); + } else { + Tcl_Obj *empty; + + TclNewObj(empty); + Tcl_DictObjPut(NULL, dictPtr, + Tcl_NewStringObj(options[2], -1), empty); + Tcl_DictObjPut(NULL, dictPtr, + Tcl_NewStringObj(options[3], -1), empty); + } + Tcl_SetObjResult(interp, dictPtr); + return TCL_OK; + } else if (objc == consumedObjc+1) { + if (Tcl_GetIndexFromObj(interp, objv[consumedObjc], options, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum Options) index) { + case OPT_CMD: + key.interp = slaveInterp; + key.type = TCL_LIMIT_TIME; + hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); + if (hPtr != NULL) { + limitCBPtr = (struct ScriptLimitCallback *) + Tcl_GetHashValue(hPtr); + if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { + Tcl_SetObjResult(interp, limitCBPtr->scriptObj); + } + } + break; + case OPT_GRAN: + Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME))); + break; + case OPT_MILLI: + if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + Tcl_Time limitMoment; + + Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_SetObjResult(interp, + Tcl_NewLongObj(limitMoment.usec/1000)); + } + break; + case OPT_SEC: + if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { + Tcl_Time limitMoment; + + Tcl_LimitGetTime(slaveInterp, &limitMoment); + Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec)); + } + break; + } + return TCL_OK; + } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { + Tcl_WrongNumArgs(interp, consumedObjc, objv, + "?-option? ?value? ?-option value ...?"); + return TCL_ERROR; + } else { + int i, scriptLen = 0, milliLen = 0, secLen = 0; + Tcl_Obj *scriptObj = NULL, *granObj = NULL; + Tcl_Obj *milliObj = NULL, *secObj = NULL; + int gran = 0; + Tcl_Time limitMoment; + int tmp; + + Tcl_LimitGetTime(slaveInterp, &limitMoment); + for (i=consumedObjc ; i 0) { + Tcl_AppendResult(interp, "may only set -milliseconds ", + "if -seconds is not also being reset", 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); + return TCL_ERROR; + } + } + + if (milliLen > 0 || secLen > 0) { + /* + * Force usec to be in range [0..1000000), possibly + * incrementing sec in the process. This makes it + * much easier for people to write scripts that do + * small time increments. + */ + limitMoment.sec += limitMoment.usec / 1000000; + limitMoment.usec %= 1000000; + + Tcl_LimitSetTime(slaveInterp, &limitMoment); + Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_TIME); + } else { + Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_TIME); + } + } + if (scriptObj != NULL) { + SetLimitCallback(interp, TCL_LIMIT_TIME, slaveInterp, + (scriptLen > 0 ? scriptObj : NULL)); + } + if (granObj != NULL) { + Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_TIME, gran); + } + return TCL_OK; + } +} diff --git a/generic/tclMain.c b/generic/tclMain.c index b4c144e..f1ca13f 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMain.c,v 1.25 2004/04/06 22:25:54 dgp Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.26 2004/05/13 12:59:23 dkf Exp $ */ #include "tclInt.h" @@ -272,7 +272,7 @@ Tcl_Main(argc, argv, appInitProc) Tcl_Obj *resultPtr; Tcl_Obj *commandPtr = NULL; CONST char *encodingName = NULL; - char buffer[TCL_INTEGER_SPACE + 5], *args; + char *args; PromptType prompt = PROMPT_START; int code, length, tty; int exitCode = 0; @@ -334,8 +334,8 @@ Tcl_Main(argc, argv, appInitProc) Tcl_SetStartupScript(path, encodingName); } - TclFormatInt(buffer, (long) argc-1); - Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc-1), + TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); /* @@ -363,6 +363,9 @@ Tcl_Main(argc, argv, appInitProc) if (Tcl_InterpDeleted(interp)) { goto done; } + if (Tcl_LimitExceeded(interp)) { + goto done; + } /* * If a script file was specified then just source that file @@ -399,6 +402,9 @@ Tcl_Main(argc, argv, appInitProc) */ Tcl_SourceRCFile(interp); + if (Tcl_LimitExceeded(interp)) { + goto done; + } /* * Process commands from stdin until there's an end-of-file. Note @@ -421,6 +427,9 @@ Tcl_Main(argc, argv, appInitProc) if (Tcl_InterpDeleted(interp)) { break; } + if (Tcl_LimitExceeded(interp)) { + break; + } inChannel = Tcl_GetStdChannel(TCL_STDIN); if (inChannel == (Tcl_Channel) NULL) { break; @@ -557,7 +566,8 @@ Tcl_Main(argc, argv, appInitProc) } done: - if ((exitCode == 0) && (mainLoopProc != NULL)) { + if ((exitCode == 0) && (mainLoopProc != NULL) + && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, @@ -579,14 +589,18 @@ Tcl_Main(argc, argv, appInitProc) */ if (!Tcl_InterpDeleted(interp)) { - sprintf(buffer, "exit %d", exitCode); - Tcl_Eval(interp, buffer); + if (!Tcl_LimitExceeded(interp)) { + char buffer[TCL_INTEGER_SPACE + 5]; + + sprintf(buffer, "exit %d", exitCode); + Tcl_Eval(interp, buffer); + } /* * If Tcl_Eval returns, trying to eval [exit], something - * unusual is happening. Maybe interp has been deleted; - * maybe [exit] was redefined. We still want to cleanup - * and exit. + * unusual is happening. Maybe interp has been deleted; maybe + * [exit] was redefined, maybe we've blown up because of an + * exceeded limit. We still want to cleanup and exit. */ if (!Tcl_InterpDeleted(interp)) { diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 66b9760..0e34ab6 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTrace.c,v 1.9 2004/03/01 17:33:45 dgp Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.10 2004/05/13 12:59:23 dkf Exp $ */ #include "tclInt.h" @@ -1295,7 +1295,8 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) tcmdPtr->refCount++; - if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED) + && !Tcl_LimitExceeded(interp)) { /* * Generate a command to execute by appending list elements * for the old and new command name and the operation. @@ -1333,6 +1334,7 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) Tcl_DStringLength(&cmd), 0); if (code != TCL_OK) { /* We ignore errors in these traced commands */ + /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/ } Tcl_RestoreResult(interp, &state); @@ -1728,7 +1730,7 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, return traceCode; } - if (!(flags & TCL_INTERP_DESTROYED)) { + if (!(flags & TCL_INTERP_DESTROYED) && !Tcl_LimitExceeded(interp)) { /* * Check whether the current call is going to eval arbitrary * Tcl code with a generated trace, or whether we are only @@ -1938,7 +1940,8 @@ TraceVarProc(clientData, interp, name1, name2, flags) Tcl_Preserve((ClientData) tvarPtr); result = NULL; - if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED) + && !Tcl_LimitExceeded(interp)) { if (tvarPtr->length != (size_t) 0) { /* * Generate a command to execute by appending list elements diff --git a/tests/interp.test b/tests/interp.test index e6b2024..bf49282 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.27 2004/03/30 16:22:22 msofer Exp $ +# RCS: @(#) $Id: interp.test,v 1.28 2004/05/13 12:59:23 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -31,7 +31,7 @@ test interp-1.1 {options for interp command} { } {1 {wrong # args: should be "interp cmd ?arg ...?"}} test interp-1.2 {options for interp command} { list [catch {interp frobox} msg] $msg -} {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} +} {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.3 {options for interp command} { interp delete } "" @@ -49,13 +49,13 @@ test interp-1.6 {options for interp command} { } {1 {wrong # args: should be "interp slaves ?path?"}} test interp-1.7 {options for interp command} { list [catch {interp hello} msg] $msg -} {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} +} {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.8 {options for interp command} { list [catch {interp -froboz} msg] $msg -} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} +} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.9 {options for interp command} { list [catch {interp -froboz -safe} msg] $msg -} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}} +} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer}} test interp-1.10 {options for interp command} { list [catch {interp target} msg] $msg } {1 {wrong # args: should be "interp target path alias"}} @@ -855,196 +855,153 @@ test interp-19.9 {alias deletion, renaming} { } 1156 test interp-20.1 {interp hide, interp expose and interp invokehidden} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a eval {proc foo {} {}} - a hide foo - catch {a eval foo something} msg - interp delete a + set a [interp create] + $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + $a eval {proc foo {} {}} + $a hide foo + catch {$a eval foo something} msg + interp delete $a set msg } {invalid command name "foo"} test interp-20.2 {interp hide, interp expose and interp invokehidden} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a hide list + set a [interp create] + $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + $a hide list set l "" - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - a expose list - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - interp delete a + lappend l [catch {$a eval {list 1 2 3}} msg] $msg + $a expose list + lappend l [catch {$a eval {list 1 2 3}} msg] $msg + interp delete $a set l } {1 {invalid command name "list"} 0 {1 2 3}} test interp-20.3 {interp hide, interp expose and interp invokehidden} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a hide list + set a [interp create] + $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + $a hide list set l "" - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - lappend l [catch {a invokehidden list 1 2 3} msg] - lappend l $msg - a expose list - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - interp delete a + lappend l [catch { $a eval {list 1 2 3} } msg] $msg + lappend l [catch { $a invokehidden list 1 2 3 } msg] $msg + $a expose list + lappend l [catch { $a eval {list 1 2 3} } msg] $msg + interp delete $a set l } {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} test interp-20.4 {interp hide, interp expose and interp invokehidden -- passing {}} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a hide list + set a [interp create] + $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + $a hide list set l "" - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - lappend l [catch {a invokehidden list {"" 1 2 3}} msg] - lappend l $msg - a expose list - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - interp delete a + lappend l [catch { $a eval {list 1 2 3} } msg] $msg + lappend l [catch { $a invokehidden list {"" 1 2 3} } msg] $msg + $a expose list + lappend l [catch { $a eval {list 1 2 3} } msg] $msg + interp delete $a set l } {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} test interp-20.5 {interp hide, interp expose and interp invokehidden -- passing {}} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a hide list + set a [interp create] + $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + $a hide list set l "" - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - lappend l [catch {a invokehidden list {{} 1 2 3}} msg] - lappend l $msg - a expose list - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - interp delete a + lappend l [catch { $a eval {list 1 2 3} } msg] $msg + lappend l [catch { $a invokehidden list {{} 1 2 3} } msg] $msg + $a expose list + lappend l [catch { $a eval {list 1 2 3} } msg] $msg + interp delete $a set l } {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} test interp-20.6 {interp invokehidden -- eval args} { - catch {interp delete a} - interp create a - a hide list + set a [interp create] + $a hide list set l "" set z 45 - lappend l [catch {a invokehidden list $z 1 2 3} msg] - lappend l $msg - a expose list - lappend l [catch {a eval list $z 1 2 3} msg] - lappend l $msg - interp delete a + lappend l [catch { $a invokehidden list $z 1 2 3 } msg] $msg + $a expose list + lappend l [catch { $a eval list $z 1 2 3 } msg] $msg + interp delete $a set l } {0 {45 1 2 3} 0 {45 1 2 3}} test interp-20.7 {interp invokehidden vs variable eval} { - catch {interp delete a} - interp create a - a hide list + set a [interp create] + $a hide list set z 45 - set l "" - lappend l [catch {a invokehidden list {$z a b c}} msg] - lappend l $msg - interp delete a + set l [list [catch {$a invokehidden list {$z a b c}} msg] $msg] + interp delete $a set l } {0 {{$z a b c}}} test interp-20.8 {interp invokehidden vs variable eval} { - catch {interp delete a} - interp create a - a hide list - a eval set z 89 + set a [interp create] + $a hide list + $a eval set z 89 set z 45 - set l "" - lappend l [catch {a invokehidden list {$z a b c}} msg] - lappend l $msg - interp delete a + set l [list [catch {$a invokehidden list {$z a b c}} msg] $msg] + interp delete $a set l } {0 {{$z a b c}}} test interp-20.9 {interp invokehidden vs variable eval} { - catch {interp delete a} - interp create a - a hide list - a eval set z 89 + set a [interp create] + $a hide list + $a eval set z 89 set z 45 set l "" - lappend l [catch {a invokehidden list $z {$z a b c}} msg] - lappend l $msg - interp delete a + lappend l [catch {$a invokehidden list $z {$z a b c}} msg] $msg + interp delete $a set l } {0 {45 {$z a b c}}} test interp-20.10 {interp hide, interp expose and interp invokehidden} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - a eval {proc foo {} {}} - interp hide a foo - catch {interp eval a foo something} msg - interp delete a + set a [interp create] + $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + $a eval {proc foo {} {}} + interp hide $a foo + catch {interp eval $a foo something} msg + interp delete $a set msg } {invalid command name "foo"} test interp-20.11 {interp hide, interp expose and interp invokehidden} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - interp hide a list + set a [interp create] + $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide $a list set l "" - lappend l [catch {interp eval a {list 1 2 3}} msg] - lappend l $msg - interp expose a list - lappend l [catch {interp eval a {list 1 2 3}} msg] - lappend l $msg - interp delete a + lappend l [catch {interp eval $a {list 1 2 3}} msg] $msg + interp expose $a list + lappend l [catch {interp eval $a {list 1 2 3}} msg] $msg + interp delete $a set l } {1 {invalid command name "list"} 0 {1 2 3}} test interp-20.12 {interp hide, interp expose and interp invokehidden} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - interp hide a list + set a [interp create] + $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide $a list set l "" - lappend l [catch {interp eval a {list 1 2 3}} msg] - lappend l $msg - lappend l [catch {interp invokehidden a list 1 2 3} msg] - lappend l $msg - interp expose a list - lappend l [catch {interp eval a {list 1 2 3}} msg] - lappend l $msg - interp delete a + lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg + lappend l [catch {interp invokehidden $a list 1 2 3} msg] $msg + interp expose $a list + lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg + interp delete $a set l } {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} test interp-20.13 {interp hide, interp expose, interp invokehidden -- passing {}} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - interp hide a list + set a [interp create] + $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide $a list set l "" - lappend l [catch {interp eval a {list 1 2 3}} msg] - lappend l $msg - lappend l [catch {interp invokehidden a list {"" 1 2 3}} msg] - lappend l $msg - interp expose a list - lappend l [catch {interp eval a {list 1 2 3}} msg] - lappend l $msg - interp delete a + lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg + lappend l [catch {interp invokehidden $a list {"" 1 2 3}} msg] $msg + interp expose $a list + lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg + interp delete $a set l } {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} test interp-20.14 {interp hide, interp expose, interp invokehidden -- passing {}} { - catch {interp delete a} - interp create a - a eval {proc unknown {x args} {error "invalid command name \"$x\""}} - interp hide a list + set a [interp create] + $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} + interp hide $a list set l "" - lappend l [catch {interp eval a {list 1 2 3}} msg] - lappend l $msg - lappend l [catch {interp invokehidden a list {{} 1 2 3}} msg] - lappend l $msg - interp expose a list - lappend l [catch {a eval {list 1 2 3}} msg] - lappend l $msg - interp delete a + lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg + lappend l [catch {interp invokehidden $a list {{} 1 2 3}} msg] $msg + interp expose $a list + lappend l [catch {$a eval {list 1 2 3} } msg] $msg + interp delete $a set l } {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} test interp-20.15 {interp invokehidden -- eval args} { @@ -2907,16 +2864,62 @@ test interp-32.1 { parent's working directory should test interp-33.1 {refCounting for target words of alias [Bug 730244]} { # This test will panic if Bug 730244 is not fixed. - interp create i - proc test args {return $args} - trace add execution test enter {interp alias i alias {} ;#} - interp alias i alias {} test this - i eval alias + set i [interp create] + proc testHelper args {rename testHelper {}; return $args} + # Note: interp names are simple words by default + trace add execution testHelper enter "interp alias $i alias {} ;#" + interp alias $i alias {} testHelper this + $i eval alias } this +test interp-34.1 {basic test of limits - calling commands} { + set i [interp create] + $i eval { + proc foobar {} { + for {set x 0} {$x<1000000} {incr x} { + # Calls to this are not bytecoded away + pid + } + } + } + $i limit command -value 1000 + set msg [list [catch {$i eval foobar} msg] $msg] + interp delete $i + set msg +} {1 {command count limit exceeded}} +test interp-34.2 {basic test of limits - bytecoded commands} knownBug { + set i [interp create] + $i eval { + proc foobar {} { + for {set x 0} {$x<1000000} {incr x} { + # Calls to this *are* bytecoded away + expr {1+2+3} + } + } + } + $i limit command -value 1000 + set msg [list [catch {$i eval foobar} msg] $msg] + interp delete $i + set msg +} {1 {command count limit exceeded}} +test interp-34.3 {basic test of limits - pure bytecode loop} knownBug { + set i [interp create] + $i eval { + proc foobar {} { + while {1} { + # No bytecode at all here... + } + } + } + $i limit command -value 1000 + set msg [list [catch {$i eval foobar} msg] $msg] + interp delete $i + set msg +} {1 {command count limit exceeded}} + # cleanup foreach i [interp slaves] { - interp delete $i + interp delete $i } ::tcltest::cleanupTests return -- cgit v0.12