# 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.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# On some platforms the short tolerance (in percent to wait-time) used to avoid
# busy waiting, so it may cause on the fast mashines, that waiting interupts a bit
# earlier as expected ("rounded" to this tolerance boundary).
#
# Following routines guarantee the timer event always occured in such cases.
variable tolerance 5
proc tl-after {ms args} {
variable tolerance
uplevel [list after [expr {$ms + double($ms*$tolerance/100)}] {*}$args]
}
proc tl-vwait {args} {
variable tolerance
set ms [lindex $args end-1]
set vn [lindex $args end]
uplevel [list vwait [expr {$ms + double($ms*$tolerance/100)}] {*}[lrange $args 0 end-2] $vn]
}
proc clean-up-events {} {
foreach i [after info] {
after cancel $i
}
}
test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup {
clean-up-events
} -body {
set x ""
foreach i {100 200 1000 50 150} {
after $i lappend x $i
}
tl-vwait 200 done
return $x
} -cleanup {
clean-up-events
} -result {50 100 150 200}
test timer-2.1 {Tcl_DeleteTimerHandler 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 cancel lappend x 150
after cancel lappend x 50
tl-vwait 200 done
return $x
} -result {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} -setup {
clean-up-events
} -body {
foreach i {200 600 1000} {
after $i lappend x $i
}
tl-after 200
set result ""
set x ""
update
lappend result $x
tl-after 400
update
lappend result $x
tl-after 400
update
lappend result $x
} -result {200 {200 600} {200 600 1000}}
test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} -setup {
clean-up-events
} -body {
set x {}
after 100 lappend x 100
set i [after 300 lappend x 300]
after 200 after cancel $i
tl-after 400
update
return $x
} -result 100
test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} -setup {
clean-up-events
} -body {
set x {}
after 100 lappend x a
after 200 lappend x b
after 300 lappend x c
tl-after 300
vwait x
return $x
} -result {a b c}
test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} -setup {
clean-up-events
} -body {
set x {}
after 10 {lappend x a; after 0 lappend x b}
after 50
vwait x
return $x
} -result a
test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} -setup {
clean-up-events
} -body {
set x {}
after 100 {lappend x a; after 100 lappend x b; after 100}
tl-after 100
vwait x
set result $x
vwait x
lappend result $x
} -result {a {a b}}
# No tests for Tcl_DoWhenIdle: it's already tested by other tests
# below.
test timer-4.1 {Tcl_CancelIdleCall procedure} -setup {
clean-up-events
} -body {
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
list $x $y $z
} -result {after1 before after3}
test timer-4.2 {Tcl_CancelIdleCall procedure} -setup {
clean-up-events
} -body {
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
list $x $y $z
} -result {before after2 after3}
test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} -setup {
clean-up-events
} -body {
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
} -result {2 24 4}
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 at, cancel, idle, info or a time}
test timer-6.3 {Tcl_AfterCmd procedure, basics} -returnCodes error -body {
after gorp
} -result {bad argument "gorp": must be at, cancel, idle, info or a time}
test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
set x before
# cover prompt events also (immediate handling differs now):
after 0 {lappend x immediate}
lappend x before-immediate
update
lappend x after-immediate
after 100 {lappend x after}
after 10
update
lappend x nothing
after 200
lappend x before-after
update
lappend x after-after
set x
} {before before-immediate immediate after-immediate nothing before-after after after-after}
test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
set x before
after 100 set x after
after 10
update
set y $x
after 200
update
list $y $x
} {before after}
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} -setup {
clean-up-events
} -body {
set x before
set y [after 10 set x after]
after cancel $y
after 100
update
return $x
} -result {before}
test timer-6.10 {Tcl_AfterCmd procedure, cancel option} -setup {
clean-up-events
} -body {
set x before
after 10 set x after
after cancel {set x after}
after 100
update
return $x
} -result {before}
test timer-6.11 {Tcl_AfterCmd procedure, cancel option} -setup {
clean-up-events
} -body {
set x before
after 10 set x after-10
set id [after 30 set x after-30]
after cancel $id
after 100
update
set y $x
set x cleared
after 100
update
list $y $x
} -result {after-10 cleared}
test timer-6.12 {Tcl_AfterCmd procedure, cancel option} -setup {
clean-up-events
} -body {
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
return $x
} -result {first third}
test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} -setup {
clean-up-events
} -body {
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
return $x
} -result {first third}
test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} -setup {
clean-up-events
} -body {
set id [
after 10 {
set x done
after cancel $id
after idle {set y done}
}
]
list [tl-vwait 1000 x] [tl-vwait 100 y]
} -result {1 1}
test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} -setup {
clean-up-events
} -body {
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}]
} -cleanup {
interp delete x
} -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}
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.19.1 {Tcl_AfterCmd, info option (all events in child)} {
x eval {after info}
} [list $childEvent]
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.21.1 {Tcl_AfterCmd, info option (internal representation)} {
list [catch {x eval [list after info $childEvent]} msg] $msg
} {0 {{event in child} idle}}
test timer-6.21.1 {Tcl_AfterCmd, info option (internal representation)} {
list [catch {x eval [list after info $childEvent]} msg] $msg
} {0 {{event in child} idle}}
test timer-6.21.2 {Tcl_AfterCmd, info option (search using string representation)} {
list [catch {x eval [list after info [string trim " $childEvent "]]} msg] $msg
} {0 {{event in child} idle}}
test timer-6.22 {Tcl_AfterCmd, info option} {
list [after info $event1] [after info $event2]
} {{{event 1} idle} {{event 2} timer}}
test timer-6.22.1 {Tcl_AfterCmd, cancel option (internal representation)} {
after cancel $childEvent; # foreign event - does nothing
# check still available:
list [catch {x eval [list after info $childEvent]} msg] $msg
} {0 {{event in child} idle}}
test timer-6.22.2 {Tcl_AfterCmd, cancel option (search using string representation)} {
after cancel [string trim " $childEvent "]; # foreign event - does nothing
# check still available:
set lst [list [catch {x eval [list after info $childEvent]} msg] $msg]
# cancel again but in child:
x eval [list after cancel [string trim " $childEvent "]]
# check it was canceled:
lappend lst {*}[list [catch {x eval [list after info $childEvent]} msg] $msg]
} [list 0 {{event in child} idle} 1 "event \"$childEvent\" doesn't exist"]
after cancel $event1
after cancel $event2
interp delete x
test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NUL} -setup {
clean-up-events
} -body {
set x "hello world"
after 1 "set x ab\0cd"
after 10
update
string length $x
} -result {5}
test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NUL} -setup {
clean-up-events
} -body {
set x "hello world"
after 1 set x ab\0cd
after 10
update
string length $x
} -result {5}
test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup {
clean-up-events
} -body {
set x "hello world"
after 1 set x ab\0cd
after cancel "set x ab\0ef"
llength [after info]
} -cleanup {
clean-up-events
} -result {1}
test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup {
clean-up-events
} -body {
set x "hello world"
after 1 set x ab\0cd
after cancel set x ab\0ef
llength [after info]
} -cleanup {
clean-up-events
} -result {1}
test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup {
clean-up-events
} -body {
set x "hello world"
after idle "set x ab\0cd"
update
string length $x
} -result {5}
test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup {
clean-up-events
} -body {
set x "hello world"
after idle set x ab\0cd
update
string length $x
} -result {5}
test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NUL} -setup {
clean-up-events
} -body {
set x "hello world"
set id junk
set id [after 10 set x ab\0cd]
update
string length [lindex [lindex [after info $id] 0] 2]
} -cleanup {
clean-up-events
} -result 5
set event [after idle foo bar]
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} {
set x before
proc foo {} {
set x untouched
after 10 {set x after}
after 100
update
return $x
}
list [foo] $x
} {untouched after}
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 10 {error "After error"}
after 100
set y $x
update
list $y $x
} -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} -setup {
clean-up-events
} -body {
proc foo {} {
global x
set x {}
foreach i [after info] {
lappend x [after info $i]
}
after cancel foo
}
after idle foo
after 0 {error "I shouldn't ever have executed"}
update idletasks
clean-up-events
return $x
} -result {{{error "I shouldn't ever have executed"} timer}}
test timer-8.4 {AfterProc procedure, deleting handler from itself} -setup {
clean-up-events
} -body {
proc foo {} {
global x
set x {}
foreach i [after info] {
lappend x [after info $i]
}
after cancel foo
}
after 0 {error "I shouldn't ever have executed"}
after 1 {error "I also shouldn't ever have executed"}
after idle foo
update idletasks
lsort $x
} -result [lsort {{{error "I shouldn't ever have executed"} timer} {{error "I also shouldn't ever have executed"} timer}}]
clean-up-events
# No test for FreeAfterPtr, since it is already tested above.
test timer-9.1 {AfterCleanupProc procedure} -setup {
catch {interp delete x}
} -body {
interp create x
x eval {after 10 {
lappend x after
puts "part 1: this message should not appear"
}}
after 10 {lappend x after2}
x eval {after 10 {
lappend x after3
puts "part 2: this message should not appear"
}}
after 10 {lappend x after4}
x eval {after 10 {
lappend x after5
puts "part 3: this message should not appear"
}}
interp delete x
set x before
after 100
update
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} -setup {
clean-up-events
} -body {
set b ok
set a [after 0x100000001 {set b "after fired early"}]
list [vwait 100 b] [set b]
} -cleanup {
catch {after cancel $a}
} -result {0 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}
test timer-11.3 {[after] correct timer ordering (insert ahead)} -setup {
clean-up-events
} -body {
after 10 {set done 1}
foreach l {1 0.75 0.5 0.25 0.1 0} {
after $l [list lappend l "ev:$l"]
}
set l {}
vwait done
set l
} -result {ev:0 ev:0.1 ev:0.25 ev:0.5 ev:0.75 ev:1}
# -----------------------------------------------------------------------------
#
# timer-20.x --
#
# Following test-cases cover event-driven functionality during time-jump's
#
# Note: on some platforms it is only possible if the user has corresponding
# privileges to change system date and time.
#
# Ex.: sudo LD_LIBRARY_PATH=. ./tclsh ../tests/timer.test -match timer-20.*
# -----------------------------------------------------------------------------
proc timejump {args} {
set tnow [clock clicks]
set tm [clock format [clock add [clock seconds] {*}$args] -format %H:%M:%S]
#puts -nonewline "***[format \[%04X\] [pid]]*** jump to $tm ($args) "
if {$::tcl_platform(platform) eq "windows"} {
exec $::env(COMSPEC) /c time $tm
} else {
exec date +%T -s $tm
}
#puts "***[format \[%04X\] [pid]]*** [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}] =="
}
testConstraint ChangeTimePrivilege [expr {![catch { timejump 0 minutes }]}]
testConstraint NewVWaitAfter [expr {![catch { vwait 0 nothing }]}]
# provide monotonic command, if "clock monotonic" not available (old core):
if {![catch {::tcl::clock::monotonic}]} {
namespace inscope ::tcl::clock {namespace export monotonic}
namespace import ::tcl::clock::monotonic
} else {
proc monotonic {} {
variable tickFactor
# warming-up:
clock clicks; clock microseconds
# calc tick2usec factor:
set tick [::tcl::clock::clicks]; set usec [::tcl::clock::microseconds]
after 100
set tickFactor [expr {double([::tcl::clock::clicks] - $tick) / ([::tcl::clock::microseconds] - $usec)}]
proc monotonic {} {
variable tickFactor
expr {wide([::tcl::clock::clicks] / $tickFactor)}
}
monotonic
}
}
# asynchronous function doing 3 time jumps (+1 min, +1 min, -2 minutes) in 250-ms:
proc delayedtimejump {delay {async 1} {startms {}}} {
# async code (executed in separate process):
if {$async} {
set code ""
foreach pr {timejump delayedtimejump} {
append code [list proc $pr [info args $pr] [info body $pr]] \n
}
append code "delayedtimejump $delay 0 [::tcl::clock::milliseconds]"
exec [info nameofexecutable] << $code &
return
}
# time-jumps (1st in 250-ms, 2nd and 3rd in given delay):
set delay1 250
if {$startms ne {}} {
set delay1 [expr {250 - ([::tcl::clock::milliseconds] - $startms)}]
if {$delay1 < 0} { set delay1 0 }
}
after $delay1; timejump +1 minutes
after $delay; timejump +1 minutes
after $delay; timejump -2 minutes
}
proc test-timer-with-jump {code maxCount expMT {maxOffs 100}} {
set mitm [set sttm [clock seconds]]
set stmt [monotonic]
set expMT [expr {$expMT * 1000}]
set maxOffs [expr {$maxOffs * 1000}]
set res {}
set jumped 0
for {set i 0} {$i < $maxCount} {incr i} {
set rt [::tcl::clock::microseconds]
set mt [monotonic]
# execute:
if 1 $code
# verify monotonic time:
set mt [expr {[monotonic] - $mt}]
set rt [expr {[::tcl::clock::microseconds] - $rt}]
# give +/- 100-ms for some slow or busy systems:
if {$mt < $expMT - $maxOffs || $mt > $expMT + $maxOffs} {
lappend res "$i. too large discrepancy mt: $mt ~ $expMT (rt: $rt)"
} else {
#lappend res "$i. debug, # mt: $mt, rt: $rt"
}
# be sure we are in the future and then comming back:
if {$jumped > 2} break; # we are already back
if {[clock seconds] - $mitm > 30 || [clock seconds] - $mitm < -30} {
set mitm [clock seconds]
incr jumped
}
}
# wait for time-jump back (from the future):
set future [clock add $sttm +30 seconds]
set aftto [after 10000 {set tout 1}]
while {[clock seconds] >= $future} {
if {[vwait 100 tout]} {
error "unexpected case: too long wait for time-reset."
}
}
after cancel $aftto
after 10
# result:
if {[llength $res]} {
return [join $res \n]
}
return $jumped
}
test timer-20.1 {time jump: after relative} {ChangeTimePrivilege} {
delayedtimejump 250; # delayed time jump in 250-ms
test-timer-with-jump {
after 150 {set x 1}; vwait x
} 20 150
} 3
test timer-20.2 {time jump: vwait timeout} {ChangeTimePrivilege NewVWaitAfter} {
delayedtimejump 250; # delayed time jump in 250-ms
test-timer-with-jump {
vwait -timer 150 nothing; # we want listen timer only
} 20 150
} 3
test timer-20.3 {time jump: simple sleep} {ChangeTimePrivilege} {
delayedtimejump 250; # delayed time jump in 250-ms
test-timer-with-jump {
after 150
} 20 150
} 3
# Increase delay between time-jumps (1.5s) for possible retarded reaction of
# the notifier by absolute timers (retarded recognition of the time-jump so
# the time can jump again (also backwards) without recognition.
# Note also we cannot test absolute timers by the backwards time-jump.
test timer-20.4 {time jump: after absolute time - "after at real-time code"} {ChangeTimePrivilege NewVWaitAfter} {
set sttm [clock seconds]
set i 0
foreach tm [list \
[clock add $sttm +1 minute -2 second] \
[clock add $sttm +2 minute -2 second] \
] {
after at $tm [list set x$i 1]
incr i
}
delayedtimejump 1500; # delayed time jump in 1.5s
test-timer-with-jump {
# we want listen timer only:
if {![vwait -timer 10000 x$i]} {
error "too long wait for \"x$i\" (should be maximal 1 second)"
}
} 2 250 3000; # max 3 seconds difference (compared to 1 minute)
} 2
test timer-20.5 {time jump: sleep to absolute time - "after at real-time"} {ChangeTimePrivilege NewVWaitAfter} {
set sttm [clock seconds]
set offsLst [list \
[clock add $sttm +1 minute] \
[clock add $sttm +2 minute] \
]
delayedtimejump 1500; # delayed time jump in 1.5s
test-timer-with-jump {
upvar offsLst offsLst
after at [lindex $offsLst $i]
} 2 250 3000; # max 3 seconds difference (compared to 1 minute)
} 2
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End: