diff options
Diffstat (limited to 'tests/io.test')
| -rw-r--r-- | tests/io.test | 80 |
1 files changed, 45 insertions, 35 deletions
diff --git a/tests/io.test b/tests/io.test index cedb337..19cd9a5 100644 --- a/tests/io.test +++ b/tests/io.test @@ -17,6 +17,10 @@ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -37,7 +41,7 @@ testConstraint fcopy [llength [info commands fcopy]] testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] -testConstraint testthread [llength [info commands testthread]] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... @@ -1668,8 +1672,8 @@ test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { out } {err }} -# This test relies on the fact that the smallest available fd is used first. -test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unix} { +# This test relies on the fact that stdout is used before stderr +test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} { set f [open $path(test1) w] puts -nonewline $f { close stdin close stdout @@ -1694,8 +1698,8 @@ test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unix} { close $f2 set result } {{ close stdin -file1 -} {file2 +stdout +} {stderr }} catch {interp delete z} test io-14.5 {Tcl_GetChannel: stdio name translation} { @@ -2222,7 +2226,7 @@ test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel openpipe} { set f [open "|[list [interpreter] $path(script)]" r] set l [gets $f] close $f - set l + lsort $l } {file1 file2} test io-29.1 {Tcl_WriteChars, channel not writable} { @@ -2742,6 +2746,26 @@ test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} { close $f set r } "hello\nbye\nstrange\n" +set path(script2) [makeFile {} script2] +test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} { + set f [open $path(script) w] + puts $f { + fconfigure stdout -blocking 0 + puts -nonewline stdout [string repeat A 655360] + flush stdout + } + close $f + set f [open $path(script2) w] + puts $f {after 2000} + close $f + set t1 [clock milliseconds] + set ff [open "|[list [interpreter] $path(script2)]" w] + catch {unset ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT)} + exec [interpreter] $path(script) >@ $ff + set t2 [clock milliseconds] + close $ff + expr {($t2-$t1)/2000 ? $t2-$t1 : 0} +} 0 test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} { variable c 0 variable x running @@ -6665,7 +6689,7 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { } set result } {0 0 ok} -test io-52.5b {TclCopyChannel, all, wrapped to negative value} {fcopy} { +test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] @@ -7668,7 +7692,7 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} { # More complicated tests (like that the reference changes as a # channel is moved from thread to thread) can be done only in the # extension which fully implements the moving of channels between - # threads, i.e. 'Threads'. Or we have to extend [testthread] as well. + # threads, i.e. 'Threads'. set f [open $path(longfile) r] set result [testchannel mthread $f] @@ -7760,25 +7784,7 @@ test io-70.0 {Cutting & Splicing channels} {testchannel} { } {0 1 0} -# Duplicate of code in "thread.test". Find a better way of doing this -# without duplication. Maybe placement into a proc which transforms to -# nop after the first call, and placement of its defintion in a -# central location. - -if {[testConstraint testthread]} { - testthread errorproc ThreadError - - proc ThreadError {id info} { - global threadError - set threadError $info - } - - proc ThreadNullError {id info} { - # ignore - } -} - -test io-70.1 {Transfer channel} {testchannel testthread} { +test io-70.1 {Transfer channel} {testchannel thread} { set f [makeFile {... dummy ...} cutsplice] set c [open $f r] @@ -7787,16 +7793,17 @@ test io-70.1 {Transfer channel} {testchannel testthread} { testchannel cut $c lappend res [catch {seek $c 0 start}] - set tid [testthread create] - testthread send $tid [list set c $c] - lappend res [testthread send $tid { + set tid [thread::create -preserved] + thread::send $tid [list set c $c] + thread::send $tid {load {} Tcltest} + lappend res [thread::send $tid { testchannel splice $c set res [catch {seek $c 0 start}] close $c set res }] - tcltest::threadReap + thread::release $tid removeFile cutsplice set res @@ -7995,20 +8002,23 @@ test io-73.1 {channel Tcl_Obj SetChannelFromAny} {} { catch {close [lreplace [list a] 0 end]} } {1} -test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} {} { +test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup { # Invalidate intrep of 'channel' Tcl_Obj when transiting between interpreters. - interp create foo set f [open [info script] r] +} -body { + interp create foo seek $f 0 set code [catch {interp eval foo [list seek $f 0]} msg] # The string map converts the changing channel handle to a fixed string list $code [string map [list $f @@] $msg] -} {1 {can not find channel named "@@"}} +} -cleanup { + close $f +} -result {1 {can not find channel named "@@"}} # ### ### ### ######### ######### ######### # cleanup -foreach file [list fooBar longfile script output test1 pipe my_script \ +foreach file [list fooBar longfile script script2 output test1 pipe my_script \ test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { removeFile $file } |