# 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
    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} {
    clean-up-events
    set x ""
    foreach i {100 200 1000 50 150} {
	after $i lappend x $i
    }
    tl-vwait 200 done
    set x
} {50 100 150 200}

test timer-2.1 {Tcl_DeleteTimerHandler procedure} {
    clean-up-events
    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
    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} {
    clean-up-events
    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
} {200 {200 600} {200 600 1000}}
test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} {
    clean-up-events
    set x {}
    after 100 lappend x 100
    set i [after 300 lappend x 300]
    after 200 after cancel $i
    tl-after 400
    update
    set x
} 100
test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} {
    clean-up-events
    set x {}
    after 100 lappend x a
    after 200 lappend x b
    after 300 lappend x c
    tl-after 300
    vwait x
    set x
} {a b c}
test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
    clean-up-events
    set x {}
    after 10 {lappend x a; after 0 lappend x b}
    after 50
    vwait x
    set x
} a
test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
    clean-up-events
    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
} {a {a b}}

# No tests for Tcl_DoWhenIdle:  it's already tested by other tests
# below.

test timer-4.1 {Tcl_CancelIdleCall procedure} {
    clean-up-events
    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} {
    clean-up-events
    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} {
    clean-up-events
    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 {bad argument "2x": must be cancel, idle, info, or an integer}}
test timer-6.3 {Tcl_AfterCmd procedure, basics} {
    list [catch {after gorp} msg] $msg
} {1 {bad argument "gorp": must be cancel, idle, info, or an integer}}
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} {
    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} {
    clean-up-events
    set x before
    set y [after 10 set x after]
    after cancel $y
    after 100
    update
    set x
} {before}
test timer-6.10 {Tcl_AfterCmd procedure, cancel option} {
    clean-up-events
    set x before
    after 10 set x after
    after cancel {set x after}
    after 100
    update
    set x
} {before}
test timer-6.11 {Tcl_AfterCmd procedure, cancel option} {
    clean-up-events
    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
} {after-10 cleared}
test timer-6.12 {Tcl_AfterCmd procedure, cancel option} {
    clean-up-events
    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} {
    clean-up-events
    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} {
    clean-up-events
    set id [
	after 10 {
	    set x done
	    after cancel $id
	    after idle {set y done}
	}
    ]
    list [tl-vwait 1000 x] [tl-vwait 100 y]
} {1 1}
test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} {
    clean-up-events
    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.19.1 {Tcl_AfterCmd, info option (all events in child)} {
    x eval {after info}
} [list $childEvent]
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.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 NULL} {
    clean-up-events
    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} {
    clean-up-events
    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} {
    clean-up-events
    set x "hello world"
    after 1 set x ab\0cd
    after cancel "set x ab\0ef"
    set x [llength [after info]]
    clean-up-events
    set x
} {1}
test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
    clean-up-events
    set x "hello world"
    after 1 set x ab\0cd
    after cancel set x ab\0ef
    set y [llength [after info]]
    clean-up-events
    set y
} {1}
test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} {
    clean-up-events
    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} {
    clean-up-events
    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} {
    clean-up-events
    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]]
    clean-up-events
    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 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} {
    clean-up-events
    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
    set x
} {{{error "I shouldn't ever have executed"} timer}}
test timer-8.4 {AfterProc procedure, deleting handler from itself} {
    clean-up-events
    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
} [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} {
    catch {interp delete x}
    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
    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.1 {Bug 1350291: [after] overflowing 32-bit field} \
    -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 {
    	clean-up-events
	set l {}
	after 100 {lappend l 100; set done 1}
	after -1 {lappend l -1}
	vwait done
	set l
    } \
    -result {-1 100}

test timer-11.3 {[after] correct timer ordering (insert ahead)} \
    -body {
    	clean-up-events
	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}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# End: