diff options
Diffstat (limited to 'tests/timer.test')
| -rw-r--r-- | tests/timer.test | 84 |
1 files changed, 56 insertions, 28 deletions
diff --git a/tests/timer.test b/tests/timer.test index 2b9c9c5..db508e5 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -12,8 +12,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: timer.test,v 1.7 2000/04/10 17:19:05 ericm Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -28,8 +26,8 @@ test timer-1.1 {Tcl_CreateTimerHandler procedure} { foreach i {100 200 1000 50 150} { after $i lappend x $i } - after 200 - update + after 200 set done 1 + vwait done set x } {50 100 150 200} @@ -38,13 +36,13 @@ test timer-2.1 {Tcl_DeleteTimerHandler procedure} { after cancel $i } set x "" - foreach i {100 200 300 50 150} { + foreach i {100 200 1000 50 150} { after $i lappend x $i } after cancel lappend x 150 after cancel lappend x 50 - after 200 - update + after 200 set done 1 + vwait done set x } {100 200} @@ -177,10 +175,10 @@ test timer-6.1 {Tcl_AfterCmd procedure, basics} { } {1 {wrong # args: should be "after option ?arg arg ...?"}} test timer-6.2 {Tcl_AfterCmd procedure, basics} { list [catch {after 2x} msg] $msg -} {1 {expected integer but got "2x"}} +} {1 {bad argument "2x": must be cancel, idle, info, or an integer}} test timer-6.3 {Tcl_AfterCmd procedure, basics} { list [catch {after gorp} msg] $msg -} {1 {bad argument "gorp": must be cancel, idle, info, or a number}} +} {1 {bad argument "gorp": must be cancel, idle, info, or an integer}} test timer-6.4 {Tcl_AfterCmd procedure, ms argument} { set x before after 400 {set x after} @@ -455,20 +453,22 @@ test timer-8.1 {AfterProc procedure} { } list [foo] $x } {untouched after} -test timer-8.2 {AfterProc procedure} { - catch {rename bgerror {}} - proc bgerror msg { - global x errorInfo - set x [list $msg $errorInfo] - } - set x empty +test timer-8.2 {AfterProc procedure} -setup { + variable x empty + proc myHandler {msg options} { + variable x [list $msg [dict get $options -errorinfo]] + } + set handler [interp bgerror {}] + interp bgerror {} [namespace which myHandler] +} -body { after 100 {error "After error"} after 200 set y $x update - catch {rename bgerror {}} list $y $x -} {empty {{After error} {After error +} -cleanup { + interp bgerror {} $handler +} -result {empty {{After error} {After error while executing "error "After error"" ("after" script)}}} @@ -538,18 +538,46 @@ test timer-9.1 {AfterCleanupProc procedure} { set x } {before after2 after4} -# cleanup -::tcltest::cleanupTests -return - - - - - - - +test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup { + interp create slave + slave eval namespace export after + slave eval namespace eval foo namespace import ::after +} -body { + slave eval foo::after 1 + slave eval namespace origin foo::after +} -cleanup { + # Bug will cause crash here; would cause failure otherwise + interp delete slave +} -result ::after +test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} \ + -body { + set b ok + set a [after 0x100000001 {set b "after fired early"}] + after 100 set done 1 + vwait done + set b + } \ + -cleanup { + catch {after cancel $a} + } \ + -result ok +test timer-11.2 {Bug 1350293: [after] negative argument} \ + -body { + set l {} + after 100 {lappend l 100; set done 1} + after -1 {lappend l -1} + vwait done + set l + } \ + -result {-1 100} +# cleanup +::tcltest::cleanupTests +return +# Local Variables: +# mode: tcl +# End: |