sl@0: # This file contains a collection of tests for the procedures in the file sl@0: # tclEvent.c, which includes the "update", and "vwait" Tcl sl@0: # commands. Sourcing this file into Tcl runs the tests and generates sl@0: # output for errors. No output means no errors were found. sl@0: # sl@0: # Copyright (c) 1995-1997 Sun Microsystems, Inc. sl@0: # Copyright (c) 1998-1999 by Scriptics Corporation. sl@0: # sl@0: # See the file "license.terms" for information on usage and redistribution sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: # sl@0: # RCS: @(#) $Id: event.test,v 1.20.2.1 2006/11/28 16:29:47 kennykb Exp $ sl@0: sl@0: package require tcltest 2 sl@0: namespace import -force ::tcltest::* sl@0: sl@0: testConstraint testfilehandler [llength [info commands testfilehandler]] sl@0: testConstraint testexithandler [llength [info commands testexithandler]] sl@0: testConstraint testfilewait [llength [info commands testfilewait]] sl@0: sl@0: test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} { sl@0: testfilehandler close sl@0: testfilehandler create 0 readable off sl@0: testfilehandler clear 0 sl@0: testfilehandler oneevent sl@0: set result "" sl@0: lappend result [testfilehandler counts 0] sl@0: testfilehandler fillpartial 0 sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 0] sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 0] sl@0: testfilehandler close sl@0: set result sl@0: } {{0 0} {1 0} {2 0}} sl@0: test event-1.2 {Tcl_CreateFileHandler, writing} {testfilehandler nonPortable} { sl@0: # This test is non-portable because on some systems (e.g. sl@0: # SunOS 4.1.3) pipes seem to be writable always. sl@0: testfilehandler close sl@0: testfilehandler create 0 off writable sl@0: testfilehandler clear 0 sl@0: testfilehandler oneevent sl@0: set result "" sl@0: lappend result [testfilehandler counts 0] sl@0: testfilehandler fillpartial 0 sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 0] sl@0: testfilehandler fill 0 sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 0] sl@0: testfilehandler close sl@0: set result sl@0: } {{0 1} {0 2} {0 2}} sl@0: test event-1.3 {Tcl_DeleteFileHandler} {testfilehandler nonPortable} { sl@0: testfilehandler close sl@0: testfilehandler create 2 disabled disabled sl@0: testfilehandler create 1 readable writable sl@0: testfilehandler create 0 disabled disabled sl@0: testfilehandler fillpartial 1 sl@0: set result "" sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler create 1 off off sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler close sl@0: set result sl@0: } {{0 1} {1 1} {1 2} {0 0}} sl@0: sl@0: test event-2.1 {Tcl_DeleteFileHandler} {testfilehandler nonPortable} { sl@0: testfilehandler close sl@0: testfilehandler create 2 disabled disabled sl@0: testfilehandler create 1 readable writable sl@0: testfilehandler fillpartial 1 sl@0: set result "" sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler create 1 off off sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler close sl@0: set result sl@0: } {{0 1} {1 1} {1 2} {0 0}} sl@0: test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} \ sl@0: {testfilehandler nonPortable} { sl@0: testfilehandler close sl@0: testfilehandler create 0 readable writable sl@0: testfilehandler fillpartial 0 sl@0: set result "" sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 0] sl@0: testfilehandler close sl@0: testfilehandler create 0 readable writable sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 0] sl@0: testfilehandler close sl@0: set result sl@0: } {{0 1} {0 0}} sl@0: sl@0: test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } {testfilehandler} { sl@0: testfilehandler close sl@0: testfilehandler create 1 readable writable sl@0: testfilehandler fillpartial 1 sl@0: testfilehandler windowevent sl@0: set result [testfilehandler counts 1] sl@0: testfilehandler close sl@0: set result sl@0: } {0 0} sl@0: sl@0: test event-4.1 {FileHandlerEventProc, race between event and disabling} \ sl@0: {testfilehandler nonPortable} { sl@0: update sl@0: testfilehandler close sl@0: testfilehandler create 2 disabled disabled sl@0: testfilehandler create 1 readable writable sl@0: testfilehandler fillpartial 1 sl@0: set result "" sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler create 1 disabled disabled sl@0: testfilehandler oneevent sl@0: lappend result [testfilehandler counts 1] sl@0: testfilehandler close sl@0: set result sl@0: } {{0 1} {1 1} {1 2} {0 0}} sl@0: test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} \ sl@0: {testfilehandler nonPortable} { sl@0: update sl@0: testfilehandler close sl@0: testfilehandler create 1 readable writable sl@0: testfilehandler create 2 readable writable sl@0: testfilehandler fillpartial 1 sl@0: testfilehandler fillpartial 2 sl@0: testfilehandler oneevent sl@0: set result "" sl@0: lappend result [testfilehandler counts 1] [testfilehandler counts 2] sl@0: testfilehandler windowevent sl@0: lappend result [testfilehandler counts 1] [testfilehandler counts 2] sl@0: testfilehandler close sl@0: set result sl@0: } {{0 0} {0 1} {0 0} {0 1}} sl@0: update sl@0: sl@0: test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} { sl@0: catch {rename bgerror {}} sl@0: proc bgerror msg { sl@0: global errorInfo errorCode x sl@0: lappend x [list $msg $errorInfo $errorCode] sl@0: } sl@0: after idle {error "a simple error"} sl@0: after idle {open non_existent} sl@0: after idle {set errorInfo foobar; set errorCode xyzzy} sl@0: set x {} sl@0: update idletasks sl@0: rename bgerror {} sl@0: regsub -all [file join {} non_existent] $x "non_existent" x sl@0: set x sl@0: } {{{a simple error} {a simple error sl@0: while executing sl@0: "error "a simple error"" sl@0: ("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory sl@0: while executing sl@0: "open non_existent" sl@0: ("after" script)} {POSIX ENOENT {no such file or directory}}}} sl@0: test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} { sl@0: catch {rename bgerror {}} sl@0: proc bgerror msg { sl@0: global x sl@0: lappend x $msg sl@0: return -code break sl@0: } sl@0: after idle {error "a simple error"} sl@0: after idle {open non_existent} sl@0: set x {} sl@0: update idletasks sl@0: rename bgerror {} sl@0: set x sl@0: } {{a simple error}} sl@0: sl@0: test event-6.1 {BgErrorDeleteProc procedure} { sl@0: catch {interp delete foo} sl@0: interp create foo sl@0: set erroutfile [makeFile Unmodified err.out] sl@0: foo eval [list set erroutfile $erroutfile] sl@0: foo eval { sl@0: proc bgerror args { sl@0: global errorInfo erroutfile sl@0: set f [open $erroutfile r+] sl@0: seek $f 0 end sl@0: puts $f "$args $errorInfo" sl@0: close $f sl@0: } sl@0: after 100 {error "first error"} sl@0: after 100 {error "second error"} sl@0: } sl@0: after 100 {interp delete foo} sl@0: after 200 sl@0: update sl@0: set f [open $erroutfile r] sl@0: set result [read $f] sl@0: close $f sl@0: removeFile $erroutfile sl@0: set result sl@0: } {Unmodified sl@0: } sl@0: sl@0: test event-7.1 {bgerror / regular} { sl@0: set errRes {} sl@0: proc bgerror {err} { sl@0: global errRes; sl@0: set errRes $err; sl@0: } sl@0: after 0 {error err1} sl@0: vwait errRes; sl@0: set errRes; sl@0: } err1 sl@0: sl@0: test event-7.2 {bgerror / accumulation} { sl@0: set errRes {} sl@0: proc bgerror {err} { sl@0: global errRes; sl@0: lappend errRes $err; sl@0: } sl@0: after 0 {error err1} sl@0: after 0 {error err2} sl@0: after 0 {error err3} sl@0: update sl@0: set errRes; sl@0: } {err1 err2 err3} sl@0: sl@0: test event-7.3 {bgerror / accumulation / break} { sl@0: set errRes {} sl@0: proc bgerror {err} { sl@0: global errRes; sl@0: lappend errRes $err; sl@0: return -code break "skip!"; sl@0: } sl@0: after 0 {error err1} sl@0: after 0 {error err2} sl@0: after 0 {error err3} sl@0: update sl@0: set errRes; sl@0: } err1 sl@0: sl@0: test event-7.4 {tkerror is nothing special anymore to tcl} { sl@0: set errRes {} sl@0: # we don't just rename bgerror to empty because it could then sl@0: # be autoloaded... sl@0: proc bgerror {err} { sl@0: global errRes; sl@0: lappend errRes "bg:$err"; sl@0: } sl@0: proc tkerror {err} { sl@0: global errRes; sl@0: lappend errRes "tk:$err"; sl@0: } sl@0: after 0 {error err1} sl@0: update sl@0: rename tkerror {} sl@0: set errRes sl@0: } bg:err1 sl@0: sl@0: testConstraint exec [llength [info commands exec]] sl@0: sl@0: test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} {exec} { sl@0: set script { sl@0: after 1000 error hello sl@0: after 2000 set a 0 sl@0: vwait a sl@0: } sl@0: sl@0: list [catch {exec [interpreter] << $script} errMsg] $errMsg sl@0: } {1 {hello sl@0: while executing sl@0: "error hello" sl@0: ("after" script)}} sl@0: sl@0: sl@0: # someday : add a test checking that sl@0: # when there is no bgerror, an error msg goes to stderr sl@0: # ideally one would use sub interp and transfer a fake stderr sl@0: # to it, unfortunatly the current interp tcl API does not allow sl@0: # that. the other option would be to use fork a test but it sl@0: # then becomes more a file/exec test than a bgerror test. sl@0: sl@0: # end of bgerror tests sl@0: catch {rename bgerror {}} sl@0: sl@0: sl@0: test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} { sl@0: set child [open |[list [interpreter]] r+] sl@0: puts $child "testexithandler create 41; testexithandler create 4" sl@0: puts $child "testexithandler create 6; exit" sl@0: flush $child sl@0: set result [read $child] sl@0: close $child sl@0: set result sl@0: } {even 6 sl@0: even 4 sl@0: odd 41 sl@0: } sl@0: sl@0: test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { sl@0: set child [open |[list [interpreter]] r+] sl@0: puts $child "testexithandler create 41; testexithandler create 4" sl@0: puts $child "testexithandler create 6; testexithandler delete 41" sl@0: puts $child "testexithandler create 16; exit" sl@0: flush $child sl@0: set result [read $child] sl@0: close $child sl@0: set result sl@0: } {even 16 sl@0: even 6 sl@0: even 4 sl@0: } sl@0: test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { sl@0: set child [open |[list [interpreter]] r+] sl@0: puts $child "testexithandler create 41; testexithandler create 4" sl@0: puts $child "testexithandler create 6; testexithandler delete 4" sl@0: puts $child "testexithandler create 16; exit" sl@0: flush $child sl@0: set result [read $child] sl@0: close $child sl@0: set result sl@0: } {even 16 sl@0: even 6 sl@0: odd 41 sl@0: } sl@0: test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { sl@0: set child [open |[list [interpreter]] r+] sl@0: puts $child "testexithandler create 41; testexithandler create 4" sl@0: puts $child "testexithandler create 6; testexithandler delete 6" sl@0: puts $child "testexithandler create 16; exit" sl@0: flush $child sl@0: set result [read $child] sl@0: close $child sl@0: set result sl@0: } {even 16 sl@0: even 4 sl@0: odd 41 sl@0: } sl@0: test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { sl@0: set child [open |[list [interpreter]] r+] sl@0: puts $child "testexithandler create 41; testexithandler delete 41" sl@0: puts $child "testexithandler create 16; exit" sl@0: flush $child sl@0: set result [read $child] sl@0: close $child sl@0: set result sl@0: } {even 16 sl@0: } sl@0: sl@0: test event-10.1 {Tcl_Exit procedure} {stdio} { sl@0: set child [open |[list [interpreter]] r+] sl@0: puts $child "exit 3" sl@0: list [catch {close $child} msg] $msg [lindex $errorCode 0] \ sl@0: [lindex $errorCode 2] sl@0: } {1 {child process exited abnormally} CHILDSTATUS 3} sl@0: sl@0: test event-11.1 {Tcl_VwaitCmd procedure} { sl@0: list [catch {vwait} msg] $msg sl@0: } {1 {wrong # args: should be "vwait name"}} sl@0: test event-11.2 {Tcl_VwaitCmd procedure} { sl@0: list [catch {vwait a b} msg] $msg sl@0: } {1 {wrong # args: should be "vwait name"}} sl@0: test event-11.3 {Tcl_VwaitCmd procedure} { sl@0: catch {unset x} sl@0: set x 1 sl@0: list [catch {vwait x(1)} msg] $msg sl@0: } {1 {can't trace "x(1)": variable isn't array}} sl@0: test event-11.4 {Tcl_VwaitCmd procedure} {} { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 10; update; # On Mac make sure update won't take long sl@0: after 100 {set x x-done} sl@0: after 200 {set y y-done} sl@0: after 300 {set z z-done} sl@0: after idle {set q q-done} sl@0: set x before sl@0: set y before sl@0: set z before sl@0: set q before sl@0: list [vwait y] $x $y $z $q sl@0: } {{} x-done y-done before q-done} sl@0: sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: sl@0: test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} { sl@0: set test1file [makeFile "" test1] sl@0: set f1 [open $test1file w] sl@0: proc accept {s args} { sl@0: puts $s foobar sl@0: close $s sl@0: } sl@0: catch {set s1 [socket -server accept 0]} sl@0: after 1000 sl@0: catch {set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]]} sl@0: close $s1 sl@0: set x 0 sl@0: set y 0 sl@0: set z 0 sl@0: fileevent $s2 readable {incr z} sl@0: vwait z sl@0: fileevent $f1 writable {incr x; if {$y == 3} {set z done}} sl@0: fileevent $s2 readable {incr y; if {$x == 3} {set z done}} sl@0: vwait z sl@0: close $f1 sl@0: close $s2 sl@0: removeFile $test1file sl@0: list $x $y $z sl@0: } {3 3 done} sl@0: test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} { sl@0: set test1file [makeFile "" test1] sl@0: set test2file [makeFile "" test2] sl@0: set f1 [open $test1file w] sl@0: set f2 [open $test2file w] sl@0: set x 0 sl@0: set y 0 sl@0: set z 0 sl@0: update sl@0: fileevent $f1 writable {incr x; if {$y == 3} {set z done}} sl@0: fileevent $f2 writable {incr y; if {$x == 3} {set z done}} sl@0: vwait z sl@0: close $f1 sl@0: close $f2 sl@0: removeFile $test1file sl@0: removeFile $test2file sl@0: list $x $y $z sl@0: } {3 3 done} sl@0: sl@0: sl@0: test event-12.1 {Tcl_UpdateCmd procedure} { sl@0: list [catch {update a b} msg] $msg sl@0: } {1 {wrong # args: should be "update ?idletasks?"}} sl@0: test event-12.2 {Tcl_UpdateCmd procedure} { sl@0: list [catch {update bogus} msg] $msg sl@0: } {1 {bad option "bogus": must be idletasks}} sl@0: test event-12.3 {Tcl_UpdateCmd procedure} { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 500 {set x after} sl@0: after idle {set y after} sl@0: after idle {set z "after, y = $y"} sl@0: set x before sl@0: set y before sl@0: set z before sl@0: update idletasks sl@0: list $x $y $z sl@0: } {before after {after, y = after}} sl@0: test event-12.4 {Tcl_UpdateCmd procedure} { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 10; update; # On Mac make sure update won't take long sl@0: after 200 {set x x-done} sl@0: after 600 {set y y-done} sl@0: after idle {set z z-done} sl@0: set x before sl@0: set y before sl@0: set z before sl@0: after 300 sl@0: update sl@0: list $x $y $z sl@0: } {x-done before z-done} sl@0: sl@0: test event-13.1 {Tcl_WaitForFile procedure, readable} {testfilehandler} { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 readable 0] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } {{} {no timeout}} sl@0: test event-13.2 {Tcl_WaitForFile procedure, readable} testfilehandler { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 readable 100] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } {{} timeout} sl@0: test event-13.3 {Tcl_WaitForFile procedure, readable} testfilehandler { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: testfilehandler fillpartial 1 sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 readable 100] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } {readable {no timeout}} sl@0: test event-13.4 {Tcl_WaitForFile procedure, writable} \ sl@0: {testfilehandler nonPortable} { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: testfilehandler fill 1 sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 writable 0] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } {{} {no timeout}} sl@0: test event-13.5 {Tcl_WaitForFile procedure, writable} \ sl@0: {testfilehandler nonPortable} { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: testfilehandler fill 1 sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 writable 100] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } {{} timeout} sl@0: test event-13.6 {Tcl_WaitForFile procedure, writable} testfilehandler { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 writable 100] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } {writable {no timeout}} sl@0: test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} testfilehandler { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 lappend x timeout sl@0: after idle lappend x idle sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: set x "" sl@0: set result [list [testfilehandler wait 1 readable 200] $x] sl@0: update sl@0: testfilehandler close sl@0: lappend result $x sl@0: } {{} {} {timeout idle}} sl@0: sl@0: test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} testfilewait { sl@0: set f [open "|sleep 2" r] sl@0: set result "" sl@0: lappend result [testfilewait $f readable 100] sl@0: lappend result [testfilewait $f readable -1] sl@0: close $f sl@0: set result sl@0: } {{} readable} sl@0: sl@0: sl@0: test event-14.1 {Tcl_WaitForFile procedure, readable, big fd} \ sl@0: -constraints {testfilehandler unix} \ sl@0: -setup { sl@0: set chanList {} sl@0: for {set i 0} {$i < 32} {incr i} { sl@0: lappend chanList [open /dev/null r] sl@0: } sl@0: } \ sl@0: -body { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 readable 0] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } \ sl@0: -result {{} {no timeout}} \ sl@0: -cleanup { sl@0: foreach chan $chanList {close $chan} sl@0: } sl@0: sl@0: test event-14.2 {Tcl_WaitForFile procedure, readable, big fd} \ sl@0: -constraints {testfilehandler unix} \ sl@0: -setup { sl@0: set chanList {} sl@0: for {set i 0} {$i < 32} {incr i} { sl@0: lappend chanList [open /dev/null r] sl@0: } sl@0: } \ sl@0: -body { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 readable 100] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } \ sl@0: -result {{} timeout} \ sl@0: -cleanup { sl@0: foreach chan $chanList {close $chan} sl@0: } sl@0: sl@0: test event-14.3 {Tcl_WaitForFile procedure, readable, big fd} \ sl@0: -constraints {testfilehandler unix} \ sl@0: -setup { sl@0: set chanList {} sl@0: for {set i 0} {$i < 32} {incr i} { sl@0: lappend chanList [open /dev/null r] sl@0: } sl@0: } \ sl@0: -body { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: testfilehandler fillpartial 1 sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 readable 100] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } \ sl@0: -result {readable {no timeout}} \ sl@0: -cleanup { sl@0: foreach chan $chanList {close $chan} sl@0: } sl@0: sl@0: test event-14.4 {Tcl_WaitForFile procedure, writable, big fd} \ sl@0: -constraints {testfilehandler unix nonPortable} \ sl@0: -setup { sl@0: set chanList {} sl@0: for {set i 0} {$i < 32} {incr i} { sl@0: lappend chanList [open /dev/null r] sl@0: } sl@0: } \ sl@0: -body { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: testfilehandler fill 1 sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 writable 0] sl@0: update sl@0: testfilehandler close sl@0: list $result $ sl@0: } \ sl@0: -result {{} {no timeout}} \ sl@0: -cleanup { sl@0: foreach chan $chanList {close $chan} sl@0: } sl@0: sl@0: test event-14.5 {Tcl_WaitForFile procedure, writable, big fd} \ sl@0: -constraints {testfilehandler unix nonPortable} \ sl@0: -setup { sl@0: set chanList {} sl@0: for {set i 0} {$i < 32} {incr i} { sl@0: lappend chanList [open /dev/null r] sl@0: } sl@0: } \ sl@0: -body { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: testfilehandler fill 1 sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 writable 100] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } \ sl@0: -result {{} timeout} \ sl@0: -cleanup { sl@0: foreach chan $chanList {close $chan} sl@0: } sl@0: sl@0: test event-14.6 {Tcl_WaitForFile procedure, writable, big fd} \ sl@0: -constraints {testfilehandler unix} \ sl@0: -setup { sl@0: set chanList {} sl@0: for {set i 0} {$i < 32} {incr i} { sl@0: lappend chanList [open /dev/null r] sl@0: } sl@0: } \ sl@0: -body { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 set x timeout sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: set x "no timeout" sl@0: set result [testfilehandler wait 1 writable 100] sl@0: update sl@0: testfilehandler close sl@0: list $result $x sl@0: } \ sl@0: -result {writable {no timeout}} \ sl@0: -cleanup { sl@0: foreach chan $chanList {close $chan} sl@0: } sl@0: sl@0: test event-14.7 {Tcl_WaitForFile, don't call other event handlers, big fd} \ sl@0: -constraints {testfilehandler unix} \ sl@0: -setup { sl@0: set chanList {} sl@0: for {set i 0} {$i < 32} {incr i} { sl@0: lappend chanList [open /dev/null r] sl@0: } sl@0: } \ sl@0: -body { sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: after 100 lappend x timeout sl@0: after idle lappend x idle sl@0: testfilehandler close sl@0: testfilehandler create 1 off off sl@0: set x "" sl@0: set result [list [testfilehandler wait 1 readable 200] $x] sl@0: update sl@0: testfilehandler close sl@0: lappend result $x sl@0: } \ sl@0: -result {{} {} {timeout idle}} \ sl@0: -cleanup { sl@0: foreach chan $chanList {close $chan} sl@0: } sl@0: sl@0: sl@0: test event-14.8 {Tcl_WaitForFile procedure, waiting indefinitely, big fd} \ sl@0: -constraints {testfilewait unix} \ sl@0: -body { sl@0: set f [open "|sleep 2" r] sl@0: set result "" sl@0: lappend result [testfilewait $f readable 100] sl@0: lappend result [testfilewait $f readable -1] sl@0: close $f sl@0: set result sl@0: } \ sl@0: -setup { sl@0: set chanList {} sl@0: for {set i 0} {$i < 32} {incr i} { sl@0: lappend chanList [open /dev/null r] sl@0: } sl@0: } \ sl@0: -result {{} readable} \ sl@0: -cleanup { sl@0: foreach chan $chanList {close $chan} sl@0: } sl@0: sl@0: # cleanup sl@0: foreach i [after info] { sl@0: after cancel $i sl@0: } sl@0: ::tcltest::cleanupTests sl@0: return