summaryrefslogtreecommitdiffstats
path: root/generic/tclInterp.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2003-09-29 21:38:47 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2003-09-29 21:38:47 (GMT)
commit51d61f0f3368b5b9b14bbbbefb0a2aedb30ed5e3 (patch)
tree493b7c36e3c10db4c4a6edd067cf03ec4aa1a60a /generic/tclInterp.c
parentab6eb1243a00175b523c0b8ca52aa43f6edec906 (diff)
downloadtcl-51d61f0f3368b5b9b14bbbbefb0a2aedb30ed5e3.zip
tcl-51d61f0f3368b5b9b14bbbbefb0a2aedb30ed5e3.tar.gz
tcl-51d61f0f3368b5b9b14bbbbefb0a2aedb30ed5e3.tar.bz2
TIP#121 (app exit proc API) implementation from Joe Mistachkin
Diffstat (limited to 'generic/tclInterp.c')
-rw-r--r--generic/tclInterp.c502
1 files changed, 495 insertions, 7 deletions
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;
+}