--- /dev/null
+# This file contains a collection of tests for the procedures in the file
+# tclEvent.c, which includes the "update", and "vwait" Tcl commands. Sourcing
+# this file into Tcl runs the tests and generates output for errors. No
+# output means no errors were found.
+#
+# Copyright (c) 1995-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2.5
+ namespace import -force ::tcltest::*
+}
+
+catch {
+ ::tcltest::loadTestedCommands
+ package require -exact Tcltest [info patchlevel]
+ set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
+}
+
+
+testConstraint testfilehandler [llength [info commands testfilehandler]]
+testConstraint testexithandler [llength [info commands testexithandler]]
+testConstraint testfilewait [llength [info commands testfilewait]]
+testConstraint exec [llength [info commands exec]]
+testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
+
+test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
+ testfilehandler close
+ set result ""
+} -constraints {testfilehandler notOSX} -body {
+ testfilehandler create 0 readable off
+ testfilehandler clear 0
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+ testfilehandler fillpartial 0
+ update idletasks
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+} -cleanup {
+ testfilehandler close
+} -result {{0 0} {1 0} {2 0}}
+test event-1.2 {Tcl_CreateFileHandler, writing} -setup {
+ testfilehandler close
+ set result ""
+} -constraints {testfilehandler nonPortable} -body {
+ # This test is non-portable because on some systems (e.g., SunOS 4.1.3)
+ # pipes seem to be writable always.
+ testfilehandler create 0 off writable
+ testfilehandler clear 0
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+ testfilehandler fillpartial 0
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+ testfilehandler fill 0
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+} -cleanup {
+ testfilehandler close
+} -result {{0 1} {0 2} {0 2}}
+test event-1.3 {Tcl_DeleteFileHandler} -setup {
+ testfilehandler close
+ set result ""
+} -constraints {testfilehandler nonPortable} -body {
+ testfilehandler create 2 disabled disabled
+ testfilehandler create 1 readable writable
+ testfilehandler create 0 disabled disabled
+ testfilehandler fillpartial 1
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+ testfilehandler create 1 off off
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+} -cleanup {
+ testfilehandler close
+} -result {{0 1} {1 1} {1 2} {0 0}}
+
+test event-2.1 {Tcl_DeleteFileHandler} -setup {
+ testfilehandler close
+ set result ""
+} -constraints {testfilehandler nonPortable} -body {
+ testfilehandler create 2 disabled disabled
+ testfilehandler create 1 readable writable
+ testfilehandler fillpartial 1
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+ testfilehandler create 1 off off
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+} -cleanup {
+ testfilehandler close
+} -result {{0 1} {1 1} {1 2} {0 0}}
+test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} -setup {
+ testfilehandler close
+ set result ""
+} -constraints {testfilehandler nonPortable} -body {
+ testfilehandler create 0 readable writable
+ testfilehandler fillpartial 0
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+ testfilehandler close
+ testfilehandler create 0 readable writable
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+} -cleanup {
+ testfilehandler close
+} -result {{0 1} {0 0}}
+
+test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off} -setup {
+ testfilehandler close
+} -constraints {testfilehandler} -body {
+ testfilehandler create 1 readable writable
+ testfilehandler fillpartial 1
+ testfilehandler windowevent
+ testfilehandler counts 1
+} -cleanup {
+ testfilehandler close
+} -result {0 0}
+
+test event-4.1 {FileHandlerEventProc, race between event and disabling} -setup {
+ update
+ testfilehandler close
+ set result ""
+} -constraints {testfilehandler nonPortable} -body {
+ testfilehandler create 2 disabled disabled
+ testfilehandler create 1 readable writable
+ testfilehandler fillpartial 1
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+ testfilehandler create 1 disabled disabled
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 1]
+} -cleanup {
+ testfilehandler close
+} -result {{0 1} {1 1} {1 2} {0 0}}
+test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} -setup {
+ update
+ testfilehandler close
+} -constraints {testfilehandler nonPortable} -body {
+ testfilehandler create 1 readable writable
+ testfilehandler create 2 readable writable
+ testfilehandler fillpartial 1
+ testfilehandler fillpartial 2
+ testfilehandler oneevent
+ set result ""
+ lappend result [testfilehandler counts 1] [testfilehandler counts 2]
+ testfilehandler windowevent
+ lappend result [testfilehandler counts 1] [testfilehandler counts 2]
+} -cleanup {
+ testfilehandler close
+} -result {{0 0} {0 1} {0 0} {0 1}}
+update
+
+test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} -setup {
+ catch {rename bgerror {}}
+} -body {
+ proc bgerror msg {
+ global errorInfo errorCode x
+ lappend x [list $msg $errorInfo $errorCode]
+ }
+ after idle {error "a simple error"}
+ after idle {open non_existent}
+ after idle {set errorInfo foobar; set errorCode xyzzy}
+ set x {}
+ update idletasks
+ regsub -all [file join {} non_existent] $x "non_existent"
+} -cleanup {
+ rename bgerror {}
+} -result {{{a simple error} {a simple error
+ while executing
+"error "a simple error""
+ ("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
+ while executing
+"open non_existent"
+ ("after" script)} {POSIX ENOENT {no such file or directory}}}}
+test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} -setup {
+ catch {rename bgerror {}}
+} -body {
+ proc bgerror msg {
+ global x
+ lappend x $msg
+ return -code break
+ }
+ after idle {error "a simple error"}
+ after idle {open non_existent}
+ set x {}
+ update idletasks
+ return $x
+} -cleanup {
+ rename bgerror {}
+} -result {{a simple error}}
+test event-5.3 {HandleBgErrors: [Bug 1670155]} -setup {
+ variable x
+ proc demo args {variable x done}
+ variable target [list [namespace which demo] x]
+ proc trial args {variable target; string length $target}
+ trace add execution demo enter [namespace code trial]
+ variable save [interp bgerror {}]
+ interp bgerror {} $target
+} -body {
+ after 0 {error bar}
+ vwait [namespace which -variable x]
+} -cleanup {
+ interp bgerror {} $save
+ unset x target save
+ rename demo {}
+ rename trial {}
+} -result {}
+test event-5.3.1 {Default [interp bgerror] handler} -body {
+ ::tcl::Bgerror
+} -returnCodes error -match glob -result {*msg options*}
+test event-5.4 {Default [interp bgerror] handler} -body {
+ ::tcl::Bgerror {}
+} -returnCodes error -match glob -result {*msg options*}
+test event-5.5 {Default [interp bgerror] handler} -body {
+ ::tcl::Bgerror {} {} {}
+} -returnCodes error -match glob -result {*msg options*}
+test event-5.6 {Default [interp bgerror] handler} -body {
+ ::tcl::Bgerror {} {}
+} -returnCodes error -match glob -result {*-level*}
+test event-5.7 {Default [interp bgerror] handler} -body {
+ ::tcl::Bgerror {} {-level foo}
+} -returnCodes error -match glob -result {*expected integer*}
+test event-5.8 {Default [interp bgerror] handler} -body {
+ ::tcl::Bgerror {} {-level 0}
+} -returnCodes error -match glob -result {*-code*}
+test event-5.9 {Default [interp bgerror] handler} -body {
+ ::tcl::Bgerror {} {-level 0 -code ok}
+} -returnCodes error -match glob -result {*expected integer*}
+test event-5.10 {Default [interp bgerror] handler} -body {
+ proc bgerror {m} {append ::res $m}
+ set ::res {}
+ ::tcl::Bgerror {} {-level 0 -code 0}
+ return $::res
+} -cleanup {
+ rename bgerror {}
+} -result {}
+test event-5.11 {Default [interp bgerror] handler} -body {
+ proc bgerror {m} {append ::res $m}
+ set ::res {}
+ ::tcl::Bgerror msg {-level 0 -code 1}
+ return $::res
+} -cleanup {
+ rename bgerror {}
+} -result {msg}
+test event-5.12 {Default [interp bgerror] handler} -body {
+ proc bgerror {m} {append ::res $m}
+ set ::res {}
+ ::tcl::Bgerror msg {-level 0 -code 2}
+ return $::res
+} -cleanup {
+ rename bgerror {}
+} -result {command returned bad code: 2}
+test event-5.13 {Default [interp bgerror] handler} -body {
+ proc bgerror {m} {append ::res $m}
+ set ::res {}
+ ::tcl::Bgerror msg {-level 0 -code 3}
+ return $::res
+} -cleanup {
+ rename bgerror {}
+} -result {invoked "break" outside of a loop}
+test event-5.14 {Default [interp bgerror] handler} -body {
+ proc bgerror {m} {append ::res $m}
+ set ::res {}
+ ::tcl::Bgerror msg {-level 0 -code 4}
+ return $::res
+} -cleanup {
+ rename bgerror {}
+} -result {invoked "continue" outside of a loop}
+test event-5.15 {Default [interp bgerror] handler} -body {
+ proc bgerror {m} {append ::res $m}
+ set ::res {}
+ ::tcl::Bgerror msg {-level 0 -code 5}
+ return $::res
+} -cleanup {
+ rename bgerror {}
+} -result {command returned bad code: 5}
+
+test event-6.1 {BgErrorDeleteProc procedure} -setup {
+ catch {interp delete foo}
+ interp create foo
+ set erroutfile [makeFile Unmodified err.out]
+} -body {
+ foo eval [list set erroutfile $erroutfile]
+ foo eval {
+ proc bgerror args {
+ global errorInfo erroutfile
+ set f [open $erroutfile r+]
+ seek $f 0 end
+ puts $f "$args $errorInfo"
+ close $f
+ }
+ after 100 {error "first error"}
+ after 100 {error "second error"}
+ }
+ after 100 {interp delete foo}
+ after 200
+ update
+ set f [open $erroutfile r]
+ set result [read $f]
+ close $f
+ return $result
+} -cleanup {
+ removeFile $erroutfile
+} -result {Unmodified
+}
+
+test event-7.1 {bgerror / regular} {
+ set errRes {}
+ proc bgerror {err} {
+ global errRes
+ set errRes $err
+ }
+ after 0 {error err1}
+ vwait errRes
+ return $errRes
+} err1
+test event-7.2 {bgerror / accumulation} {
+ set errRes {}
+ proc bgerror {err} {
+ global errRes
+ lappend errRes $err
+ }
+ after 0 {error err1}
+ after 0 {error err2}
+ after 0 {error err3}
+ update
+ return $errRes
+} {err1 err2 err3}
+test event-7.3 {bgerror / accumulation / break} {
+ set errRes {}
+ proc bgerror {err} {
+ global errRes
+ lappend errRes $err
+ return -code break "skip!"
+ }
+ after 0 {error err1}
+ after 0 {error err2}
+ after 0 {error err3}
+ update
+ return $errRes
+} err1
+test event-7.4 {tkerror is nothing special anymore to tcl} -body {
+ set errRes {}
+ # we don't just rename bgerror to empty because it could then
+ # be autoloaded...
+ proc bgerror {err} {
+ global errRes
+ lappend errRes "bg:$err"
+ }
+ proc tkerror {err} {
+ global errRes
+ lappend errRes "tk:$err"
+ }
+ after 0 {error err1}
+ update
+ return $errRes
+} -cleanup {
+ rename tkerror {}
+} -result bg:err1
+test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} -body {
+ exec [interpreter] << {
+ after 1000 error hello
+ after 2000 set a 0
+ vwait a
+ }
+} -constraints {exec} -returnCodes error -result {hello
+ while executing
+"error hello"
+ ("after" script)}
+test event-7.6 {safe hidden bgerror fallback} -setup {
+ variable result {}
+ interp create -safe safe
+} -body {
+ safe alias puts puts
+ safe alias result ::append [namespace which -variable result]
+ safe eval {proc bgerror m {result $m\n$::errorCode\n$::errorInfo\n}}
+ safe hide bgerror
+ safe eval after 0 error foo
+ update
+ return $result
+} -cleanup {
+ interp delete safe
+} -result {foo
+NONE
+foo
+ while executing
+"error foo"
+ ("after" script)
+}
+test event-7.7 {safe hidden bgerror fallback} -setup {
+ variable result {}
+ interp create -safe safe
+} -body {
+ safe alias puts puts
+ safe alias result ::append [namespace which -variable result]
+ safe eval {proc bgerror m {result $m\n$::errorCode\n$::errorInfo\n}}
+ safe hide bgerror
+ safe eval {proc bgerror m {error bar soom baz}}
+ safe eval after 0 error foo
+ update
+ return $result
+} -cleanup {
+ interp delete safe
+} -result {foo
+NONE
+foo
+ while executing
+"error foo"
+ ("after" script)
+}
+
+# someday : add a test checking that when there is no bgerror, an error msg
+# goes to stderr ideally one would use sub interp and transfer a fake stderr
+# to it, unfortunatly the current interp tcl API does not allow that. The
+# other option would be to use fork a test but it then becomes more a
+# file/exec test than a bgerror test.
+
+# end of bgerror tests
+catch {rename bgerror {}}
+
+test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
+ set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
+ puts $child "testexithandler create 41; testexithandler create 4"
+ puts $child "testexithandler create 6; exit"
+ flush $child
+ set result [read $child]
+ close $child
+ return $result
+} {even 6
+even 4
+odd 41
+}
+
+test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
+ set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
+ puts $child "testexithandler create 41; testexithandler create 4"
+ puts $child "testexithandler create 6; testexithandler delete 41"
+ puts $child "testexithandler create 16; exit"
+ flush $child
+ set result [read $child]
+ close $child
+ return $result
+} {even 16
+even 6
+even 4
+}
+test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
+ set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
+ puts $child "testexithandler create 41; testexithandler create 4"
+ puts $child "testexithandler create 6; testexithandler delete 4"
+ puts $child "testexithandler create 16; exit"
+ flush $child
+ set result [read $child]
+ close $child
+ return $result
+} {even 16
+even 6
+odd 41
+}
+test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
+ set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
+ puts $child "testexithandler create 41; testexithandler create 4"
+ puts $child "testexithandler create 6; testexithandler delete 6"
+ puts $child "testexithandler create 16; exit"
+ flush $child
+ set result [read $child]
+ close $child
+ return $result
+} {even 16
+even 4
+odd 41
+}
+test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
+ set child [open |[list [interpreter]] r+]
+ puts $child "catch {load $::tcltestlib Tcltest}"
+ puts $child "testexithandler create 41; testexithandler delete 41"
+ puts $child "testexithandler create 16; exit"
+ flush $child
+ set result [read $child]
+ close $child
+ return $result
+} {even 16
+}
+
+test event-10.1 {Tcl_Exit procedure} {stdio} {
+ set child [open |[list [interpreter]] r+]
+ puts $child "exit 3"
+ list [catch {close $child} msg] $msg [lindex $::errorCode 0] \
+ [lindex $::errorCode 2]
+} {1 {child process exited abnormally} CHILDSTATUS 3}
+
+test event-11.1 {Tcl_VwaitCmd procedure} -returnCodes error -body {
+ vwait
+} -result {wrong # args: should be "vwait name"}
+test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body {
+ vwait a b
+} -result {wrong # args: should be "vwait name"}
+test event-11.3 {Tcl_VwaitCmd procedure} -setup {
+ catch {unset x}
+} -body {
+ set x 1
+ vwait x(1)
+} -returnCodes error -result {can't trace "x(1)": variable isn't array}
+test event-11.4 {Tcl_VwaitCmd procedure} -setup {
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 10; update; # On Mac make sure update won't take long
+} -body {
+ after 100 {set x x-done}
+ after 200 {set y y-done}
+ after 400 {set z z-done}
+ after idle {set q q-done}
+ set x before
+ set y before
+ set z before
+ set q before
+ list [vwait y] $x $y $z $q
+} -cleanup {
+ foreach i [after info] {
+ after cancel $i
+ }
+} -result {{} x-done y-done before q-done}
+test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} -setup {
+ set test1file [makeFile "" test1]
+} -constraints {socket} -body {
+ set f1 [open $test1file w]
+ proc accept {s args} {
+ puts $s foobar
+ close $s
+ }
+ set s1 [socket -server accept -myaddr 127.0.0.1 0]
+ after 1000
+ set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]]
+ close $s1
+ set x 0
+ set y 0
+ set z 0
+ fileevent $s2 readable {incr z}
+ vwait z
+ fileevent $f1 writable {incr x; if {$y == 3} {set z done}}
+ fileevent $s2 readable {incr y; if {$x == 3} {set z done}}
+ vwait z
+ close $f1
+ close $s2
+ list $x $y $z
+} -cleanup {
+ removeFile $test1file
+} -result {3 3 done}
+test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
+ set test1file [makeFile "" test1]
+ set test2file [makeFile "" test2]
+ set f1 [open $test1file w]
+ set f2 [open $test2file w]
+ set x 0
+ set y 0
+ set z 0
+ update
+ fileevent $f1 writable {incr x; if {$y == 3} {set z done}}
+ fileevent $f2 writable {incr y; if {$x == 3} {set z done}}
+ vwait z
+ close $f1
+ close $f2
+ removeFile $test1file
+ removeFile $test2file
+ list $x $y $z
+} {3 3 done}
+test event-11.7 {Bug 16828b3744} {
+ after idle {
+ set ::t::v 1
+ namespace delete ::t
+ }
+ namespace eval ::t {
+ vwait ::t::v
+ }
+} {}
+test event-11.8 {Bug 16828b3744} -setup {
+ oo::class create A {
+ variable continue
+
+ method start {} {
+ after idle [self] destroy
+
+ set continue 0
+ vwait [namespace current]::continue
+ }
+ destructor {
+ set continue 1
+ }
+ }
+} -body {
+ [A new] start
+} -cleanup {
+ A destroy
+} -result {}
+
+test event-12.1 {Tcl_UpdateCmd procedure} -returnCodes error -body {
+ update a b
+} -result {wrong # args: should be "update ?idletasks?"}
+test event-12.2 {Tcl_UpdateCmd procedure} -returnCodes error -body {
+ update bogus
+} -result {bad option "bogus": must be idletasks}
+test event-12.3 {Tcl_UpdateCmd procedure} -setup {
+ foreach i [after info] {
+ after cancel $i
+ }
+} -body {
+ after 500 {set x after}
+ after idle {set y after}
+ after idle {set z "after, y = $y"}
+ set x before
+ set y before
+ set z before
+ update idletasks
+ list $x $y $z
+} -cleanup {
+ foreach i [after info] {
+ after cancel $i
+ }
+} -result {before after {after, y = after}}
+test event-12.4 {Tcl_UpdateCmd procedure} -setup {
+ foreach i [after info] {
+ after cancel $i
+ }
+} -body {
+ after 10; update; # On Mac make sure update won't take long
+ after 200 {set x x-done}
+ after 600 {set y y-done}
+ after idle {set z z-done}
+ set x before
+ set y before
+ set z before
+ after 300
+ update
+ list $x $y $z
+} -cleanup {
+ foreach i [after info] {
+ after cancel $i
+ }
+} -result {x-done before z-done}
+
+test event-13.1 {Tcl_WaitForFile procedure, readable} -setup {
+ foreach i [after info] {
+ after cancel $i
+ }
+ testfilehandler close
+} -constraints {testfilehandler} -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ set x "no timeout"
+ set result [testfilehandler wait 1 readable 0]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach i [after info] {
+ after cancel $i
+ }
+} -result {{} {no timeout}}
+test event-13.2 {Tcl_WaitForFile procedure, readable} -setup {
+ foreach i [after info] {
+ after cancel $i
+ }
+ testfilehandler close
+} -constraints testfilehandler -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ set x "no timeout"
+ set result [testfilehandler wait 1 readable 100]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach i [after info] {
+ after cancel $i
+ }
+} -result {{} timeout}
+test event-13.3 {Tcl_WaitForFile procedure, readable} -setup {
+ foreach i [after info] {
+ after cancel $i
+ }
+ testfilehandler close
+} -constraints testfilehandler -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ testfilehandler fillpartial 1
+ set x "no timeout"
+ set result [testfilehandler wait 1 readable 100]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach i [after info] {
+ after cancel $i
+ }
+} -result {readable {no timeout}}
+test event-13.4 {Tcl_WaitForFile procedure, writable} -setup {
+ foreach i [after info] {
+ after cancel $i
+ }
+ testfilehandler close
+} -constraints {testfilehandler nonPortable} -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ testfilehandler fill 1
+ set x "no timeout"
+ set result [testfilehandler wait 1 writable 0]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach i [after info] {
+ after cancel $i
+ }
+} -result {{} {no timeout}}
+test event-13.5 {Tcl_WaitForFile procedure, writable} -setup {
+ foreach i [after info] {
+ after cancel $i
+ }
+ testfilehandler close
+} -constraints {testfilehandler nonPortable} -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ testfilehandler fill 1
+ set x "no timeout"
+ set result [testfilehandler wait 1 writable 100]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach i [after info] {
+ after cancel $i
+ }
+} -result {{} timeout}
+test event-13.6 {Tcl_WaitForFile procedure, writable} -setup {
+ foreach i [after info] {
+ after cancel $i
+ }
+ testfilehandler close
+} -constraints testfilehandler -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ set x "no timeout"
+ set result [testfilehandler wait 1 writable 100]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach i [after info] {
+ after cancel $i
+ }
+} -result {writable {no timeout}}
+test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} -setup {
+ foreach i [after info] {
+ after cancel $i
+ }
+ testfilehandler close
+} -constraints testfilehandler -body {
+ after 100 lappend x timeout
+ after idle lappend x idle
+ testfilehandler create 1 off off
+ set x ""
+ set result [list [testfilehandler wait 1 readable 200] $x]
+ update
+ lappend result $x
+} -cleanup {
+ testfilehandler close
+ foreach i [after info] {
+ after cancel $i
+ }
+} -result {{} {} {timeout idle}}
+test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} testfilewait {
+ set f [open "|sleep 2" r]
+ set result ""
+ lappend result [testfilewait $f readable 100]
+ lappend result [testfilewait $f readable -1]
+ close $f
+ return $result
+} {{} readable}
+
+test event-14.1 {Tcl_WaitForFile procedure, readable, big fd} -setup {
+ set chanList {}
+ for {set i 0} {$i < 32} {incr i} {
+ lappend chanList [open /dev/null r]
+ }
+ foreach i [after info] {after cancel $i}
+ testfilehandler close
+} -constraints {testfilehandler unix} -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ set x "no timeout"
+ set result [testfilehandler wait 1 readable 0]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach chan $chanList {close $chan}
+ foreach i [after info] {after cancel $i}
+} -result {{} {no timeout}}
+test event-14.2 {Tcl_WaitForFile procedure, readable, big fd} -setup {
+ set chanList {}
+ for {set i 0} {$i < 32} {incr i} {
+ lappend chanList [open /dev/null r]
+ }
+ foreach i [after info] {after cancel $i}
+ testfilehandler close
+} -constraints {testfilehandler unix} -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ set x "no timeout"
+ set result [testfilehandler wait 1 readable 100]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach chan $chanList {close $chan}
+ foreach i [after info] {after cancel $i}
+} -result {{} timeout}
+test event-14.3 {Tcl_WaitForFile procedure, readable, big fd} -setup {
+ set chanList {}
+ for {set i 0} {$i < 32} {incr i} {
+ lappend chanList [open /dev/null r]
+ }
+ foreach i [after info] {after cancel $i}
+ testfilehandler close
+} -constraints {testfilehandler unix} -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ testfilehandler fillpartial 1
+ set x "no timeout"
+ set result [testfilehandler wait 1 readable 100]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach chan $chanList {close $chan}
+ foreach i [after info] {after cancel $i}
+} -result {readable {no timeout}}
+test event-14.4 {Tcl_WaitForFile procedure, writable, big fd} -setup {
+ set chanList {}
+ for {set i 0} {$i < 32} {incr i} {
+ lappend chanList [open /dev/null r]
+ }
+ foreach i [after info] {after cancel $i}
+ testfilehandler close
+} -constraints {testfilehandler unix nonPortable} -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ testfilehandler fill 1
+ set x "no timeout"
+ set result [testfilehandler wait 1 writable 0]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach chan $chanList {close $chan}
+ foreach i [after info] {after cancel $i}
+} -result {{} {no timeout}}
+test event-14.5 {Tcl_WaitForFile procedure, writable, big fd} -setup {
+ set chanList {}
+ for {set i 0} {$i < 32} {incr i} {
+ lappend chanList [open /dev/null r]
+ }
+ foreach i [after info] {after cancel $i}
+ testfilehandler close
+} -constraints {testfilehandler unix nonPortable} -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ testfilehandler fill 1
+ set x "no timeout"
+ set result [testfilehandler wait 1 writable 100]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach chan $chanList {close $chan}
+ foreach i [after info] {after cancel $i}
+} -result {{} timeout}
+test event-14.6 {Tcl_WaitForFile procedure, writable, big fd} -setup {
+ set chanList {}
+ for {set i 0} {$i < 32} {incr i} {
+ lappend chanList [open /dev/null r]
+ }
+ foreach i [after info] {after cancel $i}
+ testfilehandler close
+} -constraints {testfilehandler unix} -body {
+ after 100 set x timeout
+ testfilehandler create 1 off off
+ set x "no timeout"
+ set result [testfilehandler wait 1 writable 100]
+ update
+ list $result $x
+} -cleanup {
+ testfilehandler close
+ foreach chan $chanList {close $chan}
+ foreach i [after info] {after cancel $i}
+} -result {writable {no timeout}}
+test event-14.7 {Tcl_WaitForFile, don't call other event handlers, big fd} -setup {
+ set chanList {}
+ for {set i 0} {$i < 32} {incr i} {
+ lappend chanList [open /dev/null r]
+ }
+ foreach i [after info] {after cancel $i}
+ testfilehandler close
+} -constraints {testfilehandler unix} -body {
+ after 100 lappend x timeout
+ after idle lappend x idle
+ testfilehandler create 1 off off
+ set x ""
+ set result [list [testfilehandler wait 1 readable 200] $x]
+ update
+ lappend result $x
+} -cleanup {
+ testfilehandler close
+ foreach chan $chanList {close $chan}
+ foreach i [after info] {after cancel $i}
+} -result {{} {} {timeout idle}}
+test event-14.8 {Tcl_WaitForFile procedure, waiting indefinitely, big fd} -setup {
+ set chanList {}
+ for {set i 0} {$i < 32} {incr i} {
+ lappend chanList [open /dev/null r]
+ }
+} -constraints {testfilewait unix} -body {
+ set f [open "|sleep 2" r]
+ set result ""
+ lappend result [testfilewait $f readable 100]
+ lappend result [testfilewait $f readable -1]
+ close $f
+ return $result
+} -cleanup {
+ foreach chan $chanList {close $chan}
+} -result {{} readable}
+\f
+# cleanup
+foreach i [after info] {
+ after cancel $i
+}
+::tcltest::cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
OSDN Git Service
