diff options
Diffstat (limited to 'tests/event.test')
| -rw-r--r-- | tests/event.test | 419 |
1 files changed, 374 insertions, 45 deletions
diff --git a/tests/event.test b/tests/event.test index 44d6610..a7122f9 100644 --- a/tests/event.test +++ b/tests/event.test @@ -8,20 +8,13 @@ # # 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.13 2001/07/31 19:12:07 vincentdarley Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import -force ::tcltest::* -set ::tcltest::testConstraints(testfilehandler) \ - [expr {[info commands testfilehandler] != {}}] -set ::tcltest::testConstraints(testexithandler) \ - [expr {[info commands testexithandler] != {}}] -set ::tcltest::testConstraints(testfilewait) \ - [expr {[info commands testfilewait] != {}}] +testConstraint testfilehandler [llength [info commands testfilehandler]] +testConstraint testexithandler [llength [info commands testexithandler]] +testConstraint testfilewait [llength [info commands testfilewait]] test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} { testfilehandler close @@ -193,14 +186,96 @@ test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} { rename bgerror {} set x } {{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} { + proc bgerror {m} {append ::res $m} + set ::res {} + ::tcl::Bgerror {} {-level 0 -code 0} + rename bgerror {} + set ::res +} {} +test event-5.11 {Default [interp bgerror] handler} { + proc bgerror {m} {append ::res $m} + set ::res {} + ::tcl::Bgerror msg {-level 0 -code 1} + rename bgerror {} + set ::res +} {msg} +test event-5.12 {Default [interp bgerror] handler} { + proc bgerror {m} {append ::res $m} + set ::res {} + ::tcl::Bgerror msg {-level 0 -code 2} + rename bgerror {} + set ::res +} {command returned bad code: 2} +test event-5.13 {Default [interp bgerror] handler} { + proc bgerror {m} {append ::res $m} + set ::res {} + ::tcl::Bgerror msg {-level 0 -code 3} + rename bgerror {} + set ::res +} {invoked "break" outside of a loop} +test event-5.14 {Default [interp bgerror] handler} { + proc bgerror {m} {append ::res $m} + set ::res {} + ::tcl::Bgerror msg {-level 0 -code 4} + rename bgerror {} + set ::res +} {invoked "continue" outside of a loop} +test event-5.15 {Default [interp bgerror] handler} { + proc bgerror {m} {append ::res $m} + set ::res {} + ::tcl::Bgerror msg {-level 0 -code 5} + rename bgerror {} + set ::res +} {command returned bad code: 5} test event-6.1 {BgErrorDeleteProc procedure} { catch {interp delete foo} interp create foo + set erroutfile [makeFile Unmodified err.out] + foo eval [list set erroutfile $erroutfile] foo eval { proc bgerror args { - global errorInfo - set f [open err.out r+] + global errorInfo erroutfile + set f [open $erroutfile r+] seek $f 0 end puts $f "$args $errorInfo" close $f @@ -208,14 +283,13 @@ test event-6.1 {BgErrorDeleteProc procedure} { 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 f [open $erroutfile r] set result [read $f] close $f - removeFile err.out + removeFile $erroutfile set result } {Unmodified } @@ -276,6 +350,61 @@ test event-7.4 {tkerror is nothing special anymore to tcl} { 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 [interpreter] << $script} errMsg] $errMsg +} {1 {hello + while executing +"error hello" + ("after" script)}} + +test event-7.6 {safe hidden bgerror fallback} { + variable result {} + interp create -safe safe + 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 + interp delete safe + set result +} {foo +NONE +foo + while executing +"error foo" + ("after" script) +} + +test event-7.7 {safe hidden bgerror fallback} { + variable result {} + interp create -safe safe + 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 + interp delete safe + set 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 @@ -288,7 +417,7 @@ catch {rename bgerror {}} test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} { - set child [open |[list [info nameofexecutable]] r+] + set child [open |[list [interpreter]] r+] puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; exit" flush $child @@ -301,7 +430,7 @@ odd 41 } test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { - set child [open |[list [info nameofexecutable]] r+] + set child [open |[list [interpreter]] r+] puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 41" puts $child "testexithandler create 16; exit" @@ -314,7 +443,7 @@ even 6 even 4 } test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { - set child [open |[list [info nameofexecutable]] r+] + set child [open |[list [interpreter]] r+] puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 4" puts $child "testexithandler create 16; exit" @@ -327,7 +456,7 @@ even 6 odd 41 } test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { - set child [open |[list [info nameofexecutable]] r+] + set child [open |[list [interpreter]] r+] puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 6" puts $child "testexithandler create 16; exit" @@ -340,7 +469,7 @@ even 4 odd 41 } test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { - set child [open |[list [info nameofexecutable]] r+] + set child [open |[list [interpreter]] r+] puts $child "testexithandler create 41; testexithandler delete 41" puts $child "testexithandler create 16; exit" flush $child @@ -351,10 +480,10 @@ test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { } test event-10.1 {Tcl_Exit procedure} {stdio} { - set child [open |[list [info nameofexecutable]] r+] + set child [open |[list [interpreter]] r+] puts $child "exit 3" - list [catch {close $child} msg] $msg [lindex $errorCode 0] \ - [lindex $errorCode 2] + 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} { @@ -389,42 +518,45 @@ foreach i [after info] { } test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} { - set f1 [open test1 w] + set test1file [makeFile "" test1] + set f1 [open $test1file w] proc accept {s args} { puts $s foobar close $s } - catch {set s1 [socket -server accept 0]} + catch {set s1 [socket -server accept -myaddr 127.0.0.1 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 } + 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 } } + 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 + removeFile $test1file 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 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 } } + 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 + removeFile $test1file + removeFile $test2file list $x $y $z } {3 3 done} @@ -571,21 +703,218 @@ test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} testfilewait { set result } {{} readable} -# cleanup -foreach i [after info] { - after cancel $i -} -::tcltest::cleanupTests -return - - +test event-14.1 {Tcl_WaitForFile procedure, readable, big fd} \ + -constraints {testfilehandler unix} \ + -setup { + set chanList {} + for {set i 0} {$i < 32} {incr i} { + lappend chanList [open /dev/null r] + } + } \ + -body { + 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 + } \ + -result {{} {no timeout}} \ + -cleanup { + foreach chan $chanList {close $chan} + } +test event-14.2 {Tcl_WaitForFile procedure, readable, big fd} \ + -constraints {testfilehandler unix} \ + -setup { + set chanList {} + for {set i 0} {$i < 32} {incr i} { + lappend chanList [open /dev/null r] + } + } \ + -body { + 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 + } \ + -result {{} timeout} \ + -cleanup { + foreach chan $chanList {close $chan} + } +test event-14.3 {Tcl_WaitForFile procedure, readable, big fd} \ + -constraints {testfilehandler unix} \ + -setup { + set chanList {} + for {set i 0} {$i < 32} {incr i} { + lappend chanList [open /dev/null r] + } + } \ + -body { + 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 + } \ + -result {readable {no timeout}} \ + -cleanup { + foreach chan $chanList {close $chan} + } +test event-14.4 {Tcl_WaitForFile procedure, writable, big fd} \ + -constraints {testfilehandler unix nonPortable} \ + -setup { + set chanList {} + for {set i 0} {$i < 32} {incr i} { + lappend chanList [open /dev/null r] + } + } \ + -body { + 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 $ + } \ + -result {{} {no timeout}} \ + -cleanup { + foreach chan $chanList {close $chan} + } +test event-14.5 {Tcl_WaitForFile procedure, writable, big fd} \ + -constraints {testfilehandler unix nonPortable} \ + -setup { + set chanList {} + for {set i 0} {$i < 32} {incr i} { + lappend chanList [open /dev/null r] + } + } \ + -body { + 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 + } \ + -result {{} timeout} \ + -cleanup { + foreach chan $chanList {close $chan} + } +test event-14.6 {Tcl_WaitForFile procedure, writable, big fd} \ + -constraints {testfilehandler unix} \ + -setup { + set chanList {} + for {set i 0} {$i < 32} {incr i} { + lappend chanList [open /dev/null r] + } + } \ + -body { + 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 + } \ + -result {writable {no timeout}} \ + -cleanup { + foreach chan $chanList {close $chan} + } +test event-14.7 {Tcl_WaitForFile, don't call other event handlers, big fd} \ + -constraints {testfilehandler unix} \ + -setup { + set chanList {} + for {set i 0} {$i < 32} {incr i} { + lappend chanList [open /dev/null r] + } + } \ + -body { + 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 + } \ + -result {{} {} {timeout idle}} \ + -cleanup { + foreach chan $chanList {close $chan} + } +test event-14.8 {Tcl_WaitForFile procedure, waiting indefinitely, big fd} \ + -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 + set result + } \ + -setup { + set chanList {} + for {set i 0} {$i < 32} {incr i} { + lappend chanList [open /dev/null r] + } + } \ + -result {{} readable} \ + -cleanup { + foreach chan $chanList {close $chan} + } +# cleanup +foreach i [after info] { + after cancel $i +} +::tcltest::cleanupTests +return |