diff options
Diffstat (limited to 'tests/event.test')
| -rw-r--r-- | tests/event.test | 589 |
1 files changed, 0 insertions, 589 deletions
diff --git a/tests/event.test b/tests/event.test deleted file mode 100644 index d75c959..0000000 --- a/tests/event.test +++ /dev/null @@ -1,589 +0,0 @@ -# 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. -# -# RCS: @(#) $Id: event.test,v 1.4 1999/04/16 00:47:26 stanton Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] -} - -set ::tcltest::testConfig(testfilehandler) \ - [expr {[info commands testfilehandler] != {}}] -set ::tcltest::testConfig(testexithandler) \ - [expr {[info commands testexithandler] != {}}] -set ::tcltest::testConfig(testfilewait) \ - [expr {[info commands testfilewait] != {}}] - - -test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} { - 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} {testfilehandler 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} {testfilehandler 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} {testfilehandler 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} \ - {testfilehandler 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} { - 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} \ - {testfilehandler 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} \ - {testfilehandler 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}} -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 {}} - - -test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} { - 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 testexithandler} { - 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 testexithandler} { - 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 testexithandler} { - 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 testexithandler} { - 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 5001] - set s2 [socket 127.0.0.1 5001] - 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} - -test event-13.1 {Tcl_WaitForFile procedure, readable} {testfilehandler} { - 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} testfilehandler { - 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} testfilehandler { - 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} \ - {testfilehandler 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} \ - {testfilehandler 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} testfilehandler { - 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} testfilehandler { - 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}} - -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 - set result -} {{} readable} - -# cleanup -foreach i [after info] { - after cancel $i -} -::tcltest::cleanupTests -return - - - - - - - - - - - - |