X-Git-Url: http://git.osdn.net/view?a=blobdiff_plain;f=tcl%2Ftests%2Ftimer.test;fp=tcl%2Ftests%2Ftimer.test;h=ac7429f1ce8125e245a5ae6c1e7bfc6d378109a6;hb=ae4bf010374a9320497af260fa90af3fe8e2c5a5;hp=0000000000000000000000000000000000000000;hpb=3cc729069938336ea54d399c4bbbe7d197295f9a;p=pf3gnuchains%2Fpf3gnuchains3x.git

diff --git a/tcl/tests/timer.test b/tcl/tests/timer.test
new file mode 100644
index 0000000000..ac7429f1ce
--- /dev/null
+++ b/tcl/tests/timer.test
@@ -0,0 +1,555 @@
+# 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$
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest
+    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}
+
+# cleanup
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+