# 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.18 2002/07/02 19:10:57 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } ::tcltest::testConstraint testfilehandler \ [expr {[info commands testfilehandler] != {}}] ::tcltest::testConstraint testexithandler \ [expr {[info commands testexithandler] != {}}] ::tcltest::testConstraint 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 {} regsub -all [file join {} non_existent] $x "non_existent" x 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 testConstraint exec [llength [info commands exec]] test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} {exec} { set script { after 1000 error hello after 2000 set a 0 vwait a } list [catch {exec [info nameofexecutable] << $script} errMsg] $errMsg } {1 {hello while executing "error hello" ("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 [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 } catch {set s1 [socket -server accept 0]} after 1000 catch {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 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