sl@0: # This file contains a collection of tests for the procedures in the
sl@0: # file tclTimer.c, which includes the "after" Tcl command.  Sourcing
sl@0: # this file into Tcl runs the tests and generates output for errors.
sl@0: # No output means no errors were found.
sl@0: #
sl@0: # This file contains a collection of tests for one or more of the Tcl
sl@0: # built-in commands.  Sourcing this file into Tcl runs the tests and
sl@0: # generates output for errors.  No output means no errors were found.
sl@0: #
sl@0: # Copyright (c) 1997 by Sun Microsystems, Inc.
sl@0: # Copyright (c) 1998-1999 by Scriptics Corporation.
sl@0: #
sl@0: # See the file "license.terms" for information on usage and redistribution
sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0: #
sl@0: # RCS: @(#) $Id: timer.test,v 1.7.22.2 2005/11/09 21:46:20 kennykb Exp $
sl@0: 
sl@0: if {[lsearch [namespace children] ::tcltest] == -1} {
sl@0:     package require tcltest 2
sl@0:     namespace import -force ::tcltest::*
sl@0: }
sl@0: 
sl@0: test timer-1.1 {Tcl_CreateTimerHandler procedure} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x ""
sl@0:     foreach i {100 200 1000 50 150} {
sl@0: 	after $i lappend x $i
sl@0:     }
sl@0:     after 200
sl@0:     update
sl@0:     set x
sl@0: } {50 100 150 200}
sl@0: 
sl@0: test timer-2.1 {Tcl_DeleteTimerHandler procedure} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x ""
sl@0:     foreach i {100 200 300 50 150} {
sl@0: 	after $i lappend x $i
sl@0:     }
sl@0:     after cancel lappend x 150
sl@0:     after cancel lappend x 50
sl@0:     after 200
sl@0:     update
sl@0:     set x
sl@0: } {100 200}
sl@0: 
sl@0: # No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested
sl@0: # above.
sl@0: 
sl@0: test timer-3.1 {TimerHandlerEventProc procedure: event masks} {
sl@0:     set x start
sl@0:     after 100 { set x fired }
sl@0:     update idletasks
sl@0:     set result $x
sl@0:     after 200
sl@0:     update
sl@0:     lappend result $x
sl@0: } {start fired}
sl@0: test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     foreach i {200 600 1000} {
sl@0: 	after $i lappend x $i
sl@0:     }
sl@0:     after 200
sl@0:     set result ""
sl@0:     set x ""
sl@0:     update
sl@0:     lappend result $x
sl@0:     after 400
sl@0:     update
sl@0:     lappend result $x
sl@0:     after 400
sl@0:     update
sl@0:     lappend result $x
sl@0: } {200 {200 600} {200 600 1000}}
sl@0: test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x {}
sl@0:     after 100 lappend x 100
sl@0:     set i [after 300 lappend x 300]
sl@0:     after 200 after cancel $i
sl@0:     after 400
sl@0:     update
sl@0:     set x
sl@0: } 100
sl@0: test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x {}
sl@0:     after 100 lappend x a
sl@0:     after 200 lappend x b
sl@0:     after 300 lappend x c
sl@0:     after 300
sl@0:     vwait x
sl@0:     set x
sl@0: } {a b c}
sl@0: test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x {}
sl@0:     after 100 {lappend x a; after 0 lappend x b}
sl@0:     after 100
sl@0:     vwait x
sl@0:     set x
sl@0: } a
sl@0: test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x {}
sl@0:     after 100 {lappend x a; after 100 lappend x b; after 100}
sl@0:     after 100
sl@0:     vwait x
sl@0:     set result $x
sl@0:     vwait x
sl@0:     lappend result $x
sl@0: } {a {a b}}
sl@0: 
sl@0: # No tests for Tcl_DoWhenIdle:  it's already tested by other tests
sl@0: # below.
sl@0: 
sl@0: test timer-4.1 {Tcl_CancelIdleCall procedure} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x before
sl@0:     set y before
sl@0:     set z before
sl@0:     after idle set x after1
sl@0:     after idle set y after2
sl@0:     after idle set z after3
sl@0:     after cancel set y after2
sl@0:     update idletasks
sl@0:     concat $x $y $z
sl@0: } {after1 before after3}
sl@0: test timer-4.2 {Tcl_CancelIdleCall procedure} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x before
sl@0:     set y before
sl@0:     set z before
sl@0:     after idle set x after1
sl@0:     after idle set y after2
sl@0:     after idle set z after3
sl@0:     after cancel set x after1
sl@0:     update idletasks
sl@0:     concat $x $y $z
sl@0: } {before after2 after3}
sl@0: 
sl@0: test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x 1
sl@0:     set y 23
sl@0:     after idle {incr x; after idle {incr x; after idle {incr x}}}
sl@0:     after idle {incr y}
sl@0:     vwait x
sl@0:     set result "$x $y"
sl@0:     update idletasks
sl@0:     lappend result $x
sl@0: } {2 24 4}
sl@0: 
sl@0: test timer-6.1 {Tcl_AfterCmd procedure, basics} {
sl@0:     list [catch {after} msg] $msg
sl@0: } {1 {wrong # args: should be "after option ?arg arg ...?"}}
sl@0: test timer-6.2 {Tcl_AfterCmd procedure, basics} {
sl@0:     list [catch {after 2x} msg] $msg
sl@0: } {1 {expected integer but got "2x"}}
sl@0: test timer-6.3 {Tcl_AfterCmd procedure, basics} {
sl@0:     list [catch {after gorp} msg] $msg
sl@0: } {1 {bad argument "gorp": must be cancel, idle, info, or a number}}
sl@0: test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
sl@0:     set x before
sl@0:     after 400 {set x after}
sl@0:     after 200
sl@0:     update
sl@0:     set y $x
sl@0:     after 400
sl@0:     update
sl@0:     list $y $x
sl@0: } {before after}
sl@0: test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
sl@0:     set x before
sl@0:     after 300 set x after
sl@0:     after 200
sl@0:     update
sl@0:     set y $x
sl@0:     after 200
sl@0:     update
sl@0:     list $y $x
sl@0: } {before after}
sl@0: test timer-6.6 {Tcl_AfterCmd procedure, cancel option} {
sl@0:     list [catch {after cancel} msg] $msg
sl@0: } {1 {wrong # args: should be "after cancel id|command"}}
sl@0: test timer-6.7 {Tcl_AfterCmd procedure, cancel option} {
sl@0:     after cancel after#1
sl@0: } {}
sl@0: test timer-6.8 {Tcl_AfterCmd procedure, cancel option} {
sl@0:     after cancel {foo bar}
sl@0: } {}
sl@0: test timer-6.9 {Tcl_AfterCmd procedure, cancel option} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x before
sl@0:     set y [after 100 set x after]
sl@0:     after cancel $y
sl@0:     after 200
sl@0:     update
sl@0:     set x
sl@0: } {before}
sl@0: test timer-6.10 {Tcl_AfterCmd procedure, cancel option} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x before
sl@0:     after 100 set x after
sl@0:     after cancel {set x after}
sl@0:     after 200
sl@0:     update
sl@0:     set x
sl@0: } {before}
sl@0: test timer-6.11 {Tcl_AfterCmd procedure, cancel option} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x before
sl@0:     after 100 set x after
sl@0:     set id [after 300 set x after]
sl@0:     after cancel $id
sl@0:     after 200
sl@0:     update
sl@0:     set y $x
sl@0:     set x cleared
sl@0:     after 200
sl@0:     update
sl@0:     list $y $x
sl@0: } {after cleared}
sl@0: test timer-6.12 {Tcl_AfterCmd procedure, cancel option} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x first
sl@0:     after idle lappend x second
sl@0:     after idle lappend x third
sl@0:     set i [after idle lappend x fourth]
sl@0:     after cancel {lappend x second}
sl@0:     after cancel $i
sl@0:     update idletasks
sl@0:     set x
sl@0: } {first third}
sl@0: test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x first
sl@0:     after idle lappend x second
sl@0:     after idle lappend x third
sl@0:     set i [after idle lappend x fourth]
sl@0:     after cancel lappend x second
sl@0:     after cancel $i
sl@0:     update idletasks
sl@0:     set x
sl@0: } {first third}
sl@0: test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set id [
sl@0: 	after 100 {
sl@0: 	    set x done
sl@0: 	    after cancel $id
sl@0: 	}
sl@0:     ]
sl@0:     vwait x
sl@0: } {}
sl@0: test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     interp create x
sl@0:     x eval {set a before; set b before; after idle {set a a-after};
sl@0: 	    after idle {set b b-after}}
sl@0:     set result [llength [x eval after info]]
sl@0:     lappend result [llength [after info]]
sl@0:     after cancel {set b b-after}
sl@0:     set a aaa
sl@0:     set b bbb
sl@0:     x eval {after cancel set a a-after}
sl@0:     update idletasks
sl@0:     lappend result $a $b [x eval {list $a $b}]
sl@0:     interp delete x
sl@0:     set result
sl@0: } {2 0 aaa bbb {before b-after}}
sl@0: test timer-6.16 {Tcl_AfterCmd procedure, idle option} {
sl@0:     list [catch {after idle} msg] $msg
sl@0: } {1 {wrong # args: should be "after idle script script ..."}}
sl@0: test timer-6.17 {Tcl_AfterCmd procedure, idle option} {
sl@0:     set x before
sl@0:     after idle {set x after}
sl@0:     set y $x
sl@0:     update idletasks
sl@0:     list $y $x
sl@0: } {before after}
sl@0: test timer-6.18 {Tcl_AfterCmd procedure, idle option} {
sl@0:     set x before
sl@0:     after idle set x after
sl@0:     set y $x
sl@0:     update idletasks
sl@0:     list $y $x
sl@0: } {before after}
sl@0: set event1 [after idle event 1]
sl@0: set event2 [after 1000 event 2]
sl@0: interp create x
sl@0: set childEvent [x eval {after idle event in child}]
sl@0: test timer-6.19 {Tcl_AfterCmd, info option} {
sl@0:     lsort [after info]
sl@0: } [lsort "$event1 $event2"]
sl@0: test timer-6.20 {Tcl_AfterCmd, info option} {
sl@0:     list [catch {after info a b} msg] $msg
sl@0: } {1 {wrong # args: should be "after info ?id?"}}
sl@0: test timer-6.21 {Tcl_AfterCmd, info option} {
sl@0:     list [catch {after info $childEvent} msg] $msg
sl@0: } "1 {event \"$childEvent\" doesn't exist}"
sl@0: test timer-6.22 {Tcl_AfterCmd, info option} {
sl@0:     list [after info $event1] [after info $event2]
sl@0: } {{{event 1} idle} {{event 2} timer}}
sl@0: 
sl@0: after cancel $event1
sl@0: after cancel $event2
sl@0: interp delete x
sl@0: 
sl@0: test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NULL} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x "hello world"
sl@0:     after 1 "set x ab\0cd"
sl@0:     after 10
sl@0:     update
sl@0:     string length $x
sl@0: } {5}
sl@0: test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NULL} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x "hello world"
sl@0:     after 1 set x ab\0cd
sl@0:     after 10
sl@0:     update
sl@0:     string length $x
sl@0: } {5}
sl@0: test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x "hello world"
sl@0:     after 1 set x ab\0cd
sl@0:     after cancel "set x ab\0ef"
sl@0:     set x [llength [after info]]
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x
sl@0: } {1}
sl@0: test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x "hello world"
sl@0:     after 1 set x ab\0cd
sl@0:     after cancel set x ab\0ef
sl@0:     set y [llength [after info]]
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set y
sl@0: } {1}
sl@0: test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x "hello world"
sl@0:     after idle "set x ab\0cd"
sl@0:     update
sl@0:     string length $x
sl@0: } {5}
sl@0: test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NULL} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x "hello world"
sl@0:     after idle set x ab\0cd
sl@0:     update
sl@0:     string length $x
sl@0: } {5}
sl@0: test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set x "hello world"
sl@0:     set id junk
sl@0:     set id [after 10 set x ab\0cd]
sl@0:     update
sl@0:     set y [string length [lindex [lindex [after info $id] 0] 2]]
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     set y
sl@0: } {5}
sl@0: 
sl@0: set event [after idle foo bar]
sl@0: scan $event after#%d id
sl@0: 
sl@0: test timer-7.1 {GetAfterEvent procedure} {
sl@0:     list [catch {after info xfter#$id} msg] $msg
sl@0: } "1 {event \"xfter#$id\" doesn't exist}"
sl@0: test timer-7.2 {GetAfterEvent procedure} {
sl@0:     list [catch {after info afterx$id} msg] $msg
sl@0: } "1 {event \"afterx$id\" doesn't exist}"
sl@0: test timer-7.3 {GetAfterEvent procedure} {
sl@0:     list [catch {after info after#ab} msg] $msg
sl@0: } {1 {event "after#ab" doesn't exist}}
sl@0: test timer-7.4 {GetAfterEvent procedure} {
sl@0:     list [catch {after info after#} msg] $msg
sl@0: } {1 {event "after#" doesn't exist}}
sl@0: test timer-7.5 {GetAfterEvent procedure} {
sl@0:     list [catch {after info after#${id}x} msg] $msg
sl@0: } "1 {event \"after#${id}x\" doesn't exist}"
sl@0: test timer-7.6 {GetAfterEvent procedure} {
sl@0:     list [catch {after info afterx[expr $id+1]} msg] $msg
sl@0: } "1 {event \"afterx[expr $id+1]\" doesn't exist}"
sl@0: after cancel $event
sl@0: 
sl@0: test timer-8.1 {AfterProc procedure} {
sl@0:     set x before
sl@0:     proc foo {} {
sl@0: 	set x untouched
sl@0: 	after 100 {set x after}
sl@0: 	after 200
sl@0: 	update
sl@0: 	return $x
sl@0:     }
sl@0:     list [foo] $x
sl@0: } {untouched after}
sl@0: test timer-8.2 {AfterProc procedure} {
sl@0:     catch {rename bgerror {}}
sl@0:     proc bgerror msg {
sl@0: 	global x errorInfo
sl@0: 	set x [list $msg $errorInfo]
sl@0:     }
sl@0:     set x empty
sl@0:     after 100 {error "After error"}
sl@0:     after 200
sl@0:     set y $x
sl@0:     update
sl@0:     catch {rename bgerror {}}
sl@0:     list $y $x
sl@0: } {empty {{After error} {After error
sl@0:     while executing
sl@0: "error "After error""
sl@0:     ("after" script)}}}
sl@0: test timer-8.3 {AfterProc procedure, deleting handler from itself} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     proc foo {} {
sl@0: 	global x
sl@0: 	set x {}
sl@0: 	foreach i [after info] {
sl@0: 	    lappend x [after info $i]
sl@0: 	}
sl@0: 	after cancel foo
sl@0:     }
sl@0:     after idle foo
sl@0:     after 1000 {error "I shouldn't ever have executed"}
sl@0:     update idletasks
sl@0:     set x
sl@0: } {{{error "I shouldn't ever have executed"} timer}}
sl@0: test timer-8.4 {AfterProc procedure, deleting handler from itself} {
sl@0:     foreach i [after info] {
sl@0: 	after cancel $i
sl@0:     }
sl@0:     proc foo {} {
sl@0: 	global x
sl@0: 	set x {}
sl@0: 	foreach i [after info] {
sl@0: 	    lappend x [after info $i]
sl@0: 	}
sl@0: 	after cancel foo
sl@0:     }
sl@0:     after 1000 {error "I shouldn't ever have executed"}
sl@0:     after idle foo
sl@0:     update idletasks
sl@0:     set x
sl@0: } {{{error "I shouldn't ever have executed"} timer}}
sl@0: 
sl@0: foreach i [after info] {
sl@0:     after cancel $i
sl@0: }
sl@0: 
sl@0: # No test for FreeAfterPtr, since it is already tested above.
sl@0: 
sl@0: 
sl@0: test timer-9.1 {AfterCleanupProc procedure} {
sl@0:     catch {interp delete x}
sl@0:     interp create x
sl@0:     x eval {after 200 {
sl@0: 	lappend x after
sl@0: 	puts "part 1: this message should not appear"
sl@0:     }}
sl@0:     after 200 {lappend x after2}
sl@0:     x eval {after 200 {
sl@0: 	lappend x after3
sl@0: 	puts "part 2: this message should not appear"
sl@0:     }}
sl@0:     after 200 {lappend x after4}
sl@0:     x eval {after 200 {
sl@0: 	lappend x after5
sl@0: 	puts "part 3: this message should not appear"
sl@0:     }}
sl@0:     interp delete x
sl@0:     set x before
sl@0:     after 300
sl@0:     update
sl@0:     set x
sl@0: } {before after2 after4}
sl@0: test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
sl@0:     interp create slave
sl@0:     slave eval namespace export after
sl@0:     slave eval namespace eval foo namespace import ::after
sl@0: } -body {
sl@0:     slave eval foo::after 1
sl@0:     slave eval namespace origin foo::after
sl@0: } -cleanup {
sl@0:     # Bug will cause crash here; would cause failure otherwise
sl@0:     interp delete slave
sl@0: } -result ::after
sl@0: 
sl@0: test timer-11.2 {Bug 1350293: [after] negative argument} \
sl@0:     -body {
sl@0: 	set l {}
sl@0: 	after 100 {lappend l 100; set done 1}
sl@0: 	after -1 {lappend l -1}
sl@0: 	vwait done
sl@0: 	set l
sl@0:     } \
sl@0:     -result {-1 100}
sl@0: 
sl@0: # cleanup
sl@0: ::tcltest::cleanupTests
sl@0: return