diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rw-r--r-- | generic/tclInterp.c | 14 | ||||
| -rw-r--r-- | tests/interp.test | 14 |
3 files changed, 31 insertions, 3 deletions
@@ -1,3 +1,9 @@ +2009-12-28 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclInterp.c (TimeLimitCallback): [Bug 2891362]: Ensure that + * tests/interp.test (interp-34.13): the granularity ticker is + reset when we check limits because of the time limit event firing. + 2009-12-27 Donal K. Fellows <dkf@users.sf.net> * doc/namespace.n (SCOPED SCRIPTS): [Bug 2921538]: Updated example to diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 67a031a..6ff8cea 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.83.2.2 2008/07/21 19:38:19 andreas_kupries Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.83.2.3 2009/12/28 10:05:22 dkf Exp $ */ #include "tclInt.h" @@ -3603,10 +3603,20 @@ TimeLimitCallback( ClientData clientData) { Tcl_Interp *interp = clientData; + Interp *iPtr = clientData; int code; Tcl_Preserve(interp); - ((Interp *)interp)->limit.timeEvent = NULL; + iPtr->limit.timeEvent = NULL; + + /* + * Must reset the granularity ticker here to force an immediate full + * check. This is OK because we're swallowing the cost in the overall cost + * of the event loop. [Bug 2891362] + */ + + iPtr->limit.granularityTicker = 0; + code = Tcl_LimitCheck(interp); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (while waiting for event)"); diff --git a/tests/interp.test b/tests/interp.test index 99a979e..62a45dc 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.54.2.1 2008/06/20 19:23:26 dgp Exp $ +# RCS: @(#) $Id: interp.test,v 1.54.2.2 2009/12/28 10:05:22 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -3275,6 +3275,18 @@ test interp-34.12 {time limit extension in callbacks} -setup { } -result {cb1 cb1 0 {} ok} -cleanup { rename cb1 {} } +test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup { + set i [interp create -safe] +} -body { + $i limit time -seconds [clock add [clock seconds] 1 second] + $i eval { + after 2000 set x timeout + vwait x + return $x + } +} -cleanup { + interp delete $i +} -returnCodes error -result {limit exceeded} test interp-35.1 {interp limit syntax} -body { interp limit |