# This file contains a collection of tests for the procedures in the # file tclTimer.c, which includes the "after" Tcl command. Sourcing # this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # 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.1.1.1 2007/07/10 15:04:24 duncan Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } test timer-1.1 {Tcl_CreateTimerHandler procedure} { foreach i [after info] { after cancel $i } set x "" foreach i {100 200 1000 50 150} { after $i lappend x $i } after 200 update set x } {50 100 150 200} test timer-2.1 {Tcl_DeleteTimerHandler procedure} { foreach i [after info] { after cancel $i } set x "" foreach i {100 200 300 50 150} { after $i lappend x $i } after cancel lappend x 150 after cancel lappend x 50 after 200 update set x } {100 200} # No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested # above. test timer-3.1 {TimerHandlerEventProc procedure: event masks} { set x start after 100 { set x fired } update idletasks set result $x after 200 update lappend result $x } {start fired} test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} { foreach i [after info] { after cancel $i } foreach i {200 600 1000} { after $i lappend x $i } after 200 set result "" set x "" update lappend result $x after 400 update lappend result $x after 400 update lappend result $x } {200 {200 600} {200 600 1000}} test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} { foreach i [after info] { after cancel $i } 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} { foreach i [after info] { after cancel $i } 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} { foreach i [after info] { after cancel $i } 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} { foreach i [after info] { after cancel $i } set x {} after 100 {lappend x a; after 100 lappend x b; after 100} after 100 vwait x set result $x vwait x lappend result $x } {a {a b}} # No tests for Tcl_DoWhenIdle: it's already tested by other tests # below. test timer-4.1 {Tcl_CancelIdleCall procedure} { foreach i [after info] { after cancel $i } set x before set y before set z before after idle set x after1 after idle set y after2 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} { foreach i [after info] { after cancel $i } set x before set y before set z before after idle set x after1 after idle set y after2 after idle set z after3 after cancel set x after1 update idletasks concat $x $y $z } {before after2 after3} test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} { foreach i [after info] { after cancel $i } set x 1 set y 23 after idle {incr x; after idle {incr x; after idle {incr x}}} after idle {incr y} vwait x set result "$x $y" update idletasks lappend result $x } {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.4 {Tcl_AfterCmd procedure, ms argument} { set x before after 400 {set x after} after 200 update set y $x after 400 update list $y $x } {before after} test timer-6.5 {Tcl_AfterCmd procedure, ms argument} { set x before after 300 set x after after 200 update set y $x after 200 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.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} { foreach i [after info] { after cancel $i } 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} { foreach i [after info] { after cancel $i } 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} { foreach i [after info] { after cancel $i } set x before after 100 set x after set id [after 300 set x after] after cancel $id after 200 update set y $x set x cleared after 200 update list $y $x } {after cleared} test timer-6.12 {Tcl_AfterCmd procedure, cancel option} { foreach i [after info] { after cancel $i } set x first after idle lappend x second after idle lappend x third set i [after idle lappend x fourth] 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} { foreach i [after info] { after cancel $i } set x first after idle lappend x second after idle lappend x third set i [after idle lappend x fourth] 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} { foreach i [after info] { after cancel $i } set id [ after 100 { set x done after cancel $id } ] vwait x } {} test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { foreach i [after info] { after cancel $i } interp create x x eval {set a before; set b before; after idle {set a a-after}; after idle {set b b-after}} set result [llength [x eval after info]] lappend result [llength [after info]] after cancel {set b b-after} set a aaa set b bbb x eval {after cancel set a a-after} update idletasks lappend result $a $b [x eval {list $a $b}] 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 ..."}} test timer-6.17 {Tcl_AfterCmd procedure, idle option} { set x before after idle {set x after} set y $x update idletasks list $y $x } {before after} test timer-6.18 {Tcl_AfterCmd procedure, idle option} { set x before after idle set x after set y $x update idletasks list $y $x } {before after} set event1 [after idle event 1] set event2 [after 1000 event 2] interp create x 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.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} { foreach i [after info] { after cancel $i } 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} { foreach i [after info] { after cancel $i } 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} { foreach i [after info] { after cancel $i } set x "hello world" after 1 set x ab\0cd after cancel "set x ab\0ef" set x [llength [after info]] foreach i [after info] { after cancel $i } set x } {1} test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} { foreach i [after info] { after cancel $i } set x "hello world" after 1 set x ab\0cd after cancel set x ab\0ef set y [llength [after info]] foreach i [after info] { after cancel $i } set y } {1} test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} { foreach i [after info] { after cancel $i } 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} { foreach i [after info] { after cancel $i } 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} { foreach i [after info] { after cancel $i } set x "hello world" set id junk set id [after 10 set x ab\0cd] update set y [string length [lindex [lindex [after info $id] 0] 2]] foreach i [after info] { after cancel $i } set y } {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}" after cancel $event test timer-8.1 {AfterProc procedure} { set x before proc foo {} { set x untouched after 100 {set x after} after 200 update return $x } 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 after 100 {error "After error"} after 200 set y $x update catch {rename bgerror {}} list $y $x } {empty {{After error} {After error while executing "error "After error"" ("after" script)}}} test timer-8.3 {AfterProc procedure, deleting handler from itself} { foreach i [after info] { after cancel $i } proc foo {} { global x set x {} foreach i [after info] { lappend x [after info $i] } after cancel foo } 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} { foreach i [after info] { after cancel $i } proc foo {} { global x set x {} foreach i [after info] { lappend x [after info $i] } after cancel foo } after 1000 {error "I shouldn't ever have executed"} after idle foo update idletasks set x } {{{error "I shouldn't ever have executed"} timer}} foreach i [after info] { after cancel $i } # No test for FreeAfterPtr, since it is already tested above. test timer-9.1 {AfterCleanupProc procedure} { catch {interp delete x} interp create x x eval {after 200 { lappend x after puts "part 1: this message should not appear" }} after 200 {lappend x after2} x eval {after 200 { lappend x after3 puts "part 2: this message should not appear" }} after 200 {lappend x after4} x eval {after 200 { lappend x after5 puts "part 3: this message should not appear" }} interp delete x set x before after 300 update set x } {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.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