diff options
| -rw-r--r-- | generic/tclIO.c | 15 | ||||
| -rw-r--r-- | tests/io.test | 33 | ||||
| -rw-r--r-- | tests/socket.test | 40 |
3 files changed, 83 insertions, 5 deletions
diff --git a/generic/tclIO.c b/generic/tclIO.c index 9197b06..6add83f 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6016,10 +6016,13 @@ ReadChars( /* * We read more chars than allowed. Reset limits to - * prevent that and try again. + * prevent that and try again. Don't forget the extra + * padding of TCL_UTF_MAX - 1 bytes demanded by the + * Tcl_ExternalToUtf() call! */ - dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) - dst; + dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) + + TCL_UTF_MAX - 1 - dst; statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; @@ -6097,8 +6100,12 @@ ReadChars( consume: bufPtr->nextRemoved += srcRead; - if (dstWrote > srcRead + 1) { - *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; + /* + * If this read contained multibyte characters, revise factorPtr + * so the next read will allocate bigger buffers. + */ + if (numChars && numChars < srcRead) { + *factorPtr = srcRead * UTF_EXPANSION_FACTOR / numChars; } Tcl_SetObjLength(objPtr, numBytes + dstWrote); return numChars; diff --git a/tests/io.test b/tests/io.test index 96ea14b..cf38a1b 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1449,6 +1449,39 @@ 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-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] diff --git a/tests/socket.test b/tests/socket.test index 0c9320a..29dd677 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -640,7 +640,45 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a close $s close $sock } -result {a:one b: c:two} - +test socket_$af-2.12 {} [list socket stdio supported_$af] { + file delete $path(script) + set f [open $path(script) w] + puts $f { + set server [socket -server accept_client 0] + puts [lindex [chan configure $server -sockname] 2] + proc accept_client { client host port } { + chan configure $client -blocking 0 -buffering line + write_line $client + } + proc write_line client { + if { [catch { chan puts $client [string repeat . 720000]}] } { + puts [catch {chan close $client}] + } else { + puts signal1 + after 0 write_line $client + } + } + chan event stdin readable {set forever now} + vwait forever + exit + } + close $f + set f [open "|[list [interpreter] $path(script)]" r+] + gets $f port + set sock [socket $localhost $port] + chan event $sock readable [list read_lines $sock $f] + proc read_lines { sock pipe } { + gets $pipe + chan close $sock + chan event $pipe readable [list readpipe $pipe] + } + proc readpipe {pipe} { + while {![string is integer [set ::done [gets $pipe]]]} {} + } + vwait ::done + close $f + set ::done +} 0 test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) set f [open $path(script) w] |