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]

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?"}