summaryrefslogtreecommitdiffstats
path: root/tests/io.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/io.test')
-rw-r--r--tests/io.test211
1 files changed, 194 insertions, 17 deletions
diff --git a/tests/io.test b/tests/io.test
index e0a2389..6314ace 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -268,7 +268,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} {
close $f
set x
} "\r\n12"
-test io-3.4 {WriteChars: loop over stage buffer} {
+test io-3.4 {WriteChars: loop over stage buffer} -body {
# stage buffer maps to more than can be queued at once.
set f [open $path(test1) w]
@@ -277,8 +277,10 @@ test io-3.4 {WriteChars: loop over stage buffer} {
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
-} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
-test io-3.5 {WriteChars: saved != 0} {
+} -cleanup {
+ catch {close $f}
+} -result [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
+test io-3.5 {WriteChars: saved != 0} -body {
# Bytes produced by UtfToExternal from end of last channel buffer
# had to be moved to beginning of next channel buffer to preserve
# requested buffersize.
@@ -289,7 +291,9 @@ test io-3.5 {WriteChars: saved != 0} {
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
-} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
+} -cleanup {
+ catch {close $f}
+} -result [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} {
# One incomplete UTF-8 character at end of staging buffer. Backup
# in src to the beginning of that UTF-8 character and try again.
@@ -307,7 +311,7 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} {
close $f
lappend x [contents $path(test1)]
} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"]
-test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
+test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body {
# When translating UTF-8 to external, the produced bytes went past end
# of the channel buffer. This is done purpose -- we then truncate the
# bytes at the end of the partial character to preserve the requested
@@ -320,7 +324,9 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
-} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
+} -cleanup {
+ catch {close $f}
+} -result [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.8 {WriteChars: reset sawLF after each buffer} {
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffering line -translation lf \
@@ -330,6 +336,15 @@ test io-3.8 {WriteChars: reset sawLF after each buffer} {
close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
+test io-3.9 {Write: flush line-buffered channels when crlf is split over two buffers} -body {
+ # https://core.tcl-lang.org/tcllib/tktedit?name=c9d8a52fe
+ set f [open $path(test1) w]
+ fconfigure $f -buffering line -translation crlf -buffersize 8
+ puts $f "1234567"
+ string map {"\r" "<cr>" "\n" "<lf>"} [contents $path(test1)]
+} -cleanup {
+ close $f
+} -result "1234567<cr><lf>"
test io-4.1 {TranslateOutputEOL: lf} {
# search for \n
@@ -1532,7 +1547,7 @@ test io-12.8 {ReadChars: multibyte chars split} {
close $f
scan [string index $in end] %c
} 160
-test io-12.9 {ReadChars: multibyte chars split} {
+test io-12.9 {ReadChars: multibyte chars split} -body {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat a 9]\xC2
@@ -1542,8 +1557,10 @@ test io-12.9 {ReadChars: multibyte chars split} {
set in [read $f]
close $f
scan [string index $in end] %c
-} 194
-test io-12.10 {ReadChars: multibyte chars split} {
+} -cleanup {
+ catch {close $f}
+} -result 194
+test io-12.10 {ReadChars: multibyte chars split} -body {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat a 9]\xC2
@@ -1553,7 +1570,9 @@ test io-12.10 {ReadChars: multibyte chars split} {
set in [read $f]
close $f
scan [string index $in end] %c
-} 194
+} -cleanup {
+ catch {close $f}
+} -result 194
test io-13.1 {TranslateInputEOL: cr mode} {} {
set f [open $path(test1) w]
@@ -2346,9 +2365,9 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \
set result ok
}
} ok
-test io-28.4 {Tcl_Close} {testchannel} {
+test io-28.4 Tcl_Close testchannel {
file delete $path(test1)
- set l ""
+ set l {}
lappend l [lsort [testchannel open]]
set f [open $path(test1) w]
lappend l [lsort [testchannel open]]
@@ -2373,6 +2392,74 @@ test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} {
lsort $l
} {file1 file2}
+
+test io-28.6 {
+ close channel in write event handler
+
+ Should not produce a segmentation fault in a Tcl built with
+ --enable-symbols and -DPURIFY
+} debugpurify {
+ variable done
+ variable res
+ after 0 [list coroutine c1 apply [list {} {
+ variable done
+ set chan [chan create w {apply {args {
+ list initialize finalize watch write configure blocking
+ }}}]
+ chan configure $chan -blocking 0
+ while 1 {
+ chan event $chan writable [list [info coroutine]]
+ yield
+ close $chan
+ set done 1
+ return
+ }
+ } [namespace current]]]
+ vwait [namespace current]::done
+return success
+} success
+
+
+test io-28.7 {
+ close channel in read event handler
+
+ Should not produce a segmentation fault in a Tcl built with
+ --enable-symbols and -DPURIFY
+} debugpurify {
+ variable done
+ variable res
+ after 0 [list coroutine c1 apply [list {} {
+ variable done
+ set chan [chan create r {apply {{cmd chan args} {
+ switch $cmd {
+ blocking - finalize {
+ }
+ watch {
+ chan postevent $chan read
+ }
+ initialize {
+ list initialize finalize watch read write configure blocking
+ }
+ default {
+ error [list {unexpected command} $cmd]
+ }
+ }
+ }}}]
+ chan configure $chan -blocking 0
+ while 1 {
+ chan event $chan readable [list [info coroutine]]
+ yield
+ close $chan
+ set done 1
+ return
+ }
+ } [namespace current]]]
+ vwait [namespace current]::done
+return success
+} success
+
+
+
test io-29.1 {Tcl_WriteChars, channel not writable} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
@@ -2989,6 +3076,99 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM
interp delete y
} ""
+test io-29.36.1 {gets on translation auto with "\r" in QA communication mode, possible regression, bug [b3977d199b]} -constraints {
+ socket tempNotMac fileevent
+} -setup {
+ set s [open "|[list [interpreter] << {
+ proc accept {so args} {
+ fconfigure $so -translation binary
+ puts -nonewline $so "who are you?\r"; flush $so
+ set a [gets $so]
+ puts -nonewline $so "really $a?\r"; flush $so
+ set a [gets $so]
+ close $so
+ set ::done $a
+ }
+ set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
+ puts [lindex [fconfigure $s -sockname] 2]
+ foreach c {1 2} {
+ vwait ::done
+ puts $::done
+ }
+ }]" r]
+ set c {}
+ set result {}
+} -body {
+ set port [gets $s]
+ foreach t {{cr lf} {auto lf}} {
+ set c [socket 127.0.0.1 $port]
+ fconfigure $c -buffering line -translation $t
+ lappend result $t
+ while {1} {
+ set q [gets $c]
+ switch -- $q {
+ "who are you?" {puts $c "client"}
+ "really client?" {puts $c "yes"; lappend result $q; break}
+ default {puts $c "wrong"; lappend result "unexpected input \"$q\""; break}
+ }
+ }
+ lappend result [gets $s]
+ close $c; set c {}
+ }
+ set result
+} -cleanup {
+ close $s
+ if {$c ne {}} { close $c }
+ unset -nocomplain s c port t q
+} -result [list {cr lf} "really client?" yes {auto lf} "really client?" yes]
+test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug [b3977d199b]} -constraints {
+ socket tempNotMac fileevent
+} -setup {
+ set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
+ set c {}
+} -body {
+ set ::cnt 0
+ proc accept {so args} {
+ fconfigure $so -translation binary
+ puts -nonewline $so "1 line\r"
+ puts -nonewline $so "\n2 li"
+ flush $so
+ # now force separate packets
+ puts -nonewline $so "ne\r"
+ flush $so
+ if {$::cnt & 1} {
+ vwait ::cli; # simulate short delay (so client can process events, just wait for it)
+ } else {
+ # we don't have a delay, so client would get the lines as single chunk
+ }
+ # we'll try with "\r" and without "\r" (to cover both branches, where "\r" and "eof" causes exit from [gets] by 3rd line)
+ puts -nonewline $so "\n3 line"
+ if {!($::cnt % 3)} {
+ puts -nonewline $so "\r"
+ }
+ flush $so
+ close $so
+ }
+ while {$::cnt < 6} { incr ::cnt
+ set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
+ fconfigure $c -blocking 0 -buffering line -translation auto
+ fileevent $c readable [list apply {c {
+ if {[gets $c line] >= 0} {
+ lappend ::cli <$line>
+ } elseif {[eof $c]} {
+ set ::done 1
+ }
+ }} $c]
+ vwait ::done
+ close $c; set c {}
+ }
+ set ::cli
+} -cleanup {
+ close $s
+ if {$c ne {}} { close $c }
+ unset -nocomplain ::done ::cli ::cnt s c
+} -result [lrepeat 6 {<1 line>} {<2 line>} {<3 line>}]
+
# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
@@ -5310,9 +5490,6 @@ test io-39.1 {Tcl_GetChannelOption} {
close $f1
set x
} 1
-#
-# Test 17.2 was removed.
-#
test io-39.2 {Tcl_GetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
@@ -8413,7 +8590,7 @@ test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} {
# cut of the remainder of the error stack, especially the filename
set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
list $x $result
-} {1 {gets {} catch {error writing "stdout": invalid argument}}}
+} {1 {gets {} catch {error writing "stdout": illegal byte sequence}}}
test io-61.1 {Reset eof state after changing the eof char} -setup {
set datafile [makeFile {} eofchar]
@@ -8687,7 +8864,7 @@ test io-73.1 {channel Tcl_Obj SetChannelFromAny} {} {
} {1}
test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup {
- # Invalidate intrep of 'channel' Tcl_Obj when transiting between interpreters.
+ # Invalidate internalrep of 'channel' Tcl_Obj when transiting between interpreters.
set f [open [info script] r]
} -body {
interp create foo
generated by cgit v0.12 at 2025-12-09 19:03:17 (GMT)