diff options
Diffstat (limited to 'tests/io.test')
| -rw-r--r-- | tests/io.test | 878 |
1 files changed, 858 insertions, 20 deletions
diff --git a/tests/io.test b/tests/io.test index 9621138..6b6ad6d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -13,14 +13,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +testConstraint testbytestring [llength [info commands testbytestring]] + namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -41,11 +43,11 @@ 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 thread [expr {0 == [catch {package require Thread 2.6}]}] +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... -testConstraint largefileSupport 0 +testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}] # some tests can only be run is umask is 2 # if "umask" cannot be run, the tests will be skipped. @@ -1449,6 +1451,105 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee lappend x [catch {close $f} msg] $msg set x } "{} timeout {} timeout \u7266 {} eof 0 {}" +test io-12.6 {ReadChars: too many chars read} { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat \uBEEF 20][string repeat . 20]] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 + while {![eof $c]} { + read $c 15 + } + close $c +} {} +test io-12.7 {ReadChars: too many chars read [bc5b790099]} { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat \uBEEF 10]....\uBEEF] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 + while {![eof $c]} { + read $c 7 + } + close $c +} {} +test io-12.8 {ReadChars: multibyte chars split} { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xc2\xa0 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -buffersize 10 + set in [read $f] + close $f + scan [string index $in end] %c +} 160 +test io-12.9 {ReadChars: multibyte chars split} { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xc2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -buffersize 10 + set in [read $f] + close $f + scan [string index $in end] %c +} 194 +test io-12.10 {ReadChars: multibyte chars split} { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xc2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -buffersize 11 + set in [read $f] + close $f + scan [string index $in end] %c +} 194 test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] @@ -1563,6 +1664,45 @@ test io-13.8 {TranslateInputEOL: auto mode: \r\n} { close $f set x } "abcd\ndef" +test io-13.8.1 {TranslateInputEOL: auto mode: \r\n} { + set f [open $path(test1) w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef" + close $f + set f [open $path(test1)] + fconfigure $f -translation auto + set x {} + lappend x [read $f 5] + lappend x [read $f] + close $f + set x +} [list "abcd\n" "def"] +test io-13.8.2 {TranslateInputEOL: auto mode: \r\n} { + set f [open $path(test1) w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef" + close $f + set f [open $path(test1)] + fconfigure $f -translation auto -buffersize 6 + set x {} + lappend x [read $f 5] + lappend x [read $f] + close $f + set x +} [list "abcd\n" "def"] +test io-13.8.3 {TranslateInputEOL: auto mode: \r\n} { + set f [open $path(test1) w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\n\r\ndef" + close $f + set f [open $path(test1)] + fconfigure $f -translation auto -buffersize 7 + set x {} + lappend x [read $f 5] + lappend x [read $f] + close $f + set x +} [list "abcd\n" "\ndef"] test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { set f [open $path(test1) w] fconfigure $f -translation lf @@ -2771,7 +2911,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa variable x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz proc writelots {s l} { - for {set i 0} {$i < 2000} {incr i} { + for {set i 0} {$i < 9000} {incr i} { puts $s $l } } @@ -2802,7 +2942,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa close $ss vwait [namespace which -variable x] set c -} 2000 +} 9000 test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} { # On Mac, this test screws up sockets such that subsequent tests using port 2828 # either cause errors or panic(). @@ -3984,6 +4124,46 @@ test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { } {{hello } {hello }} +test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts $f1 {chan configure stdout -translation crlf} + puts $f1 {puts [gets stdin]} + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + puts $f1 hello + flush $f1 + set x "" + lappend x [read $f1 6] + puts $f1 hello + flush $f1 + lappend x [read $f1] + close $f1 + set x +} {{hello +} {hello +}} +test io-32.11.2 {Tcl_Read from a pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts $f1 {chan configure stdout -translation crlf} + puts $f1 {puts [gets stdin]} + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + puts $f1 hello + flush $f1 + set x "" + lappend x [read $f1 6] + puts $f1 hello + flush $f1 + lappend x [read $f1] + close $f1 + set x +} {{hello +} {hello +}} test io-32.12 {Tcl_Read, -nonewline} { file delete $path(test1) set f1 [open $path(test1) w] @@ -4178,6 +4358,110 @@ test io-33.10 {Tcl_Gets, exercising double buffering} { close $f set y } 300 +test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 3} {set n 3} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -translation binary -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result {{} {} {} .......} +test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 3} {set n 3} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result {{} {} {} .......} +test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [string repeat \ + [string repeat . 64]\n[string repeat . 25] 2] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 65} {set n 65} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result [list [string repeat . 64] {} [string repeat . 89] \ + [string repeat . 25] {}] # Test Tcl_Seek and Tcl_Tell. @@ -4457,10 +4741,10 @@ test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { puts -nonewline $f abcdef lappend l [tell $f] close $f - lappend l [file size $f] + lappend l [file size $path(test3)] # truncate... close [open $path(test3) w] - lappend l [file size $f] + lappend l [file size $path(test3)] set l } {0 6 6 4294967296 4294967302 4294967302 0} @@ -4725,6 +5009,92 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { close $f list $c $l $e } {21 8 1} +test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr + puts $f abc\ndef + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {8 8 1 13} +test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {9 8 1 13} +test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar \x1a + puts $f {} + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {2 1 1 13} +test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr + puts $f {} + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {1 1 1 13} +test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $c $l $e [scan [string index $in end] %c] +} -result {17 8 1 13} +test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar {} + set i [format \n%cqrsuvw 26] + puts $f $i + close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $c $l $e [scan [string index $in end] %c] +} {9 1 1 13} # Test Tcl_InputBlocked @@ -4747,6 +5117,29 @@ test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { close $f1 set x } {{} 1 hello 0 {} 1} +test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} {stdio openpipe} { + set f1 [open "|[list [interpreter]]" r+] + chan configure $f1 -encoding binary -translation lf -eofchar {} + puts $f1 { + chan configure stdout -encoding binary -translation lf -eofchar {} + puts hello_from_pipe + } + flush $f1 + gets $f1 + fconfigure $f1 -blocking off -buffering full + puts $f1 {puts hello} + set x "" + lappend x [gets $f1] + lappend x [fblocked $f1] + flush $f1 + after 200 + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [gets $f1] + lappend x [fblocked $f1] + close $f1 + set x +} {{} 1 hello 0 {} 1} test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { set f1 [open "|[list [interpreter]]" r+] fconfigure $f1 -buffering line @@ -6564,11 +6957,23 @@ test io-52.4 {TclCopyChannel} {fcopy} { fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation cr -blocking 0 fcopy $f1 $f2 -size 40 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + lappend result [file size $path(test1)] +} {0 0 0 40} +test io-52.4.1 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + fconfigure $f1 -translation lf -blocking 0 -buffersize 10000000 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -size 40 + set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 close $f2 lappend result [file size $path(test1)] -} {0 0 40} +} {0 0 0 40} test io-52.5 {TclCopyChannel, all} {fcopy} { file delete $path(test1) set f1 [open $thisScript] @@ -6754,6 +7159,150 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} { file size $path(kyrillic.txt) } 3 +test io-52.12 {coverage of -translation auto} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 + set out [open $path(test2) w] + chan configure $out -translation lf + fcopy $in $out + close $in + close $out + file size $path(test2) +} 29 +test io-52.13 {coverage of -translation cr} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation cr + set out [open $path(test2) w] + chan configure $out -translation lf + fcopy $in $out + close $in + close $out + file size $path(test2) +} 30 +test io-52.14 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + chan configure $out -translation lf + fcopy $in $out + close $in + close $out + file size $path(test2) +} 29 +test io-52.14.1 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + fcopy $in $out -size 2 + close $in + close $out + file size $path(test2) +} 2 +test io-52.14.2 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -translation crlf + set out [open $path(test2) w] + fcopy $in $out -size 9 + close $in + close $out + file size $path(test2) +} 9 +test io-52.15 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\r + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 +test io-52.16 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation lf -eofchar a + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 0 +test io-52.17 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation lf -eofchar d + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 3 +test io-52.18 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf -eofchar h + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 +test io-52.19 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 10 -translation crlf -eofchar h + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 + test io-53.1 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] @@ -6823,17 +7372,12 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven for {set x 0} {$x < 12} {incr x} { append big $big } - file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { puts ready fcopy stdin stdout -command { set x } vwait x - set f [open $path(test1) w] - fconfigure $f -translation lf - puts $f "done" - close $f } close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] @@ -6841,11 +7385,10 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven fconfigure $f1 -blocking 0 puts $f1 $big flush $f1 - after 500 set result "" fileevent $f1 read [namespace code { append result [read $f1 1024] - if {[string length $result] >= [string length $big]} { + if {[string length $result] >= [string length $big]+1} { set x done } }] @@ -6854,6 +7397,38 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven set big {} set x } done +test io-53.4.1 {Bug 894da183c8} {stdio fcopy} { + set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n + variable x + for {set x 0} {$x < 12} {incr x} { + append big $big + } + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts $f1 [list file delete $path(test1)] + puts $f1 { + puts ready + set f [open io-53.4.1 w] + chan configure $f -translation lf + fcopy stdin $f -command { set x } + vwait x + close $f + } + puts $f1 "close \[[list open $path(test1) w]]" + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set result [gets $f1] + fconfigure $f1 -blocking 0 -buffersize 125000 -translation lf + puts $f1 $big + fconfigure $f1 -blocking 1 + close $f1 + set big {} + while {[catch {glob $path(test1)}]} {after 50} + file delete $path(test1) + set check [file size io-53.4.1] + file delete io-53.4.1 + set check +} 266241 set result {} proc FcopyTestAccept {sock args} { after 1000 "close $sock" @@ -7223,6 +7798,211 @@ 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-53.13 {TclCopyChannel: read error reporting} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch read} + } + finalize { + return + } + watch {} + read { + error FAIL + } + } + } + set outFile [makeFile {} out] +} -body { + set in [chan create read [namespace which driver]] + chan configure $in -translation binary + set out [open $outFile wb] + chan copy $in $out +} -cleanup { + catch {close $in} + catch {close $out} + removeFile out + rename driver {} +} -result {error reading "*": *} -returnCodes error -match glob +test io-53.14 {TclCopyChannel: write error reporting} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch write} + } + finalize { + return + } + watch {} + write { + error FAIL + } + } + } + set inFile [makeFile {aaa} in] +} -body { + set in [open $inFile rb] + set out [chan create write [namespace which driver]] + chan configure $out -translation binary + chan copy $in $out +} -cleanup { + catch {close $in} + catch {close $out} + removeFile in + rename driver {} +} -result {error writing "*": *} -returnCodes error -match glob +test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { + proc driver {cmd args} { + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 +} -body { + chan copy $c $outChan +} -cleanup { + close $outChan + close $c + removeFile out +} -result 100 +test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup { + proc driver {cmd args} { + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 -translation lf + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 -translation lf +} -body { + chan copy $c $outChan +} -cleanup { + close $outChan + close $c + removeFile out +} -result 100 +test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + line\n[string repeat a 100]line\n] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 -translation lf -buffersize 107 + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 -translation lf +} -body { + list [gets $c] [chan copy $c $outChan -size 100] [gets $c] +} -cleanup { + close $outChan + close $c + removeFile out +} -result {line 100 line} test io-54.1 {Recursive channel events} {socket fileevent} { # This test checks to see if file events are delivered during recursive @@ -7473,12 +8253,12 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test io-60.1 {writing illegal utf sequences} {openpipe fileevent} { +test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] puts $out { - puts [encoding convertfrom identity \xe2] + puts [testbytestring \xe2] exit 1 } proc readit {pipe} { @@ -7788,6 +8568,64 @@ test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup { close $f } -result {1 {can not find channel named "@@"}} +test io-73.3 {[5adc350683] [gets] after EOF} -setup { + set fn [makeFile {} io-73.3] + set rfd [open $fn r] + set wfd [open $fn a] + chan configure $wfd -buffering line + read $rfd +} -body { + set result [eof $rfd] + puts $wfd "more data" + lappend result [eof $rfd] + lappend result [gets $rfd] + lappend result [eof $rfd] + lappend result [gets $rfd] + lappend result [eof $rfd] +} -cleanup { + close $wfd + close $rfd + removeFile io-73.3 +} -result {1 1 {more data} 0 {} 1} + +test io-73.4 {[5adc350683] [read] after EOF} -setup { + set fn [makeFile {} io-73.4] + set rfd [open $fn r] + set wfd [open $fn a] + chan configure $wfd -buffering line + read $rfd +} -body { + set result [eof $rfd] + puts $wfd "more data" + lappend result [eof $rfd] + lappend result [read $rfd] + lappend result [eof $rfd] +} -cleanup { + close $wfd + close $rfd + removeFile io-73.4 +} -result {1 1 {more data +} 1} + +test io-73.5 {effect of eof on encoding end flags} -setup { + set fn [makeFile {} io-73.5] + set rfd [open $fn r] + set wfd [open $fn a] + chan configure $wfd -buffering none -translation binary + chan configure $rfd -buffersize 5 -encoding utf-8 + read $rfd +} -body { + set result [eof $rfd] + puts -nonewline $wfd "more\u00c2\u00a0data" + lappend result [eof $rfd] + lappend result [read $rfd] + lappend result [eof $rfd] +} -cleanup { + close $wfd + close $rfd + removeFile io-73.5 +} -result [list 1 1 more\u00a0data 1] + # ### ### ### ######### ######### ######### # cleanup |