? generic/tclMain.c.ano
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.1171
diff -u -r1.1171 ChangeLog
--- ChangeLog	23 Jul 2002 18:37:53 -0000	1.1171
+++ ChangeLog	24 Jul 2002 00:14:52 -0000
@@ -1,3 +1,13 @@
+2002-07-23  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-23  Joe English  <jenglish@users.sourceforge.net>
 
 	* doc/OpenFileChnl.3: (Updates from Larry Virden)
Index: generic/tclIO.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIO.c,v
retrieving revision 1.56
diff -u -r1.56 tclIO.c
--- generic/tclIO.c	24 May 2002 21:19:05 -0000	1.56
+++ generic/tclIO.c	24 Jul 2002 00:14:52 -0000
@@ -3055,6 +3055,7 @@
     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 @@
      * 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 @@
 	    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
@@ -3209,6 +3214,15 @@
 		endEncoding = 0;
 	    }
 	}
+    }
+
+    /* 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;
 }
Index: tests/io.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/io.test,v
retrieving revision 1.36
diff -u -r1.36 io.test
--- tests/io.test	10 Jul 2002 11:56:44 -0000	1.36
+++ tests/io.test	24 Jul 2002 00:14:53 -0000
@@ -7077,6 +7077,41 @@
     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] {
