# 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.7.22.2 2005/11/09 21:46:20 kennykb 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