os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/timer.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/timer.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,564 @@
1.4 +# This file contains a collection of tests for the procedures in the
1.5 +# file tclTimer.c, which includes the "after" Tcl command. Sourcing
1.6 +# this file into Tcl runs the tests and generates output for errors.
1.7 +# No output means no errors were found.
1.8 +#
1.9 +# This file contains a collection of tests for one or more of the Tcl
1.10 +# built-in commands. Sourcing this file into Tcl runs the tests and
1.11 +# generates output for errors. No output means no errors were found.
1.12 +#
1.13 +# Copyright (c) 1997 by Sun Microsystems, Inc.
1.14 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.15 +#
1.16 +# See the file "license.terms" for information on usage and redistribution
1.17 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.18 +#
1.19 +# RCS: @(#) $Id: timer.test,v 1.7.22.2 2005/11/09 21:46:20 kennykb Exp $
1.20 +
1.21 +if {[lsearch [namespace children] ::tcltest] == -1} {
1.22 + package require tcltest 2
1.23 + namespace import -force ::tcltest::*
1.24 +}
1.25 +
1.26 +test timer-1.1 {Tcl_CreateTimerHandler procedure} {
1.27 + foreach i [after info] {
1.28 + after cancel $i
1.29 + }
1.30 + set x ""
1.31 + foreach i {100 200 1000 50 150} {
1.32 + after $i lappend x $i
1.33 + }
1.34 + after 200
1.35 + update
1.36 + set x
1.37 +} {50 100 150 200}
1.38 +
1.39 +test timer-2.1 {Tcl_DeleteTimerHandler procedure} {
1.40 + foreach i [after info] {
1.41 + after cancel $i
1.42 + }
1.43 + set x ""
1.44 + foreach i {100 200 300 50 150} {
1.45 + after $i lappend x $i
1.46 + }
1.47 + after cancel lappend x 150
1.48 + after cancel lappend x 50
1.49 + after 200
1.50 + update
1.51 + set x
1.52 +} {100 200}
1.53 +
1.54 +# No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested
1.55 +# above.
1.56 +
1.57 +test timer-3.1 {TimerHandlerEventProc procedure: event masks} {
1.58 + set x start
1.59 + after 100 { set x fired }
1.60 + update idletasks
1.61 + set result $x
1.62 + after 200
1.63 + update
1.64 + lappend result $x
1.65 +} {start fired}
1.66 +test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} {
1.67 + foreach i [after info] {
1.68 + after cancel $i
1.69 + }
1.70 + foreach i {200 600 1000} {
1.71 + after $i lappend x $i
1.72 + }
1.73 + after 200
1.74 + set result ""
1.75 + set x ""
1.76 + update
1.77 + lappend result $x
1.78 + after 400
1.79 + update
1.80 + lappend result $x
1.81 + after 400
1.82 + update
1.83 + lappend result $x
1.84 +} {200 {200 600} {200 600 1000}}
1.85 +test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} {
1.86 + foreach i [after info] {
1.87 + after cancel $i
1.88 + }
1.89 + set x {}
1.90 + after 100 lappend x 100
1.91 + set i [after 300 lappend x 300]
1.92 + after 200 after cancel $i
1.93 + after 400
1.94 + update
1.95 + set x
1.96 +} 100
1.97 +test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} {
1.98 + foreach i [after info] {
1.99 + after cancel $i
1.100 + }
1.101 + set x {}
1.102 + after 100 lappend x a
1.103 + after 200 lappend x b
1.104 + after 300 lappend x c
1.105 + after 300
1.106 + vwait x
1.107 + set x
1.108 +} {a b c}
1.109 +test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
1.110 + foreach i [after info] {
1.111 + after cancel $i
1.112 + }
1.113 + set x {}
1.114 + after 100 {lappend x a; after 0 lappend x b}
1.115 + after 100
1.116 + vwait x
1.117 + set x
1.118 +} a
1.119 +test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} {
1.120 + foreach i [after info] {
1.121 + after cancel $i
1.122 + }
1.123 + set x {}
1.124 + after 100 {lappend x a; after 100 lappend x b; after 100}
1.125 + after 100
1.126 + vwait x
1.127 + set result $x
1.128 + vwait x
1.129 + lappend result $x
1.130 +} {a {a b}}
1.131 +
1.132 +# No tests for Tcl_DoWhenIdle: it's already tested by other tests
1.133 +# below.
1.134 +
1.135 +test timer-4.1 {Tcl_CancelIdleCall procedure} {
1.136 + foreach i [after info] {
1.137 + after cancel $i
1.138 + }
1.139 + set x before
1.140 + set y before
1.141 + set z before
1.142 + after idle set x after1
1.143 + after idle set y after2
1.144 + after idle set z after3
1.145 + after cancel set y after2
1.146 + update idletasks
1.147 + concat $x $y $z
1.148 +} {after1 before after3}
1.149 +test timer-4.2 {Tcl_CancelIdleCall procedure} {
1.150 + foreach i [after info] {
1.151 + after cancel $i
1.152 + }
1.153 + set x before
1.154 + set y before
1.155 + set z before
1.156 + after idle set x after1
1.157 + after idle set y after2
1.158 + after idle set z after3
1.159 + after cancel set x after1
1.160 + update idletasks
1.161 + concat $x $y $z
1.162 +} {before after2 after3}
1.163 +
1.164 +test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} {
1.165 + foreach i [after info] {
1.166 + after cancel $i
1.167 + }
1.168 + set x 1
1.169 + set y 23
1.170 + after idle {incr x; after idle {incr x; after idle {incr x}}}
1.171 + after idle {incr y}
1.172 + vwait x
1.173 + set result "$x $y"
1.174 + update idletasks
1.175 + lappend result $x
1.176 +} {2 24 4}
1.177 +
1.178 +test timer-6.1 {Tcl_AfterCmd procedure, basics} {
1.179 + list [catch {after} msg] $msg
1.180 +} {1 {wrong # args: should be "after option ?arg arg ...?"}}
1.181 +test timer-6.2 {Tcl_AfterCmd procedure, basics} {
1.182 + list [catch {after 2x} msg] $msg
1.183 +} {1 {expected integer but got "2x"}}
1.184 +test timer-6.3 {Tcl_AfterCmd procedure, basics} {
1.185 + list [catch {after gorp} msg] $msg
1.186 +} {1 {bad argument "gorp": must be cancel, idle, info, or a number}}
1.187 +test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
1.188 + set x before
1.189 + after 400 {set x after}
1.190 + after 200
1.191 + update
1.192 + set y $x
1.193 + after 400
1.194 + update
1.195 + list $y $x
1.196 +} {before after}
1.197 +test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
1.198 + set x before
1.199 + after 300 set x after
1.200 + after 200
1.201 + update
1.202 + set y $x
1.203 + after 200
1.204 + update
1.205 + list $y $x
1.206 +} {before after}
1.207 +test timer-6.6 {Tcl_AfterCmd procedure, cancel option} {
1.208 + list [catch {after cancel} msg] $msg
1.209 +} {1 {wrong # args: should be "after cancel id|command"}}
1.210 +test timer-6.7 {Tcl_AfterCmd procedure, cancel option} {
1.211 + after cancel after#1
1.212 +} {}
1.213 +test timer-6.8 {Tcl_AfterCmd procedure, cancel option} {
1.214 + after cancel {foo bar}
1.215 +} {}
1.216 +test timer-6.9 {Tcl_AfterCmd procedure, cancel option} {
1.217 + foreach i [after info] {
1.218 + after cancel $i
1.219 + }
1.220 + set x before
1.221 + set y [after 100 set x after]
1.222 + after cancel $y
1.223 + after 200
1.224 + update
1.225 + set x
1.226 +} {before}
1.227 +test timer-6.10 {Tcl_AfterCmd procedure, cancel option} {
1.228 + foreach i [after info] {
1.229 + after cancel $i
1.230 + }
1.231 + set x before
1.232 + after 100 set x after
1.233 + after cancel {set x after}
1.234 + after 200
1.235 + update
1.236 + set x
1.237 +} {before}
1.238 +test timer-6.11 {Tcl_AfterCmd procedure, cancel option} {
1.239 + foreach i [after info] {
1.240 + after cancel $i
1.241 + }
1.242 + set x before
1.243 + after 100 set x after
1.244 + set id [after 300 set x after]
1.245 + after cancel $id
1.246 + after 200
1.247 + update
1.248 + set y $x
1.249 + set x cleared
1.250 + after 200
1.251 + update
1.252 + list $y $x
1.253 +} {after cleared}
1.254 +test timer-6.12 {Tcl_AfterCmd procedure, cancel option} {
1.255 + foreach i [after info] {
1.256 + after cancel $i
1.257 + }
1.258 + set x first
1.259 + after idle lappend x second
1.260 + after idle lappend x third
1.261 + set i [after idle lappend x fourth]
1.262 + after cancel {lappend x second}
1.263 + after cancel $i
1.264 + update idletasks
1.265 + set x
1.266 +} {first third}
1.267 +test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} {
1.268 + foreach i [after info] {
1.269 + after cancel $i
1.270 + }
1.271 + set x first
1.272 + after idle lappend x second
1.273 + after idle lappend x third
1.274 + set i [after idle lappend x fourth]
1.275 + after cancel lappend x second
1.276 + after cancel $i
1.277 + update idletasks
1.278 + set x
1.279 +} {first third}
1.280 +test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} {
1.281 + foreach i [after info] {
1.282 + after cancel $i
1.283 + }
1.284 + set id [
1.285 + after 100 {
1.286 + set x done
1.287 + after cancel $id
1.288 + }
1.289 + ]
1.290 + vwait x
1.291 +} {}
1.292 +test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} {
1.293 + foreach i [after info] {
1.294 + after cancel $i
1.295 + }
1.296 + interp create x
1.297 + x eval {set a before; set b before; after idle {set a a-after};
1.298 + after idle {set b b-after}}
1.299 + set result [llength [x eval after info]]
1.300 + lappend result [llength [after info]]
1.301 + after cancel {set b b-after}
1.302 + set a aaa
1.303 + set b bbb
1.304 + x eval {after cancel set a a-after}
1.305 + update idletasks
1.306 + lappend result $a $b [x eval {list $a $b}]
1.307 + interp delete x
1.308 + set result
1.309 +} {2 0 aaa bbb {before b-after}}
1.310 +test timer-6.16 {Tcl_AfterCmd procedure, idle option} {
1.311 + list [catch {after idle} msg] $msg
1.312 +} {1 {wrong # args: should be "after idle script script ..."}}
1.313 +test timer-6.17 {Tcl_AfterCmd procedure, idle option} {
1.314 + set x before
1.315 + after idle {set x after}
1.316 + set y $x
1.317 + update idletasks
1.318 + list $y $x
1.319 +} {before after}
1.320 +test timer-6.18 {Tcl_AfterCmd procedure, idle option} {
1.321 + set x before
1.322 + after idle set x after
1.323 + set y $x
1.324 + update idletasks
1.325 + list $y $x
1.326 +} {before after}
1.327 +set event1 [after idle event 1]
1.328 +set event2 [after 1000 event 2]
1.329 +interp create x
1.330 +set childEvent [x eval {after idle event in child}]
1.331 +test timer-6.19 {Tcl_AfterCmd, info option} {
1.332 + lsort [after info]
1.333 +} [lsort "$event1 $event2"]
1.334 +test timer-6.20 {Tcl_AfterCmd, info option} {
1.335 + list [catch {after info a b} msg] $msg
1.336 +} {1 {wrong # args: should be "after info ?id?"}}
1.337 +test timer-6.21 {Tcl_AfterCmd, info option} {
1.338 + list [catch {after info $childEvent} msg] $msg
1.339 +} "1 {event \"$childEvent\" doesn't exist}"
1.340 +test timer-6.22 {Tcl_AfterCmd, info option} {
1.341 + list [after info $event1] [after info $event2]
1.342 +} {{{event 1} idle} {{event 2} timer}}
1.343 +
1.344 +after cancel $event1
1.345 +after cancel $event2
1.346 +interp delete x
1.347 +
1.348 +test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NULL} {
1.349 + foreach i [after info] {
1.350 + after cancel $i
1.351 + }
1.352 + set x "hello world"
1.353 + after 1 "set x ab\0cd"
1.354 + after 10
1.355 + update
1.356 + string length $x
1.357 +} {5}
1.358 +test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NULL} {
1.359 + foreach i [after info] {
1.360 + after cancel $i
1.361 + }
1.362 + set x "hello world"
1.363 + after 1 set x ab\0cd
1.364 + after 10
1.365 + update
1.366 + string length $x
1.367 +} {5}
1.368 +test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
1.369 + foreach i [after info] {
1.370 + after cancel $i
1.371 + }
1.372 + set x "hello world"
1.373 + after 1 set x ab\0cd
1.374 + after cancel "set x ab\0ef"
1.375 + set x [llength [after info]]
1.376 + foreach i [after info] {
1.377 + after cancel $i
1.378 + }
1.379 + set x
1.380 +} {1}
1.381 +test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} {
1.382 + foreach i [after info] {
1.383 + after cancel $i
1.384 + }
1.385 + set x "hello world"
1.386 + after 1 set x ab\0cd
1.387 + after cancel set x ab\0ef
1.388 + set y [llength [after info]]
1.389 + foreach i [after info] {
1.390 + after cancel $i
1.391 + }
1.392 + set y
1.393 +} {1}
1.394 +test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} {
1.395 + foreach i [after info] {
1.396 + after cancel $i
1.397 + }
1.398 + set x "hello world"
1.399 + after idle "set x ab\0cd"
1.400 + update
1.401 + string length $x
1.402 +} {5}
1.403 +test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NULL} {
1.404 + foreach i [after info] {
1.405 + after cancel $i
1.406 + }
1.407 + set x "hello world"
1.408 + after idle set x ab\0cd
1.409 + update
1.410 + string length $x
1.411 +} {5}
1.412 +test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} {
1.413 + foreach i [after info] {
1.414 + after cancel $i
1.415 + }
1.416 + set x "hello world"
1.417 + set id junk
1.418 + set id [after 10 set x ab\0cd]
1.419 + update
1.420 + set y [string length [lindex [lindex [after info $id] 0] 2]]
1.421 + foreach i [after info] {
1.422 + after cancel $i
1.423 + }
1.424 + set y
1.425 +} {5}
1.426 +
1.427 +set event [after idle foo bar]
1.428 +scan $event after#%d id
1.429 +
1.430 +test timer-7.1 {GetAfterEvent procedure} {
1.431 + list [catch {after info xfter#$id} msg] $msg
1.432 +} "1 {event \"xfter#$id\" doesn't exist}"
1.433 +test timer-7.2 {GetAfterEvent procedure} {
1.434 + list [catch {after info afterx$id} msg] $msg
1.435 +} "1 {event \"afterx$id\" doesn't exist}"
1.436 +test timer-7.3 {GetAfterEvent procedure} {
1.437 + list [catch {after info after#ab} msg] $msg
1.438 +} {1 {event "after#ab" doesn't exist}}
1.439 +test timer-7.4 {GetAfterEvent procedure} {
1.440 + list [catch {after info after#} msg] $msg
1.441 +} {1 {event "after#" doesn't exist}}
1.442 +test timer-7.5 {GetAfterEvent procedure} {
1.443 + list [catch {after info after#${id}x} msg] $msg
1.444 +} "1 {event \"after#${id}x\" doesn't exist}"
1.445 +test timer-7.6 {GetAfterEvent procedure} {
1.446 + list [catch {after info afterx[expr $id+1]} msg] $msg
1.447 +} "1 {event \"afterx[expr $id+1]\" doesn't exist}"
1.448 +after cancel $event
1.449 +
1.450 +test timer-8.1 {AfterProc procedure} {
1.451 + set x before
1.452 + proc foo {} {
1.453 + set x untouched
1.454 + after 100 {set x after}
1.455 + after 200
1.456 + update
1.457 + return $x
1.458 + }
1.459 + list [foo] $x
1.460 +} {untouched after}
1.461 +test timer-8.2 {AfterProc procedure} {
1.462 + catch {rename bgerror {}}
1.463 + proc bgerror msg {
1.464 + global x errorInfo
1.465 + set x [list $msg $errorInfo]
1.466 + }
1.467 + set x empty
1.468 + after 100 {error "After error"}
1.469 + after 200
1.470 + set y $x
1.471 + update
1.472 + catch {rename bgerror {}}
1.473 + list $y $x
1.474 +} {empty {{After error} {After error
1.475 + while executing
1.476 +"error "After error""
1.477 + ("after" script)}}}
1.478 +test timer-8.3 {AfterProc procedure, deleting handler from itself} {
1.479 + foreach i [after info] {
1.480 + after cancel $i
1.481 + }
1.482 + proc foo {} {
1.483 + global x
1.484 + set x {}
1.485 + foreach i [after info] {
1.486 + lappend x [after info $i]
1.487 + }
1.488 + after cancel foo
1.489 + }
1.490 + after idle foo
1.491 + after 1000 {error "I shouldn't ever have executed"}
1.492 + update idletasks
1.493 + set x
1.494 +} {{{error "I shouldn't ever have executed"} timer}}
1.495 +test timer-8.4 {AfterProc procedure, deleting handler from itself} {
1.496 + foreach i [after info] {
1.497 + after cancel $i
1.498 + }
1.499 + proc foo {} {
1.500 + global x
1.501 + set x {}
1.502 + foreach i [after info] {
1.503 + lappend x [after info $i]
1.504 + }
1.505 + after cancel foo
1.506 + }
1.507 + after 1000 {error "I shouldn't ever have executed"}
1.508 + after idle foo
1.509 + update idletasks
1.510 + set x
1.511 +} {{{error "I shouldn't ever have executed"} timer}}
1.512 +
1.513 +foreach i [after info] {
1.514 + after cancel $i
1.515 +}
1.516 +
1.517 +# No test for FreeAfterPtr, since it is already tested above.
1.518 +
1.519 +
1.520 +test timer-9.1 {AfterCleanupProc procedure} {
1.521 + catch {interp delete x}
1.522 + interp create x
1.523 + x eval {after 200 {
1.524 + lappend x after
1.525 + puts "part 1: this message should not appear"
1.526 + }}
1.527 + after 200 {lappend x after2}
1.528 + x eval {after 200 {
1.529 + lappend x after3
1.530 + puts "part 2: this message should not appear"
1.531 + }}
1.532 + after 200 {lappend x after4}
1.533 + x eval {after 200 {
1.534 + lappend x after5
1.535 + puts "part 3: this message should not appear"
1.536 + }}
1.537 + interp delete x
1.538 + set x before
1.539 + after 300
1.540 + update
1.541 + set x
1.542 +} {before after2 after4}
1.543 +test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
1.544 + interp create slave
1.545 + slave eval namespace export after
1.546 + slave eval namespace eval foo namespace import ::after
1.547 +} -body {
1.548 + slave eval foo::after 1
1.549 + slave eval namespace origin foo::after
1.550 +} -cleanup {
1.551 + # Bug will cause crash here; would cause failure otherwise
1.552 + interp delete slave
1.553 +} -result ::after
1.554 +
1.555 +test timer-11.2 {Bug 1350293: [after] negative argument} \
1.556 + -body {
1.557 + set l {}
1.558 + after 100 {lappend l 100; set done 1}
1.559 + after -1 {lappend l -1}
1.560 + vwait done
1.561 + set l
1.562 + } \
1.563 + -result {-1 100}
1.564 +
1.565 +# cleanup
1.566 +::tcltest::cleanupTests
1.567 +return