util/src/TclTk/tcl8.6.12/tests/event.test

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