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. 5# 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. 9# 10# Copyright © 1997 Sun Microsystems, Inc. 11# Copyright © 1998-1999 Scriptics Corporation. 12# 13# See the file "license.terms" for information on usage and redistribution 14# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 16if {"::tcltest" ni [namespace children]} { 17 package require tcltest 2.5 18 namespace import -force ::tcltest::* 19} 20 21test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup { 22 foreach i [after info] { 23 after cancel $i 24 } 25} -body { 26 set x "" 27 foreach i {100 200 1000 50 150} { 28 after $i lappend x $i 29 } 30 after 200 set done 1 31 vwait done 32 return $x 33} -cleanup { 34 foreach i [after info] { 35 after cancel $i 36 } 37} -result {50 100 150 200} 38 39test timer-2.1 {Tcl_DeleteTimerHandler procedure} -setup { 40 foreach i [after info] { 41 after cancel $i 42 } 43} -body { 44 set x "" 45 foreach i {100 200 1000 50 150} { 46 after $i lappend x $i 47 } 48 after cancel lappend x 150 49 after cancel lappend x 50 50 after 200 set done 1 51 vwait done 52 return $x 53} -result {100 200} 54 55# No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested 56# above. 57 58test timer-3.1 {TimerHandlerEventProc procedure: event masks} { 59 set x start 60 after 100 { set x fired } 61 update idletasks 62 set result $x 63 after 200 64 update 65 lappend result $x 66} {start fired} 67test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} -setup { 68 foreach i [after info] { 69 after cancel $i 70 } 71} -body { 72 foreach i {200 600 1000} { 73 after $i lappend x $i 74 } 75 after 200 76 set result "" 77 set x "" 78 update 79 lappend result $x 80 after 400 81 update 82 lappend result $x 83 after 400 84 update 85 lappend result $x 86} -result {200 {200 600} {200 600 1000}} 87test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} -setup { 88 foreach i [after info] { 89 after cancel $i 90 } 91} -body { 92 set x {} 93 after 100 lappend x 100 94 set i [after 300 lappend x 300] 95 after 200 after cancel $i 96 after 400 97 update 98 return $x 99} -result 100 100test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} -setup { 101 foreach i [after info] { 102 after cancel $i 103 } 104} -body { 105 set x {} 106 after 100 lappend x a 107 after 200 lappend x b 108 after 300 lappend x c 109 after 300 110 vwait x 111 return $x 112} -result {a b c} 113test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} -setup { 114 foreach i [after info] { 115 after cancel $i 116 } 117} -body { 118 set x {} 119 after 100 {lappend x a; after 0 lappend x b} 120 after 100 121 vwait x 122 return $x 123} -result a 124test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} -setup { 125 foreach i [after info] { 126 after cancel $i 127 } 128} -body { 129 set x {} 130 after 100 {lappend x a; after 100 lappend x b; after 100} 131 after 100 132 vwait x 133 set result $x 134 vwait x 135 lappend result $x 136} -result {a {a b}} 137 138# No tests for Tcl_DoWhenIdle: it's already tested by other tests 139# below. 140 141test timer-4.1 {Tcl_CancelIdleCall procedure} -setup { 142 foreach i [after info] { 143 after cancel $i 144 } 145} -body { 146 set x before 147 set y before 148 set z before 149 after idle set x after1 150 after idle set y after2 151 after idle set z after3 152 after cancel set y after2 153 update idletasks 154 list $x $y $z 155} -result {after1 before after3} 156test timer-4.2 {Tcl_CancelIdleCall procedure} -setup { 157 foreach i [after info] { 158 after cancel $i 159 } 160} -body { 161 set x before 162 set y before 163 set z before 164 after idle set x after1 165 after idle set y after2 166 after idle set z after3 167 after cancel set x after1 168 update idletasks 169 list $x $y $z 170} -result {before after2 after3} 171 172test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} -setup { 173 foreach i [after info] { 174 after cancel $i 175 } 176} -body { 177 set x 1 178 set y 23 179 after idle {incr x; after idle {incr x; after idle {incr x}}} 180 after idle {incr y} 181 vwait x 182 set result "$x $y" 183 update idletasks 184 lappend result $x 185} -result {2 24 4} 186 187test timer-6.1 {Tcl_AfterCmd procedure, basics} -returnCodes error -body { 188 after 189} -result {wrong # args: should be "after option ?arg ...?"} 190test timer-6.2 {Tcl_AfterCmd procedure, basics} -returnCodes error -body { 191 after 2x 192} -result {bad argument "2x": must be cancel, idle, info, or an integer} 193test timer-6.3 {Tcl_AfterCmd procedure, basics} -returnCodes error -body { 194 after gorp 195} -result {bad argument "gorp": must be cancel, idle, info, or an integer} 196test timer-6.4 {Tcl_AfterCmd procedure, ms argument} { 197 set x before 198 after 400 {set x after} 199 after 200 200 update 201 set y $x 202 after 400 203 update 204 list $y $x 205} {before after} 206test timer-6.5 {Tcl_AfterCmd procedure, ms argument} { 207 set x before 208 after 400 set x after 209 after 200 210 update 211 set y $x 212 after 400 213 update 214 list $y $x 215} {before after} 216test timer-6.6 {Tcl_AfterCmd procedure, cancel option} -body { 217 after cancel 218} -returnCodes error -result {wrong # args: should be "after cancel id|command"} 219test timer-6.7 {Tcl_AfterCmd procedure, cancel option} { 220 after cancel after#1 221} {} 222test timer-6.8 {Tcl_AfterCmd procedure, cancel option} { 223 after cancel {foo bar} 224} {} 225test timer-6.9 {Tcl_AfterCmd procedure, cancel option} -setup { 226 foreach i [after info] { 227 after cancel $i 228 } 229} -body { 230 set x before 231 set y [after 100 set x after] 232 after cancel $y 233 after 200 234 update 235 return $x 236} -result {before} 237test timer-6.10 {Tcl_AfterCmd procedure, cancel option} -setup { 238 foreach i [after info] { 239 after cancel $i 240 } 241} -body { 242 set x before 243 after 100 set x after 244 after cancel {set x after} 245 after 200 246 update 247 return $x 248} -result {before} 249test timer-6.11 {Tcl_AfterCmd procedure, cancel option} -setup { 250 foreach i [after info] { 251 after cancel $i 252 } 253} -body { 254 set x before 255 after 100 set x after 256 set id [after 300 set x after] 257 after cancel $id 258 after 200 259 update 260 set y $x 261 set x cleared 262 after 200 263 update 264 list $y $x 265} -result {after cleared} 266test timer-6.12 {Tcl_AfterCmd procedure, cancel option} -setup { 267 foreach i [after info] { 268 after cancel $i 269 } 270} -body { 271 set x first 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} 276 after cancel $i 277 update idletasks 278 return $x 279} -result {first third} 280test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} -setup { 281 foreach i [after info] { 282 after cancel $i 283 } 284} -body { 285 set x first 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 290 after cancel $i 291 update idletasks 292 return $x 293} -result {first third} 294test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} -setup { 295 foreach i [after info] { 296 after cancel $i 297 } 298} -body { 299 set id [ 300 after 100 { 301 set x done 302 after cancel $id 303 } 304 ] 305 vwait x 306} -result {} 307test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} -setup { 308 foreach i [after info] { 309 after cancel $i 310 } 311} -body { 312 interp create x 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} 318 set a aaa 319 set b bbb 320 x eval {after cancel set a a-after} 321 update idletasks 322 lappend result $a $b [x eval {list $a $b}] 323} -cleanup { 324 interp delete x 325} -result {2 0 aaa bbb {before b-after}} 326test timer-6.16 {Tcl_AfterCmd procedure, idle option} -body { 327 after idle 328} -returnCodes error -result {wrong # args: should be "after idle script ?script ...?"} 329test timer-6.17 {Tcl_AfterCmd procedure, idle option} { 330 set x before 331 after idle {set x after} 332 set y $x 333 update idletasks 334 list $y $x 335} {before after} 336test timer-6.18 {Tcl_AfterCmd procedure, idle option} { 337 set x before 338 after idle set x after 339 set y $x 340 update idletasks 341 list $y $x 342} {before after} 343 344set event1 [after idle event 1] 345set event2 [after 1000 event 2] 346interp create x 347set childEvent [x eval {after idle event in child}] 348test timer-6.19 {Tcl_AfterCmd, info option} { 349 lsort [after info] 350} [lsort "$event1 $event2"] 351test timer-6.20 {Tcl_AfterCmd, info option} -returnCodes error -body { 352 after info a b 353} -result {wrong # args: should be "after info ?id?"} 354test timer-6.21 {Tcl_AfterCmd, info option} -returnCodes error -body { 355 after info $childEvent 356} -result "event \"$childEvent\" doesn't exist" 357test timer-6.22 {Tcl_AfterCmd, info option} { 358 list [after info $event1] [after info $event2] 359} {{{event 1} idle} {{event 2} timer}} 360after cancel $event1 361after cancel $event2 362interp delete x 363 364test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NUL} -setup { 365 foreach i [after info] { 366 after cancel $i 367 } 368} -body { 369 set x "hello world" 370 after 1 "set x ab\x00cd" 371 after 10 372 update 373 string length $x 374} -result {5} 375test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NUL} -setup { 376 foreach i [after info] { 377 after cancel $i 378 } 379} -body { 380 set x "hello world" 381 after 1 set x ab\x00cd 382 after 10 383 update 384 string length $x 385} -result {5} 386test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup { 387 foreach i [after info] { 388 after cancel $i 389 } 390} -body { 391 set x "hello world" 392 after 1 set x ab\x00cd 393 after cancel "set x ab\x00ef" 394 llength [after info] 395} -cleanup { 396 foreach i [after info] { 397 after cancel $i 398 } 399} -result {1} 400test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup { 401 foreach i [after info] { 402 after cancel $i 403 } 404} -body { 405 set x "hello world" 406 after 1 set x ab\x00cd 407 after cancel set x ab\x00ef 408 llength [after info] 409} -cleanup { 410 foreach i [after info] { 411 after cancel $i 412 } 413} -result {1} 414test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup { 415 foreach i [after info] { 416 after cancel $i 417 } 418} -body { 419 set x "hello world" 420 after idle "set x ab\x00cd" 421 update 422 string length $x 423} -result {5} 424test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup { 425 foreach i [after info] { 426 after cancel $i 427 } 428} -body { 429 set x "hello world" 430 after idle set x ab\x00cd 431 update 432 string length $x 433} -result {5} 434test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NUL} -setup { 435 foreach i [after info] { 436 after cancel $i 437 } 438} -body { 439 set x "hello world" 440 set id junk 441 set id [after 10 set x ab\x00cd] 442 update 443 string length [lindex [lindex [after info $id] 0] 2] 444} -cleanup { 445 foreach i [after info] { 446 after cancel $i 447 } 448} -result 5 449 450set event [after idle foo bar] 451scan $event after#%d lastId 452test timer-7.1 {GetAfterEvent procedure} -returnCodes error -body { 453 after info xfter#$lastId 454} -result "event \"xfter#$lastId\" doesn't exist" 455test timer-7.2 {GetAfterEvent procedure} -returnCodes error -body { 456 after info afterx$lastId 457} -result "event \"afterx$lastId\" doesn't exist" 458test timer-7.3 {GetAfterEvent procedure} -returnCodes error -body { 459 after info after#ab 460} -result {event "after#ab" doesn't exist} 461test timer-7.4 {GetAfterEvent procedure} -returnCodes error -body { 462 after info after# 463} -result {event "after#" doesn't exist} 464test timer-7.5 {GetAfterEvent procedure} -returnCodes error -body { 465 after info after#${lastId}x 466} -result "event \"after#${lastId}x\" doesn't exist" 467test 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" 470after cancel $event 471 472test timer-8.1 {AfterProc procedure} { 473 set x before 474 proc foo {} { 475 set x untouched 476 after 100 {set x after} 477 after 200 478 update 479 return $x 480 } 481 list [foo] $x 482} {untouched after} 483test timer-8.2 {AfterProc procedure} -setup { 484 variable x empty 485 proc myHandler {msg options} { 486 variable x [list $msg [dict get $options -errorinfo]] 487 } 488 set handler [interp bgerror {}] 489 interp bgerror {} [namespace which myHandler] 490} -body { 491 after 100 {error "After error"} 492 after 200 493 set y $x 494 update 495 list $y $x 496} -cleanup { 497 interp bgerror {} $handler 498} -result {empty {{After error} {After error 499 while executing 500"error "After error"" 501 ("after" script)}}} 502test timer-8.3 {AfterProc procedure, deleting handler from itself} -setup { 503 foreach i [after info] { 504 after cancel $i 505 } 506} -body { 507 proc foo {} { 508 global x 509 set x {} 510 foreach i [after info] { 511 lappend x [after info $i] 512 } 513 after cancel foo 514 } 515 after idle foo 516 after 1000 {error "I shouldn't ever have executed"} 517 update idletasks 518 return $x 519} -result {{{error "I shouldn't ever have executed"} timer}} 520test timer-8.4 {AfterProc procedure, deleting handler from itself} -setup { 521 foreach i [after info] { 522 after cancel $i 523 } 524} -body { 525 proc foo {} { 526 global x 527 set x {} 528 foreach i [after info] { 529 lappend x [after info $i] 530 } 531 after cancel foo 532 } 533 after 1000 {error "I shouldn't ever have executed"} 534 after idle foo 535 update idletasks 536 return $x 537} -result {{{error "I shouldn't ever have executed"} timer}} 538 539foreach i [after info] { 540 after cancel $i 541} 542 543# No test for FreeAfterPtr, since it is already tested above. 544 545test timer-9.1 {AfterCleanupProc procedure} -setup { 546 catch {interp delete x} 547} -body { 548 interp create x 549 x eval {after 200 { 550 lappend x after 551 puts "part 1: this message should not appear" 552 }} 553 after 200 {lappend x after2} 554 x eval {after 200 { 555 lappend x after3 556 puts "part 2: this message should not appear" 557 }} 558 after 200 {lappend x after4} 559 x eval {after 200 { 560 lappend x after5 561 puts "part 3: this message should not appear" 562 }} 563 interp delete x 564 set x before 565 after 300 566 update 567 return $x 568} -result {before after2 after4} 569 570test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup { 571 interp create child 572 child eval namespace export after 573 child eval namespace eval foo namespace import ::after 574} -body { 575 child eval foo::after 1 576 child eval namespace origin foo::after 577} -cleanup { 578 # Bug will cause crash here; would cause failure otherwise 579 interp delete child 580} -result ::after 581 582test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body { 583 set b ok 584 set a [after 0x100000001 {set b "after fired early"}] 585 after 100 set done 1 586 vwait done 587 return $b 588} -cleanup { 589 catch {after cancel $a} 590} -result ok 591test timer-11.2 {Bug 1350293: [after] negative argument} -body { 592 set l {} 593 after 100 {lappend l 100; set done 1} 594 after -1 {lappend l -1} 595 vwait done 596 return $l 597} -result {-1 100} 598 599# cleanup 600::tcltest::cleanupTests 601return 602 603# Local Variables: 604# mode: tcl 605# End: 606