From 65acf25995e78db3c34b4cfd4998caf4edd4a5d8 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 17 Oct 2014 15:20:34 +0000
Subject: [10dc6daa37] [gets] on a non-blocking channel must take care so that
1) At least one call to the channel driver input proc gets made.
Failure to do this locks up the channel - catastrophic FAIL. 2) After any
driver call reports BLOCKED, don't call again. This is less serious,
but FAILs to respect the non-blocking setting. Code corrections and tests
included, to restore 8.5.15 compat.
---
generic/tclIO.c | 6 +++++
tests/io.test | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 74 insertions(+)
diff --git a/generic/tclIO.c b/generic/tclIO.c
index d1f22c1..e786946 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -4042,6 +4042,7 @@ Tcl_GetsObj(
eof = NULL;
inEofChar = statePtr->inEofChar;
+ ResetFlag(statePtr, CHANNEL_BLOCKED);
while (1) {
if (dst >= dstEnd) {
if (FilterInputBytes(chanPtr, &gs) != 0) {
@@ -4211,6 +4212,10 @@ Tcl_GetsObj(
}
goto gotEOL;
}
+ if (GotFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_NONBLOCKING)
+ == (CHANNEL_BLOCKED|CHANNEL_NONBLOCKING)) {
+ goto restore;
+ }
dst = dstEnd;
}
@@ -4386,6 +4391,7 @@ TclGetsObjBinary(
/* Only handle TCL_TRANSLATE_LF and TCL_TRANSLATE_CR */
eolChar = (statePtr->inputTranslation == TCL_TRANSLATE_LF) ? '\n' : '\r';
+ ResetFlag(statePtr, CHANNEL_BLOCKED);
while (1) {
/*
* Subtract the number of bytes that were removed from channel
diff --git a/tests/io.test b/tests/io.test
index 006b403..0d9468d 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -4299,6 +4299,74 @@ 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 {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 -blocking 0
+ list [gets $c] [gets $c] [gets $c] [gets $c]
+} -cleanup {
+ close $c
+ rename driver {}
+} -result {{} {} {} .......}
# Test Tcl_Seek and Tcl_Tell.
--
cgit v0.12