1# This file contains a collection of tests for the procedures in the file 2# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing 3# this file into Tcl runs the tests and generates output for errors. No 4# output means no errors were found. 5# 6# Copyright © 1995-1997 Sun Microsystems, Inc. 7# Copyright © 1998-1999 Scriptics Corporation. 8# 9# See the file "license.terms" for information on usage and redistribution 10# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 12package require tcltest 2.5 13namespace import -force ::tcltest::* 14 15catch { 16 ::tcltest::loadTestedCommands 17 package require -exact tcl::test [info patchlevel] 18 set ::tcltestlib [info loaded {} Tcltest] 19} 20 21 22testConstraint testfilehandler [llength [info commands testfilehandler]] 23testConstraint testexithandler [llength [info commands testexithandler]] 24testConstraint testfilewait [llength [info commands testfilewait]] 25testConstraint exec [llength [info commands exec]] 26testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] 27 28test event-1.1 {Tcl_CreateFileHandler, reading} -setup { 29 testfilehandler close 30 set result "" 31} -constraints {testfilehandler notOSX} -body { 32 testfilehandler create 0 readable off 33 testfilehandler clear 0 34 testfilehandler oneevent 35 lappend result [testfilehandler counts 0] 36 testfilehandler fillpartial 0 37 update idletasks 38 testfilehandler oneevent 39 lappend result [testfilehandler counts 0] 40 testfilehandler oneevent 41 lappend result [testfilehandler counts 0] 42} -cleanup { 43 testfilehandler close 44} -result {{0 0} {1 0} {2 0}} 45test event-1.2 {Tcl_CreateFileHandler, writing} -setup { 46 testfilehandler close 47 set result "" 48} -constraints {testfilehandler nonPortable} -body { 49 # This test is non-portable because on some systems (e.g., SunOS 4.1.3) 50 # pipes seem to be writable always. 51 testfilehandler create 0 off writable 52 testfilehandler clear 0 53 testfilehandler oneevent 54 lappend result [testfilehandler counts 0] 55 testfilehandler fillpartial 0 56 testfilehandler oneevent 57 lappend result [testfilehandler counts 0] 58 testfilehandler fill 0 59 testfilehandler oneevent 60 lappend result [testfilehandler counts 0] 61} -cleanup { 62 testfilehandler close 63} -result {{0 1} {0 2} {0 2}} 64test event-1.3 {Tcl_DeleteFileHandler} -setup { 65 testfilehandler close 66 set result "" 67} -constraints {testfilehandler nonPortable} -body { 68 testfilehandler create 2 disabled disabled 69 testfilehandler create 1 readable writable 70 testfilehandler create 0 disabled disabled 71 testfilehandler fillpartial 1 72 testfilehandler oneevent 73 lappend result [testfilehandler counts 1] 74 testfilehandler oneevent 75 lappend result [testfilehandler counts 1] 76 testfilehandler oneevent 77 lappend result [testfilehandler counts 1] 78 testfilehandler create 1 off off 79 testfilehandler oneevent 80 lappend result [testfilehandler counts 1] 81} -cleanup { 82 testfilehandler close 83} -result {{0 1} {1 1} {1 2} {0 0}} 84 85test event-2.1 {Tcl_DeleteFileHandler} -setup { 86 testfilehandler close 87 set result "" 88} -constraints {testfilehandler nonPortable} -body { 89 testfilehandler create 2 disabled disabled 90 testfilehandler create 1 readable writable 91 testfilehandler fillpartial 1 92 testfilehandler oneevent 93 lappend result [testfilehandler counts 1] 94 testfilehandler oneevent 95 lappend result [testfilehandler counts 1] 96 testfilehandler oneevent 97 lappend result [testfilehandler counts 1] 98 testfilehandler create 1 off off 99 testfilehandler oneevent 100 lappend result [testfilehandler counts 1] 101} -cleanup { 102 testfilehandler close 103} -result {{0 1} {1 1} {1 2} {0 0}} 104test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} -setup { 105 testfilehandler close 106 set result "" 107} -constraints {testfilehandler nonPortable} -body { 108 testfilehandler create 0 readable writable 109 testfilehandler fillpartial 0 110 testfilehandler oneevent 111 lappend result [testfilehandler counts 0] 112 testfilehandler close 113 testfilehandler create 0 readable writable 114 testfilehandler oneevent 115 lappend result [testfilehandler counts 0] 116} -cleanup { 117 testfilehandler close 118} -result {{0 1} {0 0}} 119 120test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off} -setup { 121 testfilehandler close 122} -constraints {testfilehandler} -body { 123 testfilehandler create 1 readable writable 124 testfilehandler fillpartial 1 125 testfilehandler windowevent 126 testfilehandler counts 1 127} -cleanup { 128 testfilehandler close 129} -result {0 0} 130 131test event-4.1 {FileHandlerEventProc, race between event and disabling} -setup { 132 update 133 testfilehandler close 134 set result "" 135} -constraints {testfilehandler nonPortable} -body { 136 testfilehandler create 2 disabled disabled 137 testfilehandler create 1 readable writable 138 testfilehandler fillpartial 1 139 testfilehandler oneevent 140 lappend result [testfilehandler counts 1] 141 testfilehandler oneevent 142 lappend result [testfilehandler counts 1] 143 testfilehandler oneevent 144 lappend result [testfilehandler counts 1] 145 testfilehandler create 1 disabled disabled 146 testfilehandler oneevent 147 lappend result [testfilehandler counts 1] 148} -cleanup { 149 testfilehandler close 150} -result {{0 1} {1 1} {1 2} {0 0}} 151test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} -setup { 152 update 153 testfilehandler close 154} -constraints {testfilehandler nonPortable} -body { 155 testfilehandler create 1 readable writable 156 testfilehandler create 2 readable writable 157 testfilehandler fillpartial 1 158 testfilehandler fillpartial 2 159 testfilehandler oneevent 160 set result "" 161 lappend result [testfilehandler counts 1] [testfilehandler counts 2] 162 testfilehandler windowevent 163 lappend result [testfilehandler counts 1] [testfilehandler counts 2] 164} -cleanup { 165 testfilehandler close 166} -result {{0 0} {0 1} {0 0} {0 1}} 167update 168 169test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} -setup { 170 catch {rename bgerror {}} 171} -body { 172 proc bgerror msg { 173 global errorInfo errorCode x 174 lappend x [list $msg $errorInfo $errorCode] 175 } 176 after idle {error "a simple error"} 177 after idle {open non_existent} 178 after idle {set errorInfo foobar; set errorCode xyzzy} 179 set x {} 180 update idletasks 181 regsub -all [file join {} non_existent] $x "non_existent" 182} -cleanup { 183 rename bgerror {} 184} -result {{{a simple error} {a simple error 185 while executing 186"error "a simple error"" 187 ("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory 188 while executing 189"open non_existent" 190 ("after" script)} {POSIX ENOENT {no such file or directory}}}} 191test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} -setup { 192 catch {rename bgerror {}} 193} -body { 194 proc bgerror msg { 195 global x 196 lappend x $msg 197 return -code break 198 } 199 after idle {error "a simple error"} 200 after idle {open non_existent} 201 set x {} 202 update idletasks 203 return $x 204} -cleanup { 205 rename bgerror {} 206} -result {{a simple error}} 207test event-5.3 {HandleBgErrors: [Bug 1670155]} -setup { 208 variable x 209 proc demo args {variable x done} 210 variable target [list [namespace which demo] x] 211 proc trial args {variable target; string length $target} 212 trace add execution demo enter [namespace code trial] 213 variable save [interp bgerror {}] 214 interp bgerror {} $target 215} -body { 216 after 0 {error bar} 217 vwait [namespace which -variable x] 218} -cleanup { 219 interp bgerror {} $save 220 unset x target save 221 rename demo {} 222 rename trial {} 223} -result {} 224test event-5.3.1 {Default [interp bgerror] handler} -body { 225 ::tcl::Bgerror 226} -returnCodes error -match glob -result {*msg options*} 227test event-5.4 {Default [interp bgerror] handler} -body { 228 ::tcl::Bgerror {} 229} -returnCodes error -match glob -result {*msg options*} 230test event-5.5 {Default [interp bgerror] handler} -body { 231 ::tcl::Bgerror {} {} {} 232} -returnCodes error -match glob -result {*msg options*} 233test event-5.6 {Default [interp bgerror] handler} -body { 234 ::tcl::Bgerror {} {} 235} -returnCodes error -match glob -result {*-level*} 236test event-5.7 {Default [interp bgerror] handler} -body { 237 ::tcl::Bgerror {} {-level foo} 238} -returnCodes error -match glob -result {*expected integer*} 239test event-5.8 {Default [interp bgerror] handler} -body { 240 ::tcl::Bgerror {} {-level 0} 241} -returnCodes error -match glob -result {*-code*} 242test event-5.9 {Default [interp bgerror] handler} -body { 243 ::tcl::Bgerror {} {-level 0 -code ok} 244} -returnCodes error -match glob -result {*expected integer*} 245test event-5.10 {Default [interp bgerror] handler} -body { 246 proc bgerror {m} {append ::res $m} 247 set ::res {} 248 ::tcl::Bgerror {} {-level 0 -code 0} 249 return $::res 250} -cleanup { 251 rename bgerror {} 252} -result {} 253test event-5.11 {Default [interp bgerror] handler} -body { 254 proc bgerror {m} {append ::res $m} 255 set ::res {} 256 ::tcl::Bgerror msg {-level 0 -code 1} 257 return $::res 258} -cleanup { 259 rename bgerror {} 260} -result {msg} 261test event-5.12 {Default [interp bgerror] handler} -body { 262 proc bgerror {m} {append ::res $m} 263 set ::res {} 264 ::tcl::Bgerror msg {-level 0 -code 2} 265 return $::res 266} -cleanup { 267 rename bgerror {} 268} -result {command returned bad code: 2} 269test event-5.13 {Default [interp bgerror] handler} -body { 270 proc bgerror {m} {append ::res $m} 271 set ::res {} 272 ::tcl::Bgerror msg {-level 0 -code 3} 273 return $::res 274} -cleanup { 275 rename bgerror {} 276} -result {invoked "break" outside of a loop} 277test event-5.14 {Default [interp bgerror] handler} -body { 278 proc bgerror {m} {append ::res $m} 279 set ::res {} 280 ::tcl::Bgerror msg {-level 0 -code 4} 281 return $::res 282} -cleanup { 283 rename bgerror {} 284} -result {invoked "continue" outside of a loop} 285test event-5.15 {Default [interp bgerror] handler} -body { 286 proc bgerror {m} {append ::res $m} 287 set ::res {} 288 ::tcl::Bgerror msg {-level 0 -code 5} 289 return $::res 290} -cleanup { 291 rename bgerror {} 292} -result {command returned bad code: 5} 293 294test event-6.1 {BgErrorDeleteProc procedure} -setup { 295 catch {interp delete foo} 296 interp create foo 297 set erroutfile [makeFile Unmodified err.out] 298} -body { 299 foo eval [list set erroutfile $erroutfile] 300 foo eval { 301 proc bgerror args { 302 global errorInfo erroutfile 303 set f [open $erroutfile r+] 304 seek $f 0 end 305 puts $f "$args $errorInfo" 306 close $f 307 } 308 after 100 {error "first error"} 309 after 100 {error "second error"} 310 } 311 after 100 {interp delete foo} 312 after 200 313 update 314 set f [open $erroutfile r] 315 set result [read $f] 316 close $f 317 return $result 318} -cleanup { 319 removeFile $erroutfile 320} -result {Unmodified 321} 322 323test event-7.1 {bgerror / regular} { 324 set errRes {} 325 proc bgerror {err} { 326 global errRes 327 set errRes $err 328 } 329 after 0 {error err1} 330 vwait errRes 331 return $errRes 332} err1 333test event-7.2 {bgerror / accumulation} { 334 set errRes {} 335 proc bgerror {err} { 336 global errRes 337 lappend errRes $err 338 } 339 after 0 {error err1} 340 after 0 {error err2} 341 after 0 {error err3} 342 update 343 return $errRes 344} {err1 err2 err3} 345test event-7.3 {bgerror / accumulation / break} { 346 set errRes {} 347 proc bgerror {err} { 348 global errRes 349 lappend errRes $err 350 return -code break "skip!" 351 } 352 after 0 {error err1} 353 after 0 {error err2} 354 after 0 {error err3} 355 update 356 return $errRes 357} err1 358test event-7.4 {tkerror is nothing special anymore to tcl} -body { 359 set errRes {} 360 # we don't just rename bgerror to empty because it could then 361 # be autoloaded... 362 proc bgerror {err} { 363 global errRes 364 lappend errRes "bg:$err" 365 } 366 proc tkerror {err} { 367 global errRes 368 lappend errRes "tk:$err" 369 } 370 after 0 {error err1} 371 update 372 return $errRes 373} -cleanup { 374 rename tkerror {} 375} -result bg:err1 376test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} -body { 377 exec [interpreter] << { 378 after 1000 error hello 379 after 2000 set a 0 380 vwait a 381 } 382} -constraints {exec} -returnCodes error -result {hello 383 while executing 384"error hello" 385 ("after" script)} 386test event-7.6 {safe hidden bgerror fallback} -setup { 387 variable result {} 388 interp create -safe safe 389} -body { 390 safe alias puts puts 391 safe alias result ::append [namespace which -variable result] 392 safe eval {proc bgerror m {result $m\n$::errorCode\n$::errorInfo\n}} 393 safe hide bgerror 394 safe eval after 0 error foo 395 update 396 return $result 397} -cleanup { 398 interp delete safe 399} -result {foo 400NONE 401foo 402 while executing 403"error foo" 404 ("after" script) 405} 406test event-7.7 {safe hidden bgerror fallback} -setup { 407 variable result {} 408 interp create -safe safe 409} -body { 410 safe alias puts puts 411 safe alias result ::append [namespace which -variable result] 412 safe eval {proc bgerror m {result $m\n$::errorCode\n$::errorInfo\n}} 413 safe hide bgerror 414 safe eval {proc bgerror m {error bar soom baz}} 415 safe eval after 0 error foo 416 update 417 return $result 418} -cleanup { 419 interp delete safe 420} -result {foo 421NONE 422foo 423 while executing 424"error foo" 425 ("after" script) 426} 427 428# someday : add a test checking that when there is no bgerror, an error msg 429# goes to stderr ideally one would use sub interp and transfer a fake stderr 430# to it, unfortunatly the current interp tcl API does not allow that. The 431# other option would be to use fork a test but it then becomes more a 432# file/exec test than a bgerror test. 433 434# end of bgerror tests 435catch {rename bgerror {}} 436 437test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} { 438 set child [open |[list [interpreter]] r+] 439 puts $child "catch {load $::tcltestlib Tcltest}" 440 puts $child "testexithandler create 41; testexithandler create 4" 441 puts $child "testexithandler create 6; exit" 442 flush $child 443 set result [read $child] 444 close $child 445 return $result 446} {even 6 447even 4 448odd 41 449} 450 451test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { 452 set child [open |[list [interpreter]] r+] 453 puts $child "catch {load $::tcltestlib Tcltest}" 454 puts $child "testexithandler create 41; testexithandler create 4" 455 puts $child "testexithandler create 6; testexithandler delete 41" 456 puts $child "testexithandler create 16; exit" 457 flush $child 458 set result [read $child] 459 close $child 460 return $result 461} {even 16 462even 6 463even 4 464} 465test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { 466 set child [open |[list [interpreter]] r+] 467 puts $child "catch {load $::tcltestlib Tcltest}" 468 puts $child "testexithandler create 41; testexithandler create 4" 469 puts $child "testexithandler create 6; testexithandler delete 4" 470 puts $child "testexithandler create 16; exit" 471 flush $child 472 set result [read $child] 473 close $child 474 return $result 475} {even 16 476even 6 477odd 41 478} 479test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { 480 set child [open |[list [interpreter]] r+] 481 puts $child "catch {load $::tcltestlib Tcltest}" 482 puts $child "testexithandler create 41; testexithandler create 4" 483 puts $child "testexithandler create 6; testexithandler delete 6" 484 puts $child "testexithandler create 16; exit" 485 flush $child 486 set result [read $child] 487 close $child 488 return $result 489} {even 16 490even 4 491odd 41 492} 493test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { 494 set child [open |[list [interpreter]] r+] 495 puts $child "catch {load $::tcltestlib Tcltest}" 496 puts $child "testexithandler create 41; testexithandler delete 41" 497 puts $child "testexithandler create 16; exit" 498 flush $child 499 set result [read $child] 500 close $child 501 return $result 502} {even 16 503} 504 505test event-10.1 {Tcl_Exit procedure} {stdio} { 506 set child [open |[list [interpreter]] r+] 507 puts $child "exit 3" 508 list [catch {close $child} msg] $msg [lindex $::errorCode 0] \ 509 [lindex $::errorCode 2] 510} {1 {child process exited abnormally} CHILDSTATUS 3} 511 512test event-11.1 {Tcl_VwaitCmd procedure} -returnCodes error -body { 513 vwait 514} -result {wrong # args: should be "vwait name"} 515test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body { 516 vwait a b 517} -result {wrong # args: should be "vwait name"} 518test event-11.3 {Tcl_VwaitCmd procedure} -setup { 519 catch {unset x} 520} -body { 521 set x 1 522 vwait x(1) 523} -returnCodes error -result {can't trace "x(1)": variable isn't array} 524test event-11.4 {Tcl_VwaitCmd procedure} -setup { 525 foreach i [after info] { 526 after cancel $i 527 } 528 after 10; update; # On Mac make sure update won't take long 529} -body { 530 after 100 {set x x-done} 531 after 200 {set y y-done} 532 after 400 {set z z-done} 533 after idle {set q q-done} 534 set x before 535 set y before 536 set z before 537 set q before 538 list [vwait y] $x $y $z $q 539} -cleanup { 540 foreach i [after info] { 541 after cancel $i 542 } 543} -result {{} x-done y-done before q-done} 544test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} -setup { 545 set test1file [makeFile "" test1] 546} -constraints {socket} -body { 547 set f1 [open $test1file w] 548 proc accept {s args} { 549 puts $s foobar 550 close $s 551 } 552 set s1 [socket -server accept -myaddr 127.0.0.1 0] 553 after 1000 554 set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]] 555 close $s1 556 set x 0 557 set y 0 558 set z 0 559 fileevent $s2 readable {incr z} 560 vwait z 561 fileevent $f1 writable {incr x; if {$y == 3} {set z done}} 562 fileevent $s2 readable {incr y; if {$x == 3} {set z done}} 563 vwait z 564 close $f1 565 close $s2 566 list $x $y $z 567} -cleanup { 568 removeFile $test1file 569} -result {3 3 done} 570test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} { 571 set test1file [makeFile "" test1] 572 set test2file [makeFile "" test2] 573 set f1 [open $test1file w] 574 set f2 [open $test2file w] 575 set x 0 576 set y 0 577 set z 0 578 update 579 fileevent $f1 writable {incr x; if {$y == 3} {set z done}} 580 fileevent $f2 writable {incr y; if {$x == 3} {set z done}} 581 vwait z 582 close $f1 583 close $f2 584 removeFile $test1file 585 removeFile $test2file 586 list $x $y $z 587} {3 3 done} 588test event-11.7 {Bug 16828b3744} { 589 after idle { 590 set ::t::v 1 591 namespace delete ::t 592 } 593 namespace eval ::t { 594 vwait ::t::v 595 } 596} {} 597test event-11.8 {Bug 16828b3744} -setup { 598 oo::class create A { 599 variable continue 600 601 method start {} { 602 after idle [self] destroy 603 604 set continue 0 605 vwait [namespace current]::continue 606 } 607 destructor { 608 set continue 1 609 } 610 } 611} -body { 612 [A new] start 613} -cleanup { 614 A destroy 615} -result {} 616 617test event-12.1 {Tcl_UpdateCmd procedure} -returnCodes error -body { 618 update a b 619} -result {wrong # args: should be "update ?idletasks?"} 620test event-12.2 {Tcl_UpdateCmd procedure} -returnCodes error -body { 621 update bogus 622} -result {bad option "bogus": must be idletasks} 623test event-12.3 {Tcl_UpdateCmd procedure} -setup { 624 foreach i [after info] { 625 after cancel $i 626 } 627} -body { 628 after 500 {set x after} 629 after idle {set y after} 630 after idle {set z "after, y = $y"} 631 set x before 632 set y before 633 set z before 634 update idletasks 635 list $x $y $z 636} -cleanup { 637 foreach i [after info] { 638 after cancel $i 639 } 640} -result {before after {after, y = after}} 641test event-12.4 {Tcl_UpdateCmd procedure} -setup { 642 foreach i [after info] { 643 after cancel $i 644 } 645} -body { 646 after 10; update; # On Mac make sure update won't take long 647 after 200 {set x x-done} 648 after 600 {set y y-done} 649 after idle {set z z-done} 650 set x before 651 set y before 652 set z before 653 after 300 654 update 655 list $x $y $z 656} -cleanup { 657 foreach i [after info] { 658 after cancel $i 659 } 660} -result {x-done before z-done} 661 662test event-13.1 {Tcl_WaitForFile procedure, readable} -setup { 663 foreach i [after info] { 664 after cancel $i 665 } 666 testfilehandler close 667} -constraints {testfilehandler} -body { 668 after 100 set x timeout 669 testfilehandler create 1 off off 670 set x "no timeout" 671 set result [testfilehandler wait 1 readable 0] 672 update 673 list $result $x 674} -cleanup { 675 testfilehandler close 676 foreach i [after info] { 677 after cancel $i 678 } 679} -result {{} {no timeout}} 680test event-13.2 {Tcl_WaitForFile procedure, readable} -setup { 681 foreach i [after info] { 682 after cancel $i 683 } 684 testfilehandler close 685} -constraints testfilehandler -body { 686 after 100 set x timeout 687 testfilehandler create 1 off off 688 set x "no timeout" 689 set result [testfilehandler wait 1 readable 100] 690 update 691 list $result $x 692} -cleanup { 693 testfilehandler close 694 foreach i [after info] { 695 after cancel $i 696 } 697} -result {{} timeout} 698test event-13.3 {Tcl_WaitForFile procedure, readable} -setup { 699 foreach i [after info] { 700 after cancel $i 701 } 702 testfilehandler close 703} -constraints testfilehandler -body { 704 after 100 set x timeout 705 testfilehandler create 1 off off 706 testfilehandler fillpartial 1 707 set x "no timeout" 708 set result [testfilehandler wait 1 readable 100] 709 update 710 list $result $x 711} -cleanup { 712 testfilehandler close 713 foreach i [after info] { 714 after cancel $i 715 } 716} -result {readable {no timeout}} 717test event-13.4 {Tcl_WaitForFile procedure, writable} -setup { 718 foreach i [after info] { 719 after cancel $i 720 } 721 testfilehandler close 722} -constraints {testfilehandler nonPortable} -body { 723 after 100 set x timeout 724 testfilehandler create 1 off off 725 testfilehandler fill 1 726 set x "no timeout" 727 set result [testfilehandler wait 1 writable 0] 728 update 729 list $result $x 730} -cleanup { 731 testfilehandler close 732 foreach i [after info] { 733 after cancel $i 734 } 735} -result {{} {no timeout}} 736test event-13.5 {Tcl_WaitForFile procedure, writable} -setup { 737 foreach i [after info] { 738 after cancel $i 739 } 740 testfilehandler close 741} -constraints {testfilehandler nonPortable} -body { 742 after 100 set x timeout 743 testfilehandler create 1 off off 744 testfilehandler fill 1 745 set x "no timeout" 746 set result [testfilehandler wait 1 writable 100] 747 update 748 list $result $x 749} -cleanup { 750 testfilehandler close 751 foreach i [after info] { 752 after cancel $i 753 } 754} -result {{} timeout} 755test event-13.6 {Tcl_WaitForFile procedure, writable} -setup { 756 foreach i [after info] { 757 after cancel $i 758 } 759 testfilehandler close 760} -constraints testfilehandler -body { 761 after 100 set x timeout 762 testfilehandler create 1 off off 763 set x "no timeout" 764 set result [testfilehandler wait 1 writable 100] 765 update 766 list $result $x 767} -cleanup { 768 testfilehandler close 769 foreach i [after info] { 770 after cancel $i 771 } 772} -result {writable {no timeout}} 773test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} -setup { 774 foreach i [after info] { 775 after cancel $i 776 } 777 testfilehandler close 778} -constraints testfilehandler -body { 779 after 100 lappend x timeout 780 after idle lappend x idle 781 testfilehandler create 1 off off 782 set x "" 783 set result [list [testfilehandler wait 1 readable 200] $x] 784 update 785 lappend result $x 786} -cleanup { 787 testfilehandler close 788 foreach i [after info] { 789 after cancel $i 790 } 791} -result {{} {} {timeout idle}} 792test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} testfilewait { 793 set f [open "|sleep 2" r] 794 set result "" 795 lappend result [testfilewait $f readable 100] 796 lappend result [testfilewait $f readable -1] 797 close $f 798 return $result 799} {{} readable} 800 801test event-14.1 {Tcl_WaitForFile procedure, readable, big fd} -setup { 802 set chanList {} 803 for {set i 0} {$i < 32} {incr i} { 804 lappend chanList [open /dev/null r] 805 } 806 foreach i [after info] {after cancel $i} 807 testfilehandler close 808} -constraints {testfilehandler unix} -body { 809 after 100 set x timeout 810 testfilehandler create 1 off off 811 set x "no timeout" 812 set result [testfilehandler wait 1 readable 0] 813 update 814 list $result $x 815} -cleanup { 816 testfilehandler close 817 foreach chan $chanList {close $chan} 818 foreach i [after info] {after cancel $i} 819} -result {{} {no timeout}} 820test event-14.2 {Tcl_WaitForFile procedure, readable, big fd} -setup { 821 set chanList {} 822 for {set i 0} {$i < 32} {incr i} { 823 lappend chanList [open /dev/null r] 824 } 825 foreach i [after info] {after cancel $i} 826 testfilehandler close 827} -constraints {testfilehandler unix} -body { 828 after 100 set x timeout 829 testfilehandler create 1 off off 830 set x "no timeout" 831 set result [testfilehandler wait 1 readable 100] 832 update 833 list $result $x 834} -cleanup { 835 testfilehandler close 836 foreach chan $chanList {close $chan} 837 foreach i [after info] {after cancel $i} 838} -result {{} timeout} 839test event-14.3 {Tcl_WaitForFile procedure, readable, big fd} -setup { 840 set chanList {} 841 for {set i 0} {$i < 32} {incr i} { 842 lappend chanList [open /dev/null r] 843 } 844 foreach i [after info] {after cancel $i} 845 testfilehandler close 846} -constraints {testfilehandler unix} -body { 847 after 100 set x timeout 848 testfilehandler create 1 off off 849 testfilehandler fillpartial 1 850 set x "no timeout" 851 set result [testfilehandler wait 1 readable 100] 852 update 853 list $result $x 854} -cleanup { 855 testfilehandler close 856 foreach chan $chanList {close $chan} 857 foreach i [after info] {after cancel $i} 858} -result {readable {no timeout}} 859test event-14.4 {Tcl_WaitForFile procedure, writable, big fd} -setup { 860 set chanList {} 861 for {set i 0} {$i < 32} {incr i} { 862 lappend chanList [open /dev/null r] 863 } 864 foreach i [after info] {after cancel $i} 865 testfilehandler close 866} -constraints {testfilehandler unix nonPortable} -body { 867 after 100 set x timeout 868 testfilehandler create 1 off off 869 testfilehandler fill 1 870 set x "no timeout" 871 set result [testfilehandler wait 1 writable 0] 872 update 873 list $result $x 874} -cleanup { 875 testfilehandler close 876 foreach chan $chanList {close $chan} 877 foreach i [after info] {after cancel $i} 878} -result {{} {no timeout}} 879test event-14.5 {Tcl_WaitForFile procedure, writable, big fd} -setup { 880 set chanList {} 881 for {set i 0} {$i < 32} {incr i} { 882 lappend chanList [open /dev/null r] 883 } 884 foreach i [after info] {after cancel $i} 885 testfilehandler close 886} -constraints {testfilehandler unix nonPortable} -body { 887 after 100 set x timeout 888 testfilehandler create 1 off off 889 testfilehandler fill 1 890 set x "no timeout" 891 set result [testfilehandler wait 1 writable 100] 892 update 893 list $result $x 894} -cleanup { 895 testfilehandler close 896 foreach chan $chanList {close $chan} 897 foreach i [after info] {after cancel $i} 898} -result {{} timeout} 899test event-14.6 {Tcl_WaitForFile procedure, writable, big fd} -setup { 900 set chanList {} 901 for {set i 0} {$i < 32} {incr i} { 902 lappend chanList [open /dev/null r] 903 } 904 foreach i [after info] {after cancel $i} 905 testfilehandler close 906} -constraints {testfilehandler unix} -body { 907 after 100 set x timeout 908 testfilehandler create 1 off off 909 set x "no timeout" 910 set result [testfilehandler wait 1 writable 100] 911 update 912 list $result $x 913} -cleanup { 914 testfilehandler close 915 foreach chan $chanList {close $chan} 916 foreach i [after info] {after cancel $i} 917} -result {writable {no timeout}} 918test event-14.7 {Tcl_WaitForFile, don't call other event handlers, big fd} -setup { 919 set chanList {} 920 for {set i 0} {$i < 32} {incr i} { 921 lappend chanList [open /dev/null r] 922 } 923 foreach i [after info] {after cancel $i} 924 testfilehandler close 925} -constraints {testfilehandler unix} -body { 926 after 100 lappend x timeout 927 after idle lappend x idle 928 testfilehandler create 1 off off 929 set x "" 930 set result [list [testfilehandler wait 1 readable 200] $x] 931 update 932 lappend result $x 933} -cleanup { 934 testfilehandler close 935 foreach chan $chanList {close $chan} 936 foreach i [after info] {after cancel $i} 937} -result {{} {} {timeout idle}} 938test event-14.8 {Tcl_WaitForFile procedure, waiting indefinitely, big fd} -setup { 939 set chanList {} 940 for {set i 0} {$i < 32} {incr i} { 941 lappend chanList [open /dev/null r] 942 } 943} -constraints {testfilewait unix} -body { 944 set f [open "|sleep 2" r] 945 set result "" 946 lappend result [testfilewait $f readable 100] 947 lappend result [testfilewait $f readable -1] 948 close $f 949 return $result 950} -cleanup { 951 foreach chan $chanList {close $chan} 952} -result {{} readable} 953 954# cleanup 955foreach i [after info] { 956 after cancel $i 957} 958::tcltest::cleanupTests 959return 960 961# Local Variables: 962# mode: tcl 963# End: 964