summaryrefslogtreecommitdiffstats
path: root/tests/io.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/io.test')
-rw-r--r--tests/io.test99
1 files changed, 64 insertions, 35 deletions
diff --git a/tests/io.test b/tests/io.test
index f1248b9..023af06 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...
@@ -1707,8 +1711,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
@@ -1733,8 +1737,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} {
@@ -2261,7 +2265,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} {
@@ -2781,6 +2785,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
@@ -6756,7 +6780,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]
@@ -7520,6 +7544,25 @@ test io-53.11 {Bug 2895565} -setup {
removeFile out
removeFile in
} -result {40 bytes copied}
+test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix openpipe fcopy} {
+ file delete $path(pipe)
+ set f1 [open $path(pipe) w]
+ puts -nonewline $f1 {
+ fconfigure stdin -translation binary -blocking 0
+ fconfigure stdout -buffering none -translation binary
+ fcopy stdin stdout
+ }
+ close $f1
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
+ fconfigure $f1 -translation binary -buffering none
+ puts -nonewline $f1 A
+ after 2000 {set ::done timeout}
+ fileevent $f1 readable {set ::done ok}
+ vwait ::done
+ set ch [read $f1 1]
+ close $f1
+ list $::done $ch
+} {ok A}
test io-54.1 {Recursive channel events} {socket fileevent} {
# This test checks to see if file events are delivered during recursive
@@ -7762,7 +7805,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]
@@ -7854,25 +7897,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]
@@ -7881,16 +7906,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
@@ -8089,20 +8115,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
}