1 # This file contains a collection of tests for the procedures in the
2 # file tclTimer.c, which includes the "after" Tcl command. Sourcing
3 # this file into Tcl runs the tests and generates output for errors.
4 # No output means no errors were found.
6 # This file contains a collection of tests for one or more of the Tcl
7 # built-in commands. Sourcing this file into Tcl runs the tests and
8 # generates output for errors. No output means no errors were found.
10 # Copyright (c) 1997 by Sun Microsystems, Inc.
11 # Copyright (c) 1998-1999 by Scriptics Corporation.
13 # See the file "license.terms" for information on usage and redistribution
14 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16 if {"::tcltest" ni [namespace children]} {
17 package require tcltest 2.5
18 namespace import -force ::tcltest::*
21 test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup {
22 foreach i [after info] {
27 foreach i {100 200 1000 50 150} {
34 foreach i [after info] {
37 } -result {50 100 150 200}
39 test timer-2.1 {Tcl_DeleteTimerHandler procedure} -setup {
40 foreach i [after info] {
45 foreach i {100 200 1000 50 150} {
48 after cancel lappend x 150
49 after cancel lappend x 50
55 # No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested
58 test timer-3.1 {TimerHandlerEventProc procedure: event masks} {
60 after 100 { set x fired }
67 test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} -setup {
68 foreach i [after info] {
72 foreach i {200 600 1000} {
86 } -result {200 {200 600} {200 600 1000}}
87 test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} -setup {
88 foreach i [after info] {
93 after 100 lappend x 100
94 set i [after 300 lappend x 300]
95 after 200 after cancel $i
100 test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} -setup {
101 foreach i [after info] {
106 after 100 lappend x a
107 after 200 lappend x b
108 after 300 lappend x c
113 test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} -setup {
114 foreach i [after info] {
119 after 100 {lappend x a; after 0 lappend x b}
124 test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} -setup {
125 foreach i [after info] {
130 after 100 {lappend x a; after 100 lappend x b; after 100}
138 # No tests for Tcl_DoWhenIdle: it's already tested by other tests
141 test timer-4.1 {Tcl_CancelIdleCall procedure} -setup {
142 foreach i [after info] {
149 after idle set x after1
150 after idle set y after2
151 after idle set z after3
152 after cancel set y after2
155 } -result {after1 before after3}
156 test timer-4.2 {Tcl_CancelIdleCall procedure} -setup {
157 foreach i [after info] {
164 after idle set x after1
165 after idle set y after2
166 after idle set z after3
167 after cancel set x after1
170 } -result {before after2 after3}
172 test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} -setup {
173 foreach i [after info] {
179 after idle {incr x; after idle {incr x; after idle {incr x}}}
187 test timer-6.1 {Tcl_AfterCmd procedure, basics} -returnCodes error -body {
189 } -result {wrong # args: should be "after option ?arg ...?"}
190 test timer-6.2 {Tcl_AfterCmd procedure, basics} -returnCodes error -body {
192 } -result {bad argument "2x": must be cancel, idle, info, or an integer}
193 test timer-6.3 {Tcl_AfterCmd procedure, basics} -returnCodes error -body {
195 } -result {bad argument "gorp": must be cancel, idle, info, or an integer}
196 test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
198 after 400 {set x after}
206 test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
208 after 400 set x after
216 test timer-6.6 {Tcl_AfterCmd procedure, cancel option} -body {
218 } -returnCodes error -result {wrong # args: should be "after cancel id|command"}
219 test timer-6.7 {Tcl_AfterCmd procedure, cancel option} {
222 test timer-6.8 {Tcl_AfterCmd procedure, cancel option} {
223 after cancel {foo bar}
225 test timer-6.9 {Tcl_AfterCmd procedure, cancel option} -setup {
226 foreach i [after info] {
231 set y [after 100 set x after]
237 test timer-6.10 {Tcl_AfterCmd procedure, cancel option} -setup {
238 foreach i [after info] {
243 after 100 set x after
244 after cancel {set x after}
249 test timer-6.11 {Tcl_AfterCmd procedure, cancel option} -setup {
250 foreach i [after info] {
255 after 100 set x after
256 set id [after 300 set x after]
265 } -result {after cleared}
266 test timer-6.12 {Tcl_AfterCmd procedure, cancel option} -setup {
267 foreach i [after info] {
272 after idle lappend x second
273 after idle lappend x third
274 set i [after idle lappend x fourth]
275 after cancel {lappend x second}
279 } -result {first third}
280 test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} -setup {
281 foreach i [after info] {
286 after idle lappend x second
287 after idle lappend x third
288 set i [after idle lappend x fourth]
289 after cancel lappend x second
293 } -result {first third}
294 test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} -setup {
295 foreach i [after info] {
307 test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} -setup {
308 foreach i [after info] {
313 x eval {set a before; set b before; after idle {set a a-after};
314 after idle {set b b-after}}
315 set result [llength [x eval after info]]
316 lappend result [llength [after info]]
317 after cancel {set b b-after}
320 x eval {after cancel set a a-after}
322 lappend result $a $b [x eval {list $a $b}]
325 } -result {2 0 aaa bbb {before b-after}}
326 test timer-6.16 {Tcl_AfterCmd procedure, idle option} -body {
328 } -returnCodes error -result {wrong # args: should be "after idle script ?script ...?"}
329 test timer-6.17 {Tcl_AfterCmd procedure, idle option} {
331 after idle {set x after}
336 test timer-6.18 {Tcl_AfterCmd procedure, idle option} {
338 after idle set x after
344 set event1 [after idle event 1]
345 set event2 [after 1000 event 2]
347 set childEvent [x eval {after idle event in child}]
348 test timer-6.19 {Tcl_AfterCmd, info option} {
350 } [lsort "$event1 $event2"]
351 test timer-6.20 {Tcl_AfterCmd, info option} -returnCodes error -body {
353 } -result {wrong # args: should be "after info ?id?"}
354 test timer-6.21 {Tcl_AfterCmd, info option} -returnCodes error -body {
355 after info $childEvent
356 } -result "event \"$childEvent\" doesn't exist"
357 test timer-6.22 {Tcl_AfterCmd, info option} {
358 list [after info $event1] [after info $event2]
359 } {{{event 1} idle} {{event 2} timer}}
364 test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NUL} -setup {
365 foreach i [after info] {
370 after 1 "set x ab\0cd"
375 test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NUL} -setup {
376 foreach i [after info] {
386 test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup {
387 foreach i [after info] {
393 after cancel "set x ab\0ef"
396 foreach i [after info] {
400 test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup {
401 foreach i [after info] {
407 after cancel set x ab\0ef
410 foreach i [after info] {
414 test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup {
415 foreach i [after info] {
420 after idle "set x ab\0cd"
424 test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup {
425 foreach i [after info] {
430 after idle set x ab\0cd
434 test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NUL} -setup {
435 foreach i [after info] {
441 set id [after 10 set x ab\0cd]
443 string length [lindex [lindex [after info $id] 0] 2]
445 foreach i [after info] {
450 set event [after idle foo bar]
451 scan $event after#%d lastId
452 test timer-7.1 {GetAfterEvent procedure} -returnCodes error -body {
453 after info xfter#$lastId
454 } -result "event \"xfter#$lastId\" doesn't exist"
455 test timer-7.2 {GetAfterEvent procedure} -returnCodes error -body {
456 after info afterx$lastId
457 } -result "event \"afterx$lastId\" doesn't exist"
458 test timer-7.3 {GetAfterEvent procedure} -returnCodes error -body {
460 } -result {event "after#ab" doesn't exist}
461 test timer-7.4 {GetAfterEvent procedure} -returnCodes error -body {
463 } -result {event "after#" doesn't exist}
464 test timer-7.5 {GetAfterEvent procedure} -returnCodes error -body {
465 after info after#${lastId}x
466 } -result "event \"after#${lastId}x\" doesn't exist"
467 test timer-7.6 {GetAfterEvent procedure} -returnCodes error -body {
468 after info afterx[expr {$lastId+1}]
469 } -result "event \"afterx[expr {$lastId+1}]\" doesn't exist"
472 test timer-8.1 {AfterProc procedure} {
476 after 100 {set x after}
483 test timer-8.2 {AfterProc procedure} -setup {
485 proc myHandler {msg options} {
486 variable x [list $msg [dict get $options -errorinfo]]
488 set handler [interp bgerror {}]
489 interp bgerror {} [namespace which myHandler]
491 after 100 {error "After error"}
497 interp bgerror {} $handler
498 } -result {empty {{After error} {After error
500 "error "After error""
502 test timer-8.3 {AfterProc procedure, deleting handler from itself} -setup {
503 foreach i [after info] {
510 foreach i [after info] {
511 lappend x [after info $i]
516 after 1000 {error "I shouldn't ever have executed"}
519 } -result {{{error "I shouldn't ever have executed"} timer}}
520 test timer-8.4 {AfterProc procedure, deleting handler from itself} -setup {
521 foreach i [after info] {
528 foreach i [after info] {
529 lappend x [after info $i]
533 after 1000 {error "I shouldn't ever have executed"}
537 } -result {{{error "I shouldn't ever have executed"} timer}}
539 foreach i [after info] {
543 # No test for FreeAfterPtr, since it is already tested above.
545 test timer-9.1 {AfterCleanupProc procedure} -setup {
546 catch {interp delete x}
551 puts "part 1: this message should not appear"
553 after 200 {lappend x after2}
556 puts "part 2: this message should not appear"
558 after 200 {lappend x after4}
561 puts "part 3: this message should not appear"
568 } -result {before after2 after4}
570 test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
572 child eval namespace export after
573 child eval namespace eval foo namespace import ::after
575 child eval foo::after 1
576 child eval namespace origin foo::after
578 # Bug will cause crash here; would cause failure otherwise
582 test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body {
584 set a [after 0x100000001 {set b "after fired early"}]
589 catch {after cancel $a}
591 test timer-11.2 {Bug 1350293: [after] negative argument} -body {
593 after 100 {lappend l 100; set done 1}
594 after -1 {lappend l -1}
600 ::tcltest::cleanupTests