summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog8
-rw-r--r--generic/tcl.decls52
-rw-r--r--generic/tcl.h20
-rw-r--r--generic/tclBasic.c16
-rw-r--r--generic/tclCmdAH.c15
-rw-r--r--generic/tclEvent.c8
-rw-r--r--generic/tclExecute.c81
-rw-r--r--generic/tclHistory.c10
-rw-r--r--generic/tclInt.h68
-rw-r--r--generic/tclInterp.c1027
-rw-r--r--generic/tclMain.c34
-rw-r--r--generic/tclTrace.c11
-rw-r--r--tests/interp.test299
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 <donal.k.fellows@man.ac.uk>
+ 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<objc ; i+=2) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum Options) index) {
+ case OPT_CMD:
+ scriptObj = objv[i+1];
+ (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
+ break;
+ case OPT_GRAN:
+ granObj = objv[i+1];
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (gran < 1) {
+ Tcl_AppendResult(interp, "granularity must be at ",
+ "least 1", NULL);
+ return TCL_ERROR;
+ }
+ break;
+ case OPT_VAL:
+ limitObj = objv[i+1];
+ (void) Tcl_GetStringFromObj(objv[i+1], &limitLen);
+ if (limitLen == 0) {
+ break;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &limit) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (limit < 0) {
+ Tcl_AppendResult(interp, "command limit value must be at ",
+ "least 0", NULL);
+ return TCL_ERROR;
+ }
+ break;
+ }
+ }
+ if (scriptObj != NULL) {
+ SetLimitCallback(interp, TCL_LIMIT_COMMANDS, slaveInterp,
+ (scriptLen > 0 ? scriptObj : NULL));
+ }
+ if (granObj != NULL) {
+ Tcl_LimitSetGranularity(slaveInterp, TCL_LIMIT_COMMANDS, gran);
+ }
+ if (limitObj != NULL) {
+ if (limitLen > 0) {
+ Tcl_LimitSetCommands(slaveInterp, limit);
+ Tcl_LimitTypeSet(slaveInterp, TCL_LIMIT_COMMANDS);
+ } else {
+ Tcl_LimitTypeReset(slaveInterp, TCL_LIMIT_COMMANDS);
+ }
+ }
+ return TCL_OK;
+ }
+}
+
+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<objc ; i+=2) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum Options) index) {
+ case OPT_CMD:
+ scriptObj = objv[i+1];
+ (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen);
+ break;
+ case OPT_GRAN:
+ granObj = objv[i+1];
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &gran) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (gran < 1) {
+ Tcl_AppendResult(interp, "granularity must be at ",
+ "least 1", NULL);
+ return TCL_ERROR;
+ }
+ break;
+ case OPT_MILLI:
+ milliObj = objv[i+1];
+ (void) Tcl_GetStringFromObj(objv[i+1], &milliLen);
+ if (milliLen == 0) {
+ break;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (tmp < 0) {
+ Tcl_AppendResult(interp, "milliseconds must be at least 0",
+ NULL);
+ return TCL_ERROR;
+ }
+ limitMoment.usec = ((long)tmp)*1000;
+ break;
+ case OPT_SEC:
+ secObj = objv[i+1];
+ (void) Tcl_GetStringFromObj(objv[i+1], &secLen);
+ if (secLen == 0) {
+ break;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (tmp < 0) {
+ Tcl_AppendResult(interp, "seconds must be at least 0",
+ NULL);
+ return TCL_ERROR;
+ }
+ limitMoment.sec = tmp;
+ break;
+ }
+ }
+ if (milliObj != NULL || secObj != NULL) {
+ if (milliObj != NULL) {
+ /*
+ * Setting -milliseconds but clearing -seconds, or
+ * resetting -milliseconds but not resetting -seconds?
+ * Bad voodoo!
+ */
+ if (secObj != NULL && secLen == 0 && milliLen > 0) {
+ Tcl_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
generated by cgit v0.12 at 2024-11-17 06:02:56 (GMT)