* tests/io.test:

	* generic/tclIO.c (WriteChars): Added flag to break out of loop if
	  nothing of the input is consumed at all, to prevent infinite
	  looping of called with a non-UTF-8 string. Fixes Bug 584603
	  (partially). Added new test "io-60.1". Might need additional
	  changes to Tcl_Main so that unprintable results are printed as
	  binary data.

3 files changed, 62 insertions, 3 deletions

diff --git a/ChangeLog b/ChangeLog
index 41ea520..16bfabe 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2002-07-30  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* tests/io.test: 
+	* generic/tclIO.c (WriteChars): Added flag to break out of loop if
+	  nothing of the input is consumed at all, to prevent infinite
+	  looping of called with a non-UTF-8 string. Fixes Bug 584603
+	  (partially). Added new test "io-60.1". Might need additional
+	  changes to Tcl_Main so that unprintable results are printed as
+	  binary data.
+
 2002-07-29  Mo DeJong  <mdejong@users.sourceforge.net>
 
 	* unix/Makefile.in: Use CC_SEARCH_FLAGS instead of
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 4895824..912a651 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIO.c,v 1.56 2002/05/24 21:19:05 dkf Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.57 2002/07/30 18:36:25 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -3055,6 +3055,7 @@ WriteChars(chanPtr, src, srcLen)
     char *dst, *stage;
     int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
     int stageLen, toWrite, stageRead, endEncoding, result;
+    int consumedSomething;
     Tcl_Encoding encoding;
     char safe[BUFFER_PADDING];
     
@@ -3075,7 +3076,9 @@ WriteChars(chanPtr, src, srcLen)
      * with proper EOL translation.
      */
 
-    while (srcLen + savedLF + endEncoding > 0) {
+    consumedSomething = 1;
+    while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) {
+        consumedSomething = 0;
 	stage = statePtr->outputStage;
 	stageMax = statePtr->bufSize;
 	stageLen = stageMax;
@@ -3199,6 +3202,8 @@ WriteChars(chanPtr, src, srcLen)
 	    stageLen -= stageRead;
 	    sawLF = 0;
 
+	    consumedSomething = 1;
+
 	    /*
 	     * If all translated characters are written to the buffer,
 	     * endEncoding is set to 0 because the escape sequence may be
@@ -3210,6 +3215,15 @@ WriteChars(chanPtr, src, srcLen)
 	    }
 	}
     }
+
+    /* If nothing was written and it happened because there was no progress
+     * in the UTF conversion, we throw an error.
+     */
+
+    if (!consumedSomething && (total == 0)) {
+        Tcl_SetErrno (EINVAL);
+        return -1;
+    }
     return total;
 }
 
diff --git a/tests/io.test b/tests/io.test
index 07d96a5..648f5e7 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: io.test,v 1.36 2002/07/10 11:56:44 dgp Exp $
+# RCS: @(#) $Id: io.test,v 1.37 2002/07/30 18:36:26 andreas_kupries Exp $
 
 if {[catch {package require tcltest 2}]} {
     puts stderr "Skipping tests in [info script].  tcltest 2 required."
@@ -7077,6 +7077,41 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
     string equal $result [testmainthread]
 } {1}
 
+
+test io-60.1 {writing illegal utf sequences} {
+    # This test will hang in older revisions of the core.
+
+    set out [open $path(script) w]
+    puts $out {
+	puts [encoding convertfrom identity \xe2]
+	exit 1
+    }
+    proc readit {pipe} {
+	variable x
+	variable result
+	if {[eof $pipe]} {
+	    set x [catch {close $pipe} line]
+	    lappend result catch $line
+	} else {
+	    gets $pipe line
+	    lappend result gets $line
+	}
+    }
+    close $out
+    set pipe [open "|[list [interpreter] $path(script)]" r]
+    fileevent $pipe readable [namespace code [list readit $pipe]]
+    variable x ""
+    set result ""
+    vwait [namespace which -variable x]
+
+    # 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}}}
+
+
+
+
 # cleanup
 foreach file [list fooBar longfile script output test1 pipe my_script foo \
 	bar test2 test3 cat stdout] {