diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | doc/Exit.3 | 36 | ||||
| -rw-r--r-- | generic/tcl.decls | 8 | ||||
| -rw-r--r-- | generic/tclBasic.c | 36 | ||||
| -rw-r--r-- | generic/tclEvent.c | 70 | ||||
| -rw-r--r-- | generic/tclInt.h | 45 | ||||
| -rw-r--r-- | generic/tclInterp.c | 502 |
7 files changed, 682 insertions, 22 deletions
@@ -1,5 +1,12 @@ 2003-09-29 Donal K. Fellows <fellowsd@cs.man.ac.uk> + TIP#121 IMPLEMENTATION FROM JOE MISTACHKIN + + * generic/tclEvent.c (Tcl_SetExitProc,Tcl_Exit): Implementation of + application exit handler scheme. + * generic/tcl.decls (Tcl_SetExitProc): Public declaration. + * doc/Exit.3: Documentation of new API function. + TIP#112 IMPLEMENTATION * generic/tclNamesp.c: Core of implementation. @@ -4,10 +4,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Exit.3,v 1.4 2000/07/24 00:03:02 jenglish Exp $ +'\" RCS: @(#) $Id: Exit.3,v 1.5 2003/09/29 21:38:48 dkf Exp $ '\" .so man.macros -.TH Tcl_Exit 3 8.1 Tcl "Tcl Library Procedures" +.TH Tcl_Exit 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Exit, Tcl_Finalize, Tcl_CreateExitHandler, Tcl_DeleteExitHandler, Tcl_ExitThread, Tcl_FinalizeThread, Tcl_CreateThreadExitHandler, Tcl_DeleteThreadExitHandler \- end the application or thread (and invoke exit handlers) @@ -30,6 +30,11 @@ Tcl_Exit, Tcl_Finalize, Tcl_CreateExitHandler, Tcl_DeleteExitHandler, Tcl_ExitTh \fBTcl_CreateThreadExitHandler\fR(\fIproc, clientData\fR) .sp \fBTcl_DeleteThreadExitHandler\fR(\fIproc, clientData\fR) +.sp +.VS 8.5 +Tcl_ExitProc * +\fBTcl_SetExitProc\fR(\fIproc\fR) +.VE 8.5 .SH ARGUMENTS .AS Tcl_ExitProc clientData .AP int status in @@ -38,7 +43,9 @@ Exact meaning may be platform-specific. 0 usually means a normal exit, any nonzero value usually means that an error occurred. .AP Tcl_ExitProc *proc in -Procedure to invoke before exiting application. +Procedure to invoke before exiting application, or (for +\fBTcl_SetExitProc\fR) NULL to uninstall the current application exit +procedure. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE @@ -59,6 +66,12 @@ otherwise causes the application to terminate without calling \fBTcl_Exit\fR, the exit handlers will not be run. \fBTcl_Exit\fR internally invokes the \fBexit\fR system call, thus it never returns control to its caller. +.VS 8.5 +If an application exit handler has been installed (see +\fBTcl_SetExitProc\fR), that handler is invoked with an argument +consisting of the exit status (cast to ClientData); the application +exit handler should not return control to Tcl. +.VE 8.5 .PP \fBTcl_Finalize\fR is similar to \fBTcl_Exit\fR except that it does not exit from the current process. @@ -73,14 +86,12 @@ However, to ensure portability, your code should always invoke code will work on all platforms. \fBTcl_Finalize\fR can be safely called more than once. .PP -.VS \fBTcl_ExitThread\fR is used to terminate the current thread and invoke per-thread exit handlers. This finalization is done by \fBTcl_FinalizeThread\fR, which you can call if you just want to clean up per-thread state and invoke the thread exit handlers. \fBTcl_Finalize\fR calls \fBTcl_FinalizeThread\fR for the current thread automatically. -.VE .PP \fBTcl_CreateExitHandler\fR arranges for \fIproc\fR to be invoked by \fBTcl_Finalize\fR and \fBTcl_Exit\fR. @@ -107,7 +118,6 @@ indicated by \fIproc\fR and \fIclientData\fR so that no call to \fIproc\fR will be made. If no such handler exists then \fBTcl_DeleteExitHandler\fR or \fBTcl_DeleteThreadExitHandler\fR does nothing. .PP -.VS .PP \fBTcl_Finalize\fR and \fBTcl_Exit\fR execute all registered exit handlers, in reverse order from the order in which they were registered. @@ -117,15 +127,23 @@ unloads \fBB\fR before it itself is unloaded. If extension \fBA\fR registers its exit handlers before loading extension \fBB\fR, this ensures that any exit handlers for \fBB\fR will be executed before the exit handlers for \fBA\fR. -.VE -.VS .PP \fBTcl_Finalize\fR and \fBTcl_Exit\fR call \fBTcl_FinalizeThread\fR and the thread exit handlers \fIafter\fR the process-wide exit handlers. This is because thread finalization shuts down the I/O channel system, so any attempt at I/O by the global exit handlers will vanish into the bitbucket. -.VE +.PP +.VS 8.5 +\fBTcl_SetExitProc\fR installs an application exit handler, returning +the previously-installed application exit handler or NULL if no +application handler was installed. If an application exit handler is +installed, that exit handler takes over complete responsibility for +finalization of Tcl's subsystems via \fBTcl_Finalize\fR at an +appropriate time. The argument passed to \fIproc\fR when it is +invoked will be the exit status code (as passed to \fBTcl_Exit\fR) +cast to a ClientData value. +.VE 8.5 .SH KEYWORDS callback, cleanup, dynamic loading, end application, exit, unloading, thread diff --git a/generic/tcl.decls b/generic/tcl.decls index 1e0edf4..084aed6 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.100 2003/09/05 21:52:11 dgp Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.101 2003/09/29 21:38:49 dkf Exp $ library tcl @@ -1854,6 +1854,12 @@ declare 518 generic { int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, CONST char *encodingName) } + +# New export due to TIP#121 +declare 519 generic { + Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8c1b739..71d0874 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.87 2003/09/29 14:37:14 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.88 2003/09/29 21:38:49 dkf Exp $ */ #include "tclInt.h" @@ -384,6 +384,19 @@ Tcl_CreateInterp() iPtr->execEnvPtr = TclCreateExecEnv(interp); /* + * Initialise the resource limiting framework. + */ + + iPtr->limitCheckCounter = 0; + iPtr->limits = 0; + iPtr->timeGranularity = 0; + iPtr->timeLimit = 0; + iPtr->timeLimitHandlers = NULL; + iPtr->cmdcountGranularity = 0; + iPtr->cmdcountLimit = 0; + iPtr->cmdcountLimitHandlers = NULL; + + /* * Initialize the compilation and execution statistics kept for this * interpreter. */ @@ -969,6 +982,7 @@ DeleteInterpProc(interp) Tcl_HashSearch search; Tcl_HashTable *hTablePtr; ResolverScheme *resPtr, *nextResPtr; + LimitHandler *lhPtr, *nextLhPtr; /* * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup. @@ -990,6 +1004,26 @@ DeleteInterpProc(interp) TclHandleFree(iPtr->handle); /* + * Destroy any resource limiting handlers that this interpreter + * has; we're on our way out now, so failing because of resource + * limits now would be very silly indeed. + */ + + iPtr->limits = 0; + for (lhPtr=iPtr->timeLimitHandlers ; lhPtr!=NULL ; lhPtr=nextLhPtr) { + nextLhPtr = lhPtr->next; + Tcl_DecrRefCount(lhPtr->handlerObj); + lhPtr->handlerObj = NULL; + Tcl_EventuallyFree((char *) lhPtr, TCL_DYNAMIC); + } + for (lhPtr=iPtr->cmdcountLimitHandlers ; lhPtr!=NULL ; lhPtr=nextLhPtr) { + nextLhPtr = lhPtr->next; + Tcl_DecrRefCount(lhPtr->handlerObj); + lhPtr->handlerObj = NULL; + Tcl_EventuallyFree((char *) lhPtr, TCL_DYNAMIC); + } + + /* * Dismantle everything in the global namespace except for the * "errorInfo" and "errorCode" variables. These remain until the * namespace is actually destroyed, in case any errors occur. diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 003e5a2..3449db1 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.29 2003/05/13 12:39:50 dkf Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.30 2003/09/29 21:38:49 dkf Exp $ */ #include "tclInt.h" @@ -88,6 +88,14 @@ TCL_DECLARE_MUTEX(exitMutex) static int inFinalize = 0; static int subsystemsInitialized = 0; +/* + * This variable contains the application wide exit handler. It will be + * called by Tcl_Exit instead of the C-runtime exit if this variable is set + * to a non-NULL value. + */ + +static Tcl_ExitProc *appExitPtr = NULL; + typedef struct ThreadSpecificData { ExitHandler *firstExitPtr; /* First in list of all exit handlers for * this thread. */ @@ -542,6 +550,44 @@ Tcl_DeleteThreadExitHandler(proc, clientData) /* *---------------------------------------------------------------------- * + * Tcl_SetExitProc -- + * + * This procedure sets the application wide exit handler that + * will be called by Tcl_Exit in place of the C-runtime exit. If + * the application wide exit handler is NULL, the C-runtime exit + * will be used instead. + * + * Results: + * The previously set application wide exit handler. + * + * Side effects: + * Sets the application wide exit handler to the specified value. + * + *---------------------------------------------------------------------- + */ + +Tcl_ExitProc * +Tcl_SetExitProc(proc) + Tcl_ExitProc *proc; /* new exit handler for app or NULL */ +{ + Tcl_ExitProc *prevExitProc; + + /* + * Swap the old exit proc for the new one, saving the old one for + * our return value. + */ + + Tcl_MutexLock(&exitMutex); + prevExitProc = appExitPtr; + appExitPtr = proc; + Tcl_MutexUnlock(&exitMutex); + + return prevExitProc; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Exit -- * * This procedure is called to terminate the application. @@ -561,8 +607,26 @@ Tcl_Exit(status) int status; /* Exit status for application; typically * 0 for normal return, 1 for error return. */ { - Tcl_Finalize(); - TclpExit(status); + Tcl_ExitProc *currentAppExitPtr; + + Tcl_MutexLock(&exitMutex); + currentAppExitPtr = appExitPtr; + Tcl_MutexUnlock(&exitMutex); + + if (currentAppExitPtr) { + /* + * Warning: this code SHOULD NOT return, as there is code that + * depends on Tcl_Exit never returning. In fact, we will + * panic if anyone returns, so critical is this dependcy. + */ + currentAppExitPtr((ClientData) status); + Tcl_Panic("AppExitProc returned unexpectedly"); + } else { + /* use default handling */ + Tcl_Finalize(); + TclpExit(status); + Tcl_Panic("OS exit failed!"); + } } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index d60429b..acf4ae5 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.133 2003/09/29 14:37:14 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.134 2003/09/29 21:38:49 dkf Exp $ */ #ifndef _TCLINT @@ -1094,6 +1094,14 @@ typedef struct Command { #define CMD_HAS_EXEC_TRACES 0x4 /* + * Flag bits for saying what limits are enabled on an interpreter, as + * defined in TIP #143. + */ + +#define LIMIT_COMMAND_COUNTS 0x1 +#define LIMIT_WALL_TIME 0x2 + +/* *---------------------------------------------------------------- * Data structures related to name resolution procedures. *---------------------------------------------------------------- @@ -1127,6 +1135,21 @@ typedef struct ResolverScheme { /* *---------------------------------------------------------------- + * This structure defines a list of interpreter/handler script pairs + * that will be called when a particular limit is exceeded in some + * interpreter. + *---------------------------------------------------------------- + */ + +typedef struct LimitHandler { + Tcl_Interp *interp; /* Which interpreter to execute the handler + * in. */ + Tcl_Obj *handlerObj; /* The handler script itself. */ + struct LimitHandler *next; /* Pointer to next handler in linked list. */ +} LimitHandler; + +/* + *---------------------------------------------------------------- * This structure defines an interpreter, which is a collection of * commands plus other state information related to interpreting * commands, such as variable storage. Primary responsibility for @@ -1325,6 +1348,26 @@ typedef struct Interp { Tcl_Obj *returnOptionsKey; /* holds "-options" */ /* + * Resource limit control fields (TIP #143) + */ + + long limitCheckCounter; /* Counter used to constrain the frequency + * of limit checks. */ + int limits; /* Which limits are to be checked. */ + long timeGranularity; /* Modulus for the limit check counter to + * determine when to apply the time limit + * checks. */ + long timeLimit; /* When the time limit expires. */ + LimitHandler *timeLimitHandlers; + /* Linked list of time limit handlers. */ + long cmdcountGranularity; /* As with timeLimitGranularity except + * for being for command count limits. */ + int cmdcountLimit; /* The maximum number of commands that this + * interpreter may execute. */ + LimitHandler *cmdcountLimitHandlers; + /* Linked list of cmdcount limit handlers. */ + + /* * Statistical information about the bytecode compiler and interpreter's * operation. */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 8159855..524529f 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.22 2003/05/12 22:44:24 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.23 2003/09/29 21:38:49 dkf Exp $ */ #include "tclInt.h" @@ -146,6 +146,13 @@ typedef struct InterpInfo { } InterpInfo; /* + * Default granularities for various limits. + */ + +#define DEFAULT_CMDCOUNT_GRANULARITY 100 +#define DEFAULT_TIME_GRANULARITY 1000 + +/* * Prototypes for local static procedures: */ @@ -358,17 +365,17 @@ 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", - "target", "transfer", + "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_TARGET, OPT_TRANSFER + OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_LIMIT, + OPT_MARKTRUSTED, OPT_RECLIMIT, OPT_SLAVES, + OPT_SHARE, OPT_TARGET, OPT_TRANSFER }; @@ -772,6 +779,47 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) } return TCL_OK; } + case OPT_LIMIT: { + static CONST char *limits[] = { + "command", "time", NULL + }; + enum LimitTypes { + LIMIT_CMD, LIMIT_TIME + }; + Tcl_Interp *limitedInterp; + + if (objc < 4 || (objc & 1 && objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "path type ?opt? ?val? ..."); + return TCL_ERROR; + } + limitedInterp = GetInterp(interp, objv[2]); + if (limitedInterp == NULL) { + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[3], limits, "limit-type", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LimitTypes) index) { + case LIMIT_CMD: + if (objc == 4) { + return ReadLimitCmdCount(interp, limitedInterp, NULL); + } else if (objc == 5) { + return ReadLimitCmdCount(interp, limitedInterp, objv[4]); + } else { + return SetLimitCmdCount(interp, limitedInterp, + objc-4, objv+4); + } + case LIMIT_TIME: + if (objc == 4) { + return ReadLimitTime(interp, limitedInterp, NULL); + } else if (objc == 5) { + return ReadLimitTime(interp, limitedInterp, objv[4]); + } else { + return SetLimitTime(interp, limitedInterp, objc-4, objv+4); + } + } + } } return TCL_OK; } @@ -1809,6 +1857,18 @@ SlaveCreate(interp, pathPtr, safe) } slaveInterp = Tcl_CreateInterp(); + if (((Interp *) masterInterp)->limits & LIMIT_COMMAND_COUNT) { + Interp *sPtr = (Interp *) slaveInterp; + sPtr->limits |= LIMIT_COMMAND_COUNT; + sPtr->cmdcountGranularity = DEFAULT_CMDCOUNT_GRANULARITY; + sPtr->cmdcountLimit = 0; + } + if (((Interp *) masterInterp)->limits & LIMIT_WALL_TIME) { + Interp *sPtr = (Interp *) slaveInterp; + sPtr->limits |= LIMIT_WALL_TIME; + sPtr->timeGranularity = DEFAULT_TIME_GRANULARITY; + sPtr->timeLimit = ((Interp *) masterInterp)->timeLimit; + } slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; @@ -2007,6 +2067,42 @@ SlaveObjCmd(clientData, interp, objc, objv) } return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); } + case OPT_LIMIT: { + static CONST char *limits[] = { + "command", "time", NULL + }; + enum LimitTypes { + LIMIT_CMD, LIMIT_TIME + }; + + if (objc < 3 || (objc > 4 && !(objc & 1))) { + Tcl_WrongNumArgs(interp, 2, objv, "type ?opt? ?val? ..."); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], limits, "limit-type", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LimitTypes) index) { + case LIMIT_CMD: + if (objc == 4) { + return ReadLimitCmdCount(interp, slaveInterp, NULL); + } else if (objc == 5) { + return ReadLimitCmdCount(interp, slaveInterp, objv[3]); + } else { + return SetLimitCmdCount(interp, slaveInterp, + objc-3, objv+3); + } + case LIMIT_TIME: + if (objc == 4) { + return ReadLimitTime(interp, slaveInterp, NULL); + } else if (objc == 5) { + return ReadLimitTime(interp, slaveInterp, objv[3]); + } else { + return SetLimitTime(interp, slaveInterp, objc-3, objv+3); + } + } + } } return TCL_ERROR; @@ -2487,3 +2583,395 @@ Tcl_MakeSafe(interp) return TCL_OK; } + +static CONST char *limitOpts[] = { + "-command", "-granularity", "-value", NULL +}; +enum LimitOpts { + LIM_CMD, LIM_GRAN, LIM_VAL +}; + +static int +ReadLimitCmdCount(interp, targetInterp, propertyName) + Tcl_Interp *interp, *targetInterp; + Tcl_Obj *propertyName; +{ + Interp *tPtr = (Interp *) targetInterp; + + if (propertyName == NULL) { + Tcl_Obj *resultObj, *emptyObj; + int limited = tPtr->limits & LIMIT_COMMAND_COUNT; + + /* + * We do not know how many times we will need the emptyObj; + * could be zero to three times. + */ + + TclNewObj(resultObj); + TclNewObj(emptyObj); + Tcl_IncrRefCount(emptyObj); + + if (limited) { + LimitHandler *lh = tPtr->cmdcountLimitHandlers; + for (; lh!=NULL ; lh=lh->next) { + if (lh->interp == interp) { + break; + } + } + Tcl_DictObjPut(NULL, resultObj, Tcl_NewStringObj(limitOpts[0], -1), + lh ? lh->handlerObj : emptyObj); + } else { + Tcl_DictObjPut(NULL, resultObj, Tcl_NewStringObj(limitOpts[0], -1), + emptyObj); + } + Tcl_DictObjPut(NULL, resultObj, Tcl_NewStringObj(limitOpts[1], -1), + limited? Tcl_NewLongObj(tPtr->cmdcountGranularity) : emptyObj); + Tcl_DictObjPut(NULL, resultObj, Tcl_NewStringObj(limitOpts[2], -1), + limited? Tcl_NewIntObj(tPtr->cmdcountLimit) : emptyObj); + + Tcl_DecrRefCount(emptyObj); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } else { + int index; + + if (Tcl_GetIndexFromObj(interp, propertyName, limitOpts, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (!(tPtr->limits & LIMIT_COMMAND_COUNT)) { + return TCL_OK; + } + + switch ((enum LimitOpts) index) { + case LIM_CMD: { + LimitHandler *lh = tPtr->cmdcountLimitHandlers; + for (; lh!=NULL ; lh=lh->next) { + if (lh->interp == interp) { + Tcl_SetObjResult(interp, lh->handlerObj); + break; + } + } + break; + } + case LIM_GRAN: + Tcl_SetObjResult(Tcl_NewLongObj(tPtr->cmdcountGranularity)); + break; + case LIM_VAL: + Tcl_SetObjResult(Tcl_NewIntObj(tPtr->cmdcountLimit)); + break; + } + return TCL_OK; + } +} + +static int +SetLimitCmdCount(interp, targetInterp, objc, objv) + Tcl_Interp *interp, *targetInterp; + int objc; + Tcl_Obj *CONST objv[]; +{ + Interp *tPtr = (Interp *) targetInterp; + int i, index, value, setFlag; + long gran; + Tcl_Obj *newCmd, *newGran, *newVal; + LimitHandler *lh, *lh2; + + /* + * Parse the options to set. + */ + + newCmd = newGran = newVal = NULL; + setFlag = 1; + for (i=0 ; i<objc ; i+=2) { + if (Tcl_GetIndexFromObj(interp, objv[i], limitOpts, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LimitOpts) index) { + case LIM_CMD: + newCmd = objv[i+1]; + break; + case LIM_GRAN: + if (Tcl_GetLongFromObj(interp, objv[i+1], &gran) != TCL_OK) { + return TCL_ERROR; + } + if (gran < 1) { + Tcl_AppendResult(interp,"granularities must be positive",NULL); + return TCL_ERROR; + } + newGran = objv[i+1]; + break; + case LIM_VAL: + /* + * If we have these numeric types, we know that we will + * not have an empty string rep. + */ + if (objv[i+1]->typePtr != &tclIntType && + objv[i+1]->typePtr != &tclDoubleType && + objv[i+1]->typePtr != &tclWideIntType) { + Tcl_GetString(objv[i+1]); + setFlag = (objv[i+1]->length > 0); + } + if (Tcl_GetIntFromObj(interp, objv[i+1], &value) != TCL_OK) { + return TCL_ERROR; + } + newVal = objv[i+1]; + break; + } + } + + if (!setFlag) { + /* + * Remove limit on interpreter. + */ + tPtr->limits &= ~LIMIT_COMMAND_COUNTS; + for (lh=tPtr->cmdcountLimitHandlers ; lh!=NULL ; lh=lh2) { + lh2 = lh->next; + Tcl_DecrRefCount(lh->handlerObj); + Tcl_EventuallyFree(lh, TCL_DYNAMIC); + } + tPtr->cmdcountLimitHandlers = NULL; + } else if (tPtr->limits & LIMIT_COMMAND_COUNTS) { + /* + * Modify limit on interpreter. + */ + + if (newGran != NULL) { + tPtr->cmdcountGranularity = gran; + } + if (newVal != NULL) { + tPtr->cmdcountLimit = value; + } + if (newCmd != NULL) { + for (lh=tPtr->cmdcountLimitHandlers ; lh!=NULL ; lh=lh->next) { + if (lh->interp == interp) { + break; + } + } + if (lh == NULL) { + lh = (LimitHandler *) ckalloc(sizeof(LimitHandler)); + lh->interp = interp; + lh->next = tPtr->cmdcountLimitHandlers; + tPtr->cmdcountLimitHandlers = lh; + } else { + Tcl_DecrRefCount(lh->handlerObj); + } + lh->handlerObj = newCmd; + Tcl_IncrRefCount(newCmd); + } + } else { + /* + * Install limit on interpreter; value must have been set. + */ + + if (newGran == NULL) { + gran = DEFAULT_CMDCOUNT_GRANULARITY; + } + tPtr->limits |= LIMIT_COMMAND_COUNTS; + tPtr->cmdcountGranularity = gran; + tPtr->cmdcountValue = value; + if (newCmd != NULL) { + lh = (LimitHandler *) ckalloc(sizeof(LimitHandler)); + lh->interp = interp; + lh->handlerObj = newCmd; + Tcl_IncrRefCount(newCmd); + lh->next = NULL; + tPtr->cmdcountLimitHandlers = lh; + } + } + + return TCL_OK; +} + +static int +ReadLimitTime(interp, targetInterp, propertyName) + Tcl_Interp *interp, *targetInterp; + Tcl_Obj *propertyName; +{ + Interp *tPtr = (Interp *) targetInterp; + + if (propertyName == NULL) { + Tcl_Obj *resultObj, *emptyObj; + int limited = tPtr->limits & LIMIT_COMMAND_COUNT; + + /* + * We do not know how many times we will need the emptyObj; + * could be zero to three times. + */ + + TclNewObj(resultObj); + TclNewObj(emptyObj); + Tcl_IncrRefCount(emptyObj); + + if (limited) { + LimitHandler *lh = tPtr->timeLimitHandlers; + for (; lh!=NULL ; lh=lh->next) { + if (lh->interp == interp) { + break; + } + } + Tcl_DictObjPut(NULL, resultObj, Tcl_NewStringObj(limitOpts[0], -1), + lh ? lh->handlerObj : emptyObj); + } else { + Tcl_DictObjPut(NULL, resultObj, Tcl_NewStringObj(limitOpts[0], -1), + emptyObj); + } + Tcl_DictObjPut(NULL, resultObj, Tcl_NewStringObj(limitOpts[1], -1), + limited ? Tcl_NewLongObj(tPtr->timeGranularity) : emptyObj); + Tcl_DictObjPut(NULL, resultObj, Tcl_NewStringObj(limitOpts[2], -1), + limited ? Tcl_NewIntObj(tPtr->timeLimit) : emptyObj); + + Tcl_DecrRefCount(emptyObj); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; + } else { + int index; + + if (Tcl_GetIndexFromObj(interp, propertyName, limitOpts, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (!(tPtr->limits & LIMIT_COMMAND_COUNT)) { + return TCL_OK; + } + switch ((enum LimitOpts) index) { + case LIM_CMD: { + LimitHandler *lh = tPtr->timeLimitHandlers; + for (; lh!=NULL ; lh=lh->next) { + if (lh->interp == interp) { + Tcl_SetObjResult(interp, lh->handlerObj); + break; + } + } + break; + } + case LIM_GRAN: + Tcl_SetObjResult(Tcl_NewLongObj(tPtr->timeGranularity)); + break; + case LIM_VAL: + Tcl_SetObjResult(Tcl_NewIntObj(tPtr->timeLimit)); + break; + } + return TCL_OK; + } +} + +static int +SetLimitTime(interp, targetInterp, objc, objv) + Tcl_Interp *interp, *targetInterp; + int objc; + Tcl_Obj *CONST objv[]; +{ + Interp *tPtr = (Interp *) targetInterp; + int i, index, value, setFlag; + long gran; + Tcl_Obj *newCmd, *newGran, *newVal; + LimitHandler *lh, *lh2; + + /* + * Parse the options to set. + */ + + newCmd = newGran = newVal = NULL; + setFlag = 1; + for (i=0 ; i<objc ; i+=2) { + if (Tcl_GetIndexFromObj(interp, objv[i], limitOpts, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LimitOpts) index) { + case LIM_CMD: + newCmd = objv[i+1]; + break; + case LIM_GRAN: + if (Tcl_GetLongFromObj(interp, objv[i+1], &gran) != TCL_OK) { + return TCL_ERROR; + } + if (gran < 1) { + Tcl_AppendResult(interp,"granularities must be positive",NULL); + return TCL_ERROR; + } + newGran = objv[i+1]; + break; + case LIM_VAL: + /* + * If we have these numeric types, we know that we will + * not have an empty string rep. + */ + if (objv[i+1]->typePtr != &tclIntType && + objv[i+1]->typePtr != &tclDoubleType && + objv[i+1]->typePtr != &tclWideIntType) { + Tcl_GetString(objv[i+1]); + setFlag = (objv[i+1]->length > 0); + } + if (Tcl_GetIntFromObj(interp, objv[i+1], &value) != TCL_OK) { + return TCL_ERROR; + } + newVal = objv[i+1]; + break; + } + } + + if (!setFlag) { + /* + * Remove limit on interpreter. + */ + tPtr->limits &= ~LIMIT_COMMAND_COUNTS; + for (lh=tPtr->timeLimitHandlers ; lh!=NULL ; lh=lh2) { + lh2 = lh->next; + Tcl_DecrRefCount(lh->handlerObj); + Tcl_EventuallyFree(lh, TCL_DYNAMIC); + } + tPtr->timeLimitHandlers = NULL; + } else if (tPtr->limits & LIMIT_COMMAND_COUNTS) { + /* + * Modify limit on interpreter. + */ + + if (newGran != NULL) { + tPtr->timeGranularity = gran; + } + if (newVal != NULL) { + tPtr->timeLimit = value; + } + if (newCmd != NULL) { + for (lh=tPtr->timeLimitHandlers ; lh!=NULL ; lh=lh->next) { + if (lh->interp == interp) { + break; + } + } + if (lh == NULL) { + lh = (LimitHandler *) ckalloc(sizeof(LimitHandler)); + lh->interp = interp; + lh->next = tPtr->timeLimitHandlers; + tPtr->timeLimitHandlers = lh; + } else { + Tcl_DecrRefCount(lh->handlerObj); + } + lh->handlerObj = newCmd; + Tcl_IncrRefCount(newCmd); + } + } else { + /* + * Install limit on interpreter; value must have been set. + */ + + if (newGran == NULL) { + gran = DEFAULT_TIME_GRANULARITY; + } + tPtr->limits |= LIMIT_COMMAND_COUNTS; + tPtr->timeGranularity = gran; + tPtr->timeValue = value; + if (newCmd != NULL) { + lh = (LimitHandler *) ckalloc(sizeof(LimitHandler)); + lh->interp = interp; + lh->handlerObj = newCmd; + Tcl_IncrRefCount(newCmd); + lh->next = NULL; + tPtr->timeLimitHandlers = lh; + } + } + + return TCL_OK; +} |