From e770c1ef59718fa714e17e91db88cbb3030a88c3 Mon Sep 17 00:00:00 2001
From: dgp <dgp@noemail.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.

FossilOrigin-Name: 87fc2707a08cdebd353814f1a982ef0a6f9feeda
---
 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