summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2004-12-16 19:36:14 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2004-12-16 19:36:14 (GMT)
commita0655d89bbe9e5b91b703509126ed1c48a1cf405 (patch)
treede437c399d4304e768cda1abe7dada3b80e3c57f
parent96a4475c4aa4e7f173d328e2a6f37770ae35f497 (diff)
downloadtcl-a0655d89bbe9e5b91b703509126ed1c48a1cf405.zip
tcl-a0655d89bbe9e5b91b703509126ed1c48a1cf405.tar.gz
tcl-a0655d89bbe9e5b91b703509126ed1c48a1cf405.tar.bz2
Upgrade the capabilities of time limits by allowing them to fire in the midst
of the processing of the event loop or during a blocking [after]. [Bug 1085023]
-rw-r--r--ChangeLog20
-rw-r--r--generic/tclEvent.c6
-rw-r--r--generic/tclInt.h7
-rw-r--r--generic/tclInterp.c63
-rw-r--r--generic/tclTimer.c88
-rw-r--r--tests/interp.test25
6 files changed, 188 insertions, 21 deletions
diff --git a/ChangeLog b/ChangeLog
index 154fdfa..8ffd2ae 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,23 @@
+2004-12-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * generic/tclInterp.c (Tcl_LimitSetTime, TimeLimitCallback):
+ (TclLimitRemoveAllHandlers, TclInitLimitSupport): Set a timer
+ event to trigger when the time limit runs out. All the time limit
+ actually does is check to see if the time limit has been exceeded,
+ but this is enough to fix [Bug 1085023].
+ * generic/tclInt.h (struct Interp): Added a field to hold the token
+ for the timer event handler associated with the current time limit.
+ * generic/tclEvent.c (Tcl_UpdateObjCmd, Tcl_VwaitObjCmd): Add
+ error message when limit exceeded.
+ * tests/interp.test (interp-34.[89]): Check that time limits
+ handle the two cases reported in [Bug 1085023]
+
+ * generic/tclTimer.c (TclCreateAbsoluteTimerHandler): New internal
+ function that allows setting a timer handler that will be
+ triggered at (or after) a specific time instead of at some number
+ of milliseconds in the future. This is a candidate for future
+ exposure via a TIP.
+
2004-12-15 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c:
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 5a734c4..8d4533ec 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.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: tclEvent.c,v 1.55 2004/12/04 21:19:18 dgp Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.56 2004/12/16 19:36:17 dkf Exp $
*/
#include "tclInt.h"
@@ -1101,6 +1101,8 @@ Tcl_VwaitObjCmd(clientData, interp, objc, objv)
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
if (Tcl_LimitExceeded(interp)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "limit exceeded", NULL);
return TCL_ERROR;
}
}
@@ -1190,6 +1192,8 @@ Tcl_UpdateObjCmd(clientData, interp, objc, objv)
while (Tcl_DoOneEvent(flags) != 0) {
if (Tcl_LimitExceeded(interp)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "limit exceeded", NULL);
return TCL_ERROR;
}
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 38be9d5..5f10b46 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.207 2004/12/14 21:11:46 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.208 2004/12/16 19:36:34 dkf Exp $
*/
#ifndef _TCLINT
@@ -1408,6 +1408,8 @@ typedef struct Interp {
* is reached. */
int timeGranularity; /* Mod factor used to determine how often
* to evaluate the limit check. */
+ Tcl_TimerToken timeEvent; /* Handle for a timer callback that will
+ * occur when the time-limit is exceeded. */
Tcl_HashTable callbacks; /* Mapping from (interp,type) pair to data
* used to install a limit handler callback
@@ -2114,6 +2116,9 @@ MODULE_SCOPE int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData,
MODULE_SCOPE int Tcl_ContinueObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler _ANSI_ARGS_((
+ Tcl_Time *timePtr, Tcl_TimerProc *proc,
+ ClientData clientData));
MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index f6f53f2..4521b50 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.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: tclInterp.c,v 1.54 2004/12/02 15:31:28 dkf Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.55 2004/12/16 19:36:34 dkf Exp $
*/
#include "tclInt.h"
@@ -246,6 +246,7 @@ static void DeleteScriptLimitCallback _ANSI_ARGS_((
ClientData clientData));
static void RunLimitHandlers _ANSI_ARGS_((LimitHandler *handlerPtr,
Tcl_Interp *interp));
+static void TimeLimitCallback _ANSI_ARGS_((ClientData clientData));
/*
@@ -2946,7 +2947,7 @@ Tcl_MakeSafe(interp)
*
* Tcl_LimitExceeded --
*
- * Tests whether any limit has been exceededin the given
+ * Tests whether any limit has been exceeded in the given
* interpreter (i.e. whether the interpreter is currently unable
* to process further scripts).
*
@@ -3073,7 +3074,7 @@ Tcl_LimitCheck(interp)
iPtr->limit.exceeded |= TCL_LIMIT_TIME;
Tcl_Preserve(interp);
RunLimitHandlers(iPtr->limit.timeHandlers, interp);
- if (iPtr->limit.time.sec >= now.sec ||
+ 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;
@@ -3415,6 +3416,16 @@ TclLimitRemoveAllHandlers(interp)
ckfree((char *) handlerPtr);
}
}
+
+ /*
+ * Delete the timer callback that is used to trap limits that
+ * occur in [vwait]s...
+ */
+
+ if (iPtr->limit.timeEvent != NULL) {
+ Tcl_DeleteTimerHandler(iPtr->limit.timeEvent);
+ iPtr->limit.timeEvent = NULL;
+ }
}
/*
@@ -3611,14 +3622,59 @@ Tcl_LimitSetTime(interp, timeLimitPtr)
Tcl_Time *timeLimitPtr;
{
Interp *iPtr = (Interp *) interp;
+ Tcl_Time nextMoment;
memcpy(&iPtr->limit.time, timeLimitPtr, sizeof(Tcl_Time));
+ if (iPtr->limit.timeEvent != NULL) {
+ Tcl_DeleteTimerHandler(iPtr->limit.timeEvent);
+ }
+ nextMoment.sec = timeLimitPtr->sec;
+ nextMoment.usec = timeLimitPtr->usec+10;
+ if (nextMoment.usec >= 1000000) {
+ nextMoment.sec++;
+ nextMoment.usec -= 1000000;
+ }
+ iPtr->limit.timeEvent = TclCreateAbsoluteTimerHandler(&nextMoment,
+ TimeLimitCallback, (ClientData) interp);
iPtr->limit.exceeded &= ~TCL_LIMIT_COMMANDS;
}
/*
*----------------------------------------------------------------------
*
+ * TimeLimitCallback --
+ *
+ * Callback that allows time limits to be enforced even when
+ * doing a blocking wait for events.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May put the interpreter into a state where it can no longer
+ * execute commands. May make callbacks into other interpreters.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+TimeLimitCallback(clientData)
+ ClientData clientData;
+{
+ Tcl_Interp *interp = (Tcl_Interp *) clientData;
+
+ Tcl_Preserve((ClientData) interp);
+ ((Interp *)interp)->limit.timeEvent = NULL;
+ if (Tcl_LimitCheck(interp) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (while waiting for event)");
+ Tcl_BackgroundError(interp);
+ }
+ Tcl_Release((ClientData) interp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_LimitGetTime --
*
* Get the current time limit.
@@ -3928,6 +3984,7 @@ TclInitLimitSupport(interp)
iPtr->limit.cmdGranularity = 1;
memset(&iPtr->limit.time, 0, sizeof(Tcl_Time));
iPtr->limit.timeHandlers = NULL;
+ iPtr->limit.timeEvent = NULL;
iPtr->limit.timeGranularity = 10;
Tcl_InitHashTable(&iPtr->limit.callbacks,
sizeof(struct ScriptLimitCallbackKey)/sizeof(int));
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 8c5a210..12c2ce9 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.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: tclTimer.c,v 1.12 2004/10/06 15:59:25 dgp Exp $
+ * RCS: @(#) $Id: tclTimer.c,v 1.13 2004/12/16 19:36:35 dkf Exp $
*/
#include "tclInt.h"
@@ -223,30 +223,58 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData)
Tcl_TimerProc *proc; /* Procedure to invoke. */
ClientData clientData; /* Arbitrary data to pass to proc. */
{
- register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
Tcl_Time time;
- ThreadSpecificData *tsdPtr;
-
- tsdPtr = InitTimer();
-
- timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
/*
* Compute when the event should fire.
*/
Tcl_GetTime(&time);
- timerHandlerPtr->time.sec = time.sec + milliseconds/1000;
- timerHandlerPtr->time.usec = time.usec + (milliseconds%1000)*1000;
- if (timerHandlerPtr->time.usec >= 1000000) {
- timerHandlerPtr->time.usec -= 1000000;
- timerHandlerPtr->time.sec += 1;
+ time.sec += milliseconds/1000;
+ time.usec += (milliseconds%1000)*1000;
+ if (time.usec >= 1000000) {
+ time.usec -= 1000000;
+ time.sec += 1;
}
+ return TclCreateAbsoluteTimerHandler(&time, proc, clientData);
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * TclCreateAbsoluteTimerHandler --
+ *
+ * Arrange for a given procedure to be invoked at a particular
+ * time in the future.
+ *
+ * Results:
+ * The return value is a token for the timer event, which
+ * may be used to delete the event before it fires.
+ *
+ * Side effects:
+ * When the time in timePtr has been reached, proc will be invoked
+ * exactly once.
+ *
+ *--------------------------------------------------------------
+ */
+
+Tcl_TimerToken
+TclCreateAbsoluteTimerHandler(timePtr, proc, clientData)
+ Tcl_Time *timePtr;
+ Tcl_TimerProc *proc;
+ ClientData clientData;
+{
+ register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
+ ThreadSpecificData *tsdPtr;
+
+ tsdPtr = InitTimer();
+ timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
/*
- * Fill in other fields for the event.
+ * Fill in fields for the event.
*/
+ memcpy((void *)&timerHandlerPtr->time, (void *)timePtr, sizeof(Tcl_Time));
timerHandlerPtr->proc = proc;
timerHandlerPtr->clientData = clientData;
tsdPtr->lastTimerId++;
@@ -788,7 +816,39 @@ processInteger:
ms = 0;
}
if (objc == 2) {
- Tcl_Sleep(ms);
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->limit.timeEvent != NULL) {
+ Tcl_Time endTime, now;
+
+ Tcl_GetTime(&endTime);
+ endTime.sec += ms/1000;
+ endTime.usec += (ms%1000)*1000;
+ if (endTime.usec >= 1000000) {
+ endTime.sec++;
+ endTime.usec -= 1000000;
+ }
+
+ do {
+ Tcl_GetTime(&now);
+ if (endTime.sec < iPtr->limit.time.sec ||
+ (endTime.sec == iPtr->limit.time.sec &&
+ endTime.usec < iPtr->limit.time.usec)) {
+ Tcl_Sleep(1000*(endTime.sec - now.sec) +
+ (endTime.usec - now.usec)/1000);
+ break;
+ } else {
+ Tcl_Sleep(1000*(iPtr->limit.time.sec - now.sec) +
+ (iPtr->limit.time.usec - now.usec)/1000);
+ if (Tcl_LimitCheck(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ } while (endTime.sec > now.sec ||
+ (endTime.sec == now.sec && endTime.usec > now.usec));
+ } else {
+ Tcl_Sleep(ms);
+ }
return TCL_OK;
}
afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
diff --git a/tests/interp.test b/tests/interp.test
index 244a750..9308e90 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.43 2004/11/18 21:00:51 dgp Exp $
+# RCS: @(#) $Id: interp.test,v 1.44 2004/12/16 19:36:35 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -3075,7 +3075,28 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup {
rename cb3 {}
rename cb4 {}
}
-
+# Bug 1085023
+test interp-34.8 {time limits trigger in vwaits} -body {
+ set i [interp create]
+ interp limit $i time -seconds [expr {[clock seconds]+1}] -granularity 1
+ $i eval {
+ set x {}
+ vwait x
+ }
+} -cleanup {
+ interp delete $i
+} -returnCodes error -result {limit exceeded}
+test interp-34.9 {time limits trigger in blocking after} {
+ set i [interp create]
+ set t0 [clock seconds]
+ interp limit $i time -seconds [expr {$t0 + 1}] -granularity 1
+ set code [catch {
+ $i eval {after 10000}
+ } msg]
+ set t1 [clock seconds]
+ interp delete $i
+ list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}]
+} {1 {time limit exceeded} OK}
test interp-35.1 {interp limit syntax} -body {
interp limit
} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?options?"}