# 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.
#
# 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.2 2001/09/14 01:43:50 zlaski Exp $
if {[string compare test [info procs test]] == 1} then {source defs}
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
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}