summaryrefslogtreecommitdiffstats
path: root/tests/event.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/event.test')
-rw-r--r--tests/event.test567
1 files changed, 567 insertions, 0 deletions
diff --git a/tests/event.test b/tests/event.test
new file mode 100644
index 0000000..027f7e0
--- /dev/null
+++ b/tests/event.test
@@ -0,0 +1,567 @@
+# 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.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# "@(#) event.test 1.35 97/08/11 11:58:38"
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+if {[catch {testfilehandler create 0 off off}] == 0 } {
+ test event-1.1 {Tcl_CreateFileHandler, reading} {
+ testfilehandler close
+ testfilehandler create 0 readable off
+ testfilehandler clear 0
+ testfilehandler oneevent
+ set result ""
+ lappend result [testfilehandler counts 0]
+ testfilehandler fillpartial 0
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+ testfilehandler close
+ set result
+ } {{0 0} {1 0} {2 0}}
+ test event-1.2 {Tcl_CreateFileHandler, writing} {nonPortable} {
+ # This test is non-portable because on some systems (e.g.
+ # SunOS 4.1.3) pipes seem to be writable always.
+ testfilehandler close
+ testfilehandler create 0 off writable
+ testfilehandler clear 0
+ testfilehandler oneevent
+ set result ""
+ 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]
+ testfilehandler close
+ set result
+ } {{0 1} {0 2} {0 2}}
+ test event-1.3 {Tcl_DeleteFileHandler} {nonPortable} {
+ testfilehandler close
+ testfilehandler create 2 disabled disabled
+ testfilehandler create 1 readable writable
+ testfilehandler create 0 disabled disabled
+ testfilehandler fillpartial 1
+ set result ""
+ 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]
+ testfilehandler close
+ set result
+ } {{0 1} {1 1} {1 2} {0 0}}
+
+ test event-2.1 {Tcl_DeleteFileHandler} {nonPortable} {
+ testfilehandler close
+ testfilehandler create 2 disabled disabled
+ testfilehandler create 1 readable writable
+ testfilehandler fillpartial 1
+ set result ""
+ 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]
+ testfilehandler close
+ set result
+ } {{0 1} {1 1} {1 2} {0 0}}
+ test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} {nonPortable} {
+ testfilehandler close
+ testfilehandler create 0 readable writable
+ testfilehandler fillpartial 0
+ set result ""
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+ testfilehandler close
+ testfilehandler create 0 readable writable
+ testfilehandler oneevent
+ lappend result [testfilehandler counts 0]
+ testfilehandler close
+ set result
+ } {{0 1} {0 0}}
+
+ test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } {
+ testfilehandler close
+ testfilehandler create 1 readable writable
+ testfilehandler fillpartial 1
+ testfilehandler windowevent
+ set result [testfilehandler counts 1]
+ testfilehandler close
+ set result
+ } {0 0}
+
+ test event-4.1 {FileHandlerEventProc, race between event and disabling} {nonPortable} {
+ update
+ testfilehandler close
+ testfilehandler create 2 disabled disabled
+ testfilehandler create 1 readable writable
+ testfilehandler fillpartial 1
+ set result ""
+ 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]
+ testfilehandler close
+ set result
+ } {{0 1} {1 1} {1 2} {0 0}}
+ test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} {nonPortable} {
+ update
+ testfilehandler close
+ 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]
+ testfilehandler close
+ set result
+ } {{0 0} {0 1} {0 0} {0 1}}
+ testfilehandler close
+ update
+}
+
+test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
+ catch {rename bgerror {}}
+ 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
+ rename bgerror {}
+ set x
+} {{{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} {
+ catch {rename bgerror {}}
+ 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
+ rename bgerror {}
+ set x
+} {{a simple error}}
+
+test event-6.1 {BgErrorDeleteProc procedure} {
+ catch {interp delete foo}
+ interp create foo
+ foo eval {
+ proc bgerror args {
+ global errorInfo
+ set f [open err.out r+]
+ seek $f 0 end
+ puts $f "$args $errorInfo"
+ close $f
+ }
+ after 100 {error "first error"}
+ after 100 {error "second error"}
+ }
+ makeFile Unmodified err.out
+ after 100 {interp delete foo}
+ after 200
+ update
+ set f [open err.out r]
+ set result [read $f]
+ close $f
+ removeFile err.out
+ set result
+} {Unmodified
+}
+
+test event-7.1 {bgerror / regular} {
+ set errRes {}
+ proc bgerror {err} {
+ global errRes;
+ set errRes $err;
+ }
+ after 0 {error err1}
+ vwait errRes;
+ set 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
+ set 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
+ set errRes;
+} err1
+
+test event-7.4 {tkerror is nothing special anymore to tcl} {
+ 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
+ rename tkerror {}
+ set errRes
+} bg:err1
+
+# 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 {}}
+
+
+if {[info commands testexithandler] != ""} {
+ test event-8.1 {Tcl_CreateExitHandler procedure} {stdio} {
+ set child [open |[list [info nameofexecutable]] r+]
+ puts $child "testexithandler create 41; testexithandler create 4"
+ puts $child "testexithandler create 6; exit"
+ flush $child
+ set result [read $child]
+ close $child
+ set result
+ } {even 6
+even 4
+odd 41
+}
+
+ test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio} {
+ set child [open |[list [info nameofexecutable]] r+]
+ 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
+ set result
+ } {even 16
+even 6
+even 4
+}
+ test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio} {
+ set child [open |[list [info nameofexecutable]] r+]
+ 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
+ set result
+ } {even 16
+even 6
+odd 41
+}
+ test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio} {
+ set child [open |[list [info nameofexecutable]] r+]
+ 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
+ set result
+ } {even 16
+even 4
+odd 41
+}
+ test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio} {
+ set child [open |[list [info nameofexecutable]] r+]
+ puts $child "testexithandler create 41; testexithandler delete 41"
+ puts $child "testexithandler create 16; exit"
+ flush $child
+ set result [read $child]
+ close $child
+ set result
+ } {even 16
+}
+}
+
+test event-10.1 {Tcl_Exit procedure} {stdio} {
+ set child [open |[list [info nameofexecutable]] 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} {
+ list [catch {vwait} msg] $msg
+} {1 {wrong # args: should be "vwait name"}}
+test event-11.2 {Tcl_VwaitCmd procedure} {
+ list [catch {vwait a b} msg] $msg
+} {1 {wrong # args: should be "vwait name"}}
+test event-11.3 {Tcl_VwaitCmd procedure} {
+ catch {unset x}
+ set x 1
+ list [catch {vwait x(1)} msg] $msg
+} {1 {can't trace "x(1)": variable isn't array}}
+test event-11.4 {Tcl_VwaitCmd procedure} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 10; update; # On Mac make sure update won't take long
+ after 100 {set x x-done}
+ after 200 {set y y-done}
+ after 300 {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
+} {{} x-done y-done before q-done}
+
+foreach i [after info] {
+ after cancel $i
+}
+
+test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {
+ set f1 [open test1 w]
+ proc accept {s args} {
+ puts $s foobar
+ close $s
+ }
+ set s1 [socket -server accept 5000]
+ set s2 [socket 127.0.0.1 5000]
+ 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
+ file delete test1 test2
+ list $x $y $z
+} {3 3 done}
+test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
+ file delete test1 test2
+ set f1 [open test1 w]
+ set f2 [open test2 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
+ file delete test1 test2
+ list $x $y $z
+} {3 3 done}
+
+
+test event-12.1 {Tcl_UpdateCmd procedure} {
+ list [catch {update a b} msg] $msg
+} {1 {wrong # args: should be "update ?idletasks?"}}
+test event-12.2 {Tcl_UpdateCmd procedure} {
+ list [catch {update bogus} msg] $msg
+} {1 {bad option "bogus": must be idletasks}}
+test event-12.3 {Tcl_UpdateCmd procedure} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ 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
+} {before after {after, y = after}}
+test event-12.4 {Tcl_UpdateCmd procedure} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ 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
+} {x-done before z-done}
+
+if {[info commands testfilehandler] != ""} {
+ test event-13.1 {Tcl_WaitForFile procedure, readable} unixOnly {
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 100 set x timeout
+ testfilehandler close
+ testfilehandler create 1 off off
+ set x "no timeout"
+ set result [testfilehandler wait 1 readable 0]
+ update
+ testfilehandler close
+ list $result $x
+ } {{} {no timeout}}
+ test event-13.2 {Tcl_WaitForFile procedure, readable} unixOnly {
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 100 set x timeout
+ testfilehandler close
+ testfilehandler create 1 off off
+ set x "no timeout"
+ set result [testfilehandler wait 1 readable 100]
+ update
+ testfilehandler close
+ list $result $x
+ } {{} timeout}
+ test event-13.3 {Tcl_WaitForFile procedure, readable} unixOnly {
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 100 set x timeout
+ testfilehandler close
+ testfilehandler create 1 off off
+ testfilehandler fillpartial 1
+ set x "no timeout"
+ set result [testfilehandler wait 1 readable 100]
+ update
+ testfilehandler close
+ list $result $x
+ } {readable {no timeout}}
+ test event-13.4 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 100 set x timeout
+ testfilehandler close
+ testfilehandler create 1 off off
+ testfilehandler fill 1
+ set x "no timeout"
+ set result [testfilehandler wait 1 writable 0]
+ update
+ testfilehandler close
+ list $result $x
+ } {{} {no timeout}}
+ test event-13.5 {Tcl_WaitForFile procedure, writable} {unixOnly nonPortable} {
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 100 set x timeout
+ testfilehandler close
+ testfilehandler create 1 off off
+ testfilehandler fill 1
+ set x "no timeout"
+ set result [testfilehandler wait 1 writable 100]
+ update
+ testfilehandler close
+ list $result $x
+ } {{} timeout}
+ test event-13.6 {Tcl_WaitForFile procedure, writable} unixOnly {
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 100 set x timeout
+ testfilehandler close
+ testfilehandler create 1 off off
+ set x "no timeout"
+ set result [testfilehandler wait 1 writable 100]
+ update
+ testfilehandler close
+ list $result $x
+ } {writable {no timeout}}
+ test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} unixOnly {
+ foreach i [after info] {
+ after cancel $i
+ }
+ after 100 lappend x timeout
+ after idle lappend x idle
+ testfilehandler close
+ testfilehandler create 1 off off
+ set x ""
+ set result [list [testfilehandler wait 1 readable 200] $x]
+ update
+ testfilehandler close
+ lappend result $x
+ } {{} {} {timeout idle}}
+}
+
+if {[info commands testfilewait] != ""} {
+ test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} unixOnly {
+ set f [open "|sleep 2" r]
+ set result ""
+ lappend result [testfilewait $f readable 100]
+ lappend result [testfilewait $f readable -1]
+ close $f
+ set result
+ } {{} readable}
+}
+
+foreach i [after info] {
+ after cancel $i
+}