diff options
Diffstat (limited to 'tests/timer.test')
| -rw-r--r-- | tests/timer.test | 346 |
1 files changed, 198 insertions, 148 deletions
diff --git a/tests/timer.test b/tests/timer.test index 4a85cda..ab6efc9 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -12,41 +12,45 @@ # # 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.5 1999/06/26 20:55:15 rjohnson Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* + package require tcltest 2 + namespace import -force ::tcltest::* } -test timer-1.1 {Tcl_CreateTimerHandler procedure} { +test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup { foreach i [after info] { after cancel $i } +} -body { set x "" foreach i {100 200 1000 50 150} { after $i lappend x $i } - after 200 - update - set x -} {50 100 150 200} + after 200 set done 1 + vwait done + return $x +} -cleanup { + foreach i [after info] { + after cancel $i + } +} -result {50 100 150 200} -test timer-2.1 {Tcl_DeleteTimerHandler procedure} { +test timer-2.1 {Tcl_DeleteTimerHandler procedure} -setup { foreach i [after info] { after cancel $i } +} -body { 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 - set x -} {100 200} + after 200 set done 1 + vwait done + return $x +} -result {100 200} # No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested # above. @@ -60,10 +64,11 @@ test timer-3.1 {TimerHandlerEventProc procedure: event masks} { update lappend result $x } {start fired} -test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} { +test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} -setup { foreach i [after info] { after cancel $i } +} -body { foreach i {200 600 1000} { after $i lappend x $i } @@ -78,45 +83,49 @@ test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} { after 400 update lappend result $x -} {200 {200 600} {200 600 1000}} -test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} { +} -result {200 {200 600} {200 600 1000}} +test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} -setup { foreach i [after info] { after cancel $i } +} -body { set x {} after 100 lappend x 100 set i [after 300 lappend x 300] after 200 after cancel $i after 400 update - set x -} 100 -test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} { + return $x +} -result 100 +test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} -setup { foreach i [after info] { after cancel $i } +} -body { set x {} after 100 lappend x a after 200 lappend x b after 300 lappend x c after 300 vwait x - set x -} {a b c} -test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} { + return $x +} -result {a b c} +test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} -setup { foreach i [after info] { after cancel $i } +} -body { set x {} after 100 {lappend x a; after 0 lappend x b} after 100 vwait x - set x -} a -test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} { + return $x +} -result a +test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} -setup { foreach i [after info] { after cancel $i } +} -body { set x {} after 100 {lappend x a; after 100 lappend x b; after 100} after 100 @@ -124,15 +133,16 @@ test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't set result $x vwait x lappend result $x -} {a {a b}} +} -result {a {a b}} # No tests for Tcl_DoWhenIdle: it's already tested by other tests # below. -test timer-4.1 {Tcl_CancelIdleCall procedure} { +test timer-4.1 {Tcl_CancelIdleCall procedure} -setup { foreach i [after info] { after cancel $i } +} -body { set x before set y before set z before @@ -141,12 +151,13 @@ test timer-4.1 {Tcl_CancelIdleCall procedure} { after idle set z after3 after cancel set y after2 update idletasks - concat $x $y $z -} {after1 before after3} -test timer-4.2 {Tcl_CancelIdleCall procedure} { + list $x $y $z +} -result {after1 before after3} +test timer-4.2 {Tcl_CancelIdleCall procedure} -setup { foreach i [after info] { after cancel $i } +} -body { set x before set y before set z before @@ -155,13 +166,14 @@ test timer-4.2 {Tcl_CancelIdleCall procedure} { after idle set z after3 after cancel set x after1 update idletasks - concat $x $y $z -} {before after2 after3} + list $x $y $z +} -result {before after2 after3} -test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} { +test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} -setup { foreach i [after info] { after cancel $i } +} -body { set x 1 set y 23 after idle {incr x; after idle {incr x; after idle {incr x}}} @@ -170,17 +182,17 @@ test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} { set result "$x $y" update idletasks lappend result $x -} {2 24 4} +} -result {2 24 4} -test timer-6.1 {Tcl_AfterCmd procedure, basics} { - list [catch {after} msg] $msg -} {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"}} -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}} +test timer-6.1 {Tcl_AfterCmd procedure, basics} -returnCodes error -body { + after +} -result {wrong # args: should be "after option ?arg ...?"} +test timer-6.2 {Tcl_AfterCmd procedure, basics} -returnCodes error -body { + after 2x +} -result {bad argument "2x": must be cancel, idle, info, or an integer} +test timer-6.3 {Tcl_AfterCmd procedure, basics} -returnCodes error -body { + after gorp +} -result {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} @@ -201,41 +213,44 @@ test timer-6.5 {Tcl_AfterCmd procedure, ms argument} { update list $y $x } {before after} -test timer-6.6 {Tcl_AfterCmd procedure, cancel option} { - list [catch {after cancel} msg] $msg -} {1 {wrong # args: should be "after cancel id|command"}} +test timer-6.6 {Tcl_AfterCmd procedure, cancel option} -body { + after cancel +} -returnCodes error -result {wrong # args: should be "after cancel id|command"} test timer-6.7 {Tcl_AfterCmd procedure, cancel option} { after cancel after#1 } {} test timer-6.8 {Tcl_AfterCmd procedure, cancel option} { after cancel {foo bar} } {} -test timer-6.9 {Tcl_AfterCmd procedure, cancel option} { +test timer-6.9 {Tcl_AfterCmd procedure, cancel option} -setup { foreach i [after info] { after cancel $i } +} -body { set x before set y [after 100 set x after] after cancel $y after 200 update - set x -} {before} -test timer-6.10 {Tcl_AfterCmd procedure, cancel option} { + return $x +} -result {before} +test timer-6.10 {Tcl_AfterCmd procedure, cancel option} -setup { foreach i [after info] { after cancel $i } +} -body { set x before after 100 set x after after cancel {set x after} after 200 update - set x -} {before} -test timer-6.11 {Tcl_AfterCmd procedure, cancel option} { + return $x +} -result {before} +test timer-6.11 {Tcl_AfterCmd procedure, cancel option} -setup { foreach i [after info] { after cancel $i } +} -body { set x before after 100 set x after set id [after 300 set x after] @@ -247,11 +262,12 @@ test timer-6.11 {Tcl_AfterCmd procedure, cancel option} { after 200 update list $y $x -} {after cleared} -test timer-6.12 {Tcl_AfterCmd procedure, cancel option} { +} -result {after cleared} +test timer-6.12 {Tcl_AfterCmd procedure, cancel option} -setup { foreach i [after info] { after cancel $i } +} -body { set x first after idle lappend x second after idle lappend x third @@ -259,12 +275,13 @@ test timer-6.12 {Tcl_AfterCmd procedure, cancel option} { after cancel {lappend x second} after cancel $i update idletasks - set x -} {first third} -test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} { + return $x +} -result {first third} +test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} -setup { foreach i [after info] { after cancel $i } +} -body { set x first after idle lappend x second after idle lappend x third @@ -272,12 +289,13 @@ test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for c after cancel lappend x second after cancel $i update idletasks - set x -} {first third} -test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} { + return $x +} -result {first third} +test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} -setup { foreach i [after info] { after cancel $i } +} -body { set id [ after 100 { set x done @@ -285,11 +303,12 @@ test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, u } ] vwait x -} {} -test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { +} -result {} +test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} -setup { foreach i [after info] { after cancel $i } +} -body { interp create x x eval {set a before; set b before; after idle {set a a-after}; after idle {set b b-after}} @@ -301,12 +320,12 @@ test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { x eval {after cancel set a a-after} update idletasks lappend result $a $b [x eval {list $a $b}] +} -cleanup { interp delete x - set result -} {2 0 aaa bbb {before b-after}} -test timer-6.16 {Tcl_AfterCmd procedure, idle option} { - list [catch {after idle} msg] $msg -} {1 {wrong # args: should be "after idle script script ..."}} +} -result {2 0 aaa bbb {before b-after}} +test timer-6.16 {Tcl_AfterCmd procedure, idle option} -body { + after idle +} -returnCodes error -result {wrong # args: should be "after idle script ?script ...?"} test timer-6.17 {Tcl_AfterCmd procedure, idle option} { set x before after idle {set x after} @@ -321,6 +340,7 @@ test timer-6.18 {Tcl_AfterCmd procedure, idle option} { update idletasks list $y $x } {before after} + set event1 [after idle event 1] set event2 [after 1000 event 2] interp create x @@ -328,120 +348,125 @@ set childEvent [x eval {after idle event in child}] test timer-6.19 {Tcl_AfterCmd, info option} { lsort [after info] } [lsort "$event1 $event2"] -test timer-6.20 {Tcl_AfterCmd, info option} { - list [catch {after info a b} msg] $msg -} {1 {wrong # args: should be "after info ?id?"}} -test timer-6.21 {Tcl_AfterCmd, info option} { - list [catch {after info $childEvent} msg] $msg -} "1 {event \"$childEvent\" doesn't exist}" +test timer-6.20 {Tcl_AfterCmd, info option} -returnCodes error -body { + after info a b +} -result {wrong # args: should be "after info ?id?"} +test timer-6.21 {Tcl_AfterCmd, info option} -returnCodes error -body { + after info $childEvent +} -result "event \"$childEvent\" doesn't exist" test timer-6.22 {Tcl_AfterCmd, info option} { list [after info $event1] [after info $event2] } {{{event 1} idle} {{event 2} timer}} - after cancel $event1 after cancel $event2 interp delete x -test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NULL} { +test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after 1 "set x ab\0cd" after 10 update string length $x -} {5} -test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NULL} { +} -result {5} +test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after 1 set x ab\0cd after 10 update string length $x -} {5} -test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NULL} { +} -result {5} +test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after 1 set x ab\0cd after cancel "set x ab\0ef" - set x [llength [after info]] + llength [after info] +} -cleanup { foreach i [after info] { after cancel $i } - set x -} {1} -test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} { +} -result {1} +test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after 1 set x ab\0cd after cancel set x ab\0ef - set y [llength [after info]] + llength [after info] +} -cleanup { foreach i [after info] { after cancel $i } - set y -} {1} -test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} { +} -result {1} +test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after idle "set x ab\0cd" update string length $x -} {5} -test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NULL} { +} -result {5} +test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after idle set x ab\0cd update string length $x -} {5} -test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} { +} -result {5} +test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" set id junk - set id [after 1 set x ab\0cd] + set id [after 10 set x ab\0cd] update - set y [string length [lindex [lindex [after info $id] 0] 2]] + string length [lindex [lindex [after info $id] 0] 2] +} -cleanup { foreach i [after info] { after cancel $i } - set y -} {5} +} -result 5 set event [after idle foo bar] -scan $event after#%d id - -test timer-7.1 {GetAfterEvent procedure} { - list [catch {after info xfter#$id} msg] $msg -} "1 {event \"xfter#$id\" doesn't exist}" -test timer-7.2 {GetAfterEvent procedure} { - list [catch {after info afterx$id} msg] $msg -} "1 {event \"afterx$id\" doesn't exist}" -test timer-7.3 {GetAfterEvent procedure} { - list [catch {after info after#ab} msg] $msg -} {1 {event "after#ab" doesn't exist}} -test timer-7.4 {GetAfterEvent procedure} { - list [catch {after info after#} msg] $msg -} {1 {event "after#" doesn't exist}} -test timer-7.5 {GetAfterEvent procedure} { - list [catch {after info after#${id}x} msg] $msg -} "1 {event \"after#${id}x\" doesn't exist}" -test timer-7.6 {GetAfterEvent procedure} { - list [catch {after info afterx[expr $id+1]} msg] $msg -} "1 {event \"afterx[expr $id+1]\" doesn't exist}" +scan $event after#%d lastId +test timer-7.1 {GetAfterEvent procedure} -returnCodes error -body { + after info xfter#$lastId +} -result "event \"xfter#$lastId\" doesn't exist" +test timer-7.2 {GetAfterEvent procedure} -returnCodes error -body { + after info afterx$lastId +} -result "event \"afterx$lastId\" doesn't exist" +test timer-7.3 {GetAfterEvent procedure} -returnCodes error -body { + after info after#ab +} -result {event "after#ab" doesn't exist} +test timer-7.4 {GetAfterEvent procedure} -returnCodes error -body { + after info after# +} -result {event "after#" doesn't exist} +test timer-7.5 {GetAfterEvent procedure} -returnCodes error -body { + after info after#${lastId}x +} -result "event \"after#${lastId}x\" doesn't exist" +test timer-7.6 {GetAfterEvent procedure} -returnCodes error -body { + after info afterx[expr {$lastId+1}] +} -result "event \"afterx[expr {$lastId+1}]\" doesn't exist" after cancel $event test timer-8.1 {AfterProc procedure} { @@ -455,27 +480,30 @@ 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)}}} -test timer-8.3 {AfterProc procedure, deleting handler from itself} { +test timer-8.3 {AfterProc procedure, deleting handler from itself} -setup { foreach i [after info] { after cancel $i } +} -body { proc foo {} { global x set x {} @@ -487,12 +515,13 @@ test timer-8.3 {AfterProc procedure, deleting handler from itself} { after idle foo after 1000 {error "I shouldn't ever have executed"} update idletasks - set x -} {{{error "I shouldn't ever have executed"} timer}} -test timer-8.4 {AfterProc procedure, deleting handler from itself} { + return $x +} -result {{{error "I shouldn't ever have executed"} timer}} +test timer-8.4 {AfterProc procedure, deleting handler from itself} -setup { foreach i [after info] { after cancel $i } +} -body { proc foo {} { global x set x {} @@ -504,8 +533,8 @@ test timer-8.4 {AfterProc procedure, deleting handler from itself} { after 1000 {error "I shouldn't ever have executed"} after idle foo update idletasks - set x -} {{{error "I shouldn't ever have executed"} timer}} + return $x +} -result {{{error "I shouldn't ever have executed"} timer}} foreach i [after info] { after cancel $i @@ -513,9 +542,9 @@ foreach i [after info] { # No test for FreeAfterPtr, since it is already tested above. - -test timer-9.1 {AfterCleanupProc procedure} { +test timer-9.1 {AfterCleanupProc procedure} -setup { catch {interp delete x} +} -body { interp create x x eval {after 200 { lappend x after @@ -535,21 +564,42 @@ test timer-9.1 {AfterCleanupProc procedure} { set x before after 300 update - set x -} {before after2 after4} + return $x +} -result {before after2 after4} + +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 + return $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 + return $l +} -result {-1 100} # cleanup ::tcltest::cleanupTests return - - - - - - - - - - - +# Local Variables: +# mode: tcl +# End: |