# 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