Merge 8.7

9 files changed, 119 insertions, 59 deletions

diff --git a/generic/tclIO.c b/generic/tclIO.c
index b801441..71ad637 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -4335,6 +4335,7 @@ Write(
     char *nextNewLine = NULL;
     int endEncoding, saved = 0, total = 0, flushed = 0, needNlFlush = 0;
     char safe[BUFFER_PADDING];
+    int encodingError = 0;
 
     if (srcLen) {
         WillWrite(chanPtr);
@@ -4351,7 +4352,7 @@ Write(
 	nextNewLine = (char *)memchr(src, '\n', srcLen);
     }
 
-    while (srcLen + saved + endEncoding > 0) {
+    while (srcLen + saved + endEncoding > 0 && !encodingError) {
 	ChannelBuffer *bufPtr;
 	char *dst;
 	int result, srcRead, dstLen, dstWrote, srcLimit = srcLen;
@@ -4390,6 +4391,19 @@ Write(
 
 	statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
 
+	/*
+	 * See io-75.2, TCL bug 6978c01b65.
+	 * Check, if an encoding error occured and should be reported to the
+	 * script level.
+	 * This happens, if a written character may not be represented by the
+	 * current output encoding and strict encoding is active.
+	 */
+
+	if (result == TCL_CONVERT_UNKNOWN) {
+	    encodingError = 1;
+	    result = TCL_OK;
+	}
+
 	if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
 	    /*
 	     * We're reading from invalid/incomplete UTF-8.
@@ -4497,6 +4511,10 @@ Write(
 
     UpdateInterest(chanPtr);
 
+    if (encodingError) {
+	Tcl_SetErrno(EILSEQ);
+	return -1;
+    }
     return total;
 }
 
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 38e07cc..3f4da2e 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -795,7 +795,7 @@ proc http::geturl {url args} {
     #   script or installation that modified ::tls::socketCmd is also
     #   responsible for integrating ::http::socket into its own "new" command,
     #   if it wishes to do so.
-    
+
     if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} {
         set ::tls::socketCmd $socketCmd
     }
@@ -1606,7 +1606,7 @@ proc http::OpenSocket {token DoLater} {
 #     socket with the real socket, not only in $token but in all other requests
 #     that use the same placeholder.
 # (2) It calls ScheduleRequest to schedule each request that uses the socket.
-# 
+#
 #
 # Value of sockOld/sockNew can be "sock" (genuine socket) or "ph" (placeholder).
 # sockNew is ${token}(sock)
@@ -1666,7 +1666,7 @@ proc http::ConfigureNewSocket {token sockOld DoLater} {
         #
         # FIXME If Finish is placeholder-aware, these traces can be set earlier,
         # in PreparePersistentConnection.
-    
+
         if {[dict get $DoLater -traceread]} {
 	    set varName ::http::socketRdState($state(socketinfo))
 	    trace add variable $varName unset ::http::CancelReadPipeline
@@ -4382,7 +4382,7 @@ proc http::LoadThreadIfNeeded {} {
 
 proc http::SockInThread {caller defcmd sockargs} {
     package require Thread
-    
+
     set catchCode [catch {eval $defcmd $sockargs} sock errdict]
     if {$catchCode == 0} {
         set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict]
diff --git a/tests/chan.test b/tests/chan.test
index 92846d5..4155c36 100644
--- a/tests/chan.test
+++ b/tests/chan.test
@@ -55,13 +55,13 @@ test chan-4.3 {chan command: [Bug 800753]} -body {
 } -returnCodes error -match glob -result {bad value*}
 test chan-4.4 {chan command: check valid inValue, no outValue} -body {
     chan configure stdout -eofchar [list \x27 {}]
-} -returnCodes ok -result {}
+} -result {}
 test chan-4.5 {chan command: check valid inValue, invalid outValue} -body {
     chan configure stdout -eofchar [list \x27 \x80]
 } -returnCodes error -match glob -result {bad value for -eofchar:*}
 test chan-4.6 {chan command: check no inValue, valid outValue} -body {
     chan configure stdout -eofchar [list {} \x27]
-} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]}
+} -result {} -cleanup {chan configure stdout -eofchar [list {} {}]}
 
 test chan-5.1 {chan command: copy subcommand} -body {
     chan copy foo
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index a1cb6c2..a7aa36c 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -158,7 +158,7 @@ test cmdMZ-return-2.11 {return option handling} {
 } {3 {-code 3 -level 0}}
 test cmdMZ-return-2.12 {return option handling} -body {
     return -level 0 -code error -options {-code ok}
-} -returnCodes ok -result {}
+} -result {}
 test cmdMZ-return-2.13 {return option handling} -body {
     return -level 0 -code error -options {-code err}
 } -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
diff --git a/tests/compile.test b/tests/compile.test
index 9959da4..aec1ef1 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -652,26 +652,26 @@ test compile-16.18.$noComp {TclCompileScript: word expansion} -body {
     llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"]
 } -constraints [linsert $constraints 0 knownBug] -cleanup {
     rename LongList {}
-} -returnCodes ok  -result [expr {1<<20}]
+}  -result [expr {1<<20}]
 test compile-16.19.$noComp {TclCompileScript: word expansion} -body {
     proc LongList {} {return [lrepeat [expr {1<<11}] x]}
     llength [run "list [string repeat {{*}[LongList] } [expr {1<<11}]]"]
 } -constraints [linsert $constraints 0 knownBug] -cleanup {
     rename LongList {}
-} -returnCodes ok  -result [expr {1<<22}]
+}  -result [expr {1<<22}]
 test compile-16.20.$noComp {TclCompileScript: word expansion} -body {
     proc LongList {} {return [lrepeat [expr {1<<12}] x]}
     llength [run "list [string repeat {{*}[LongList] } [expr {1<<12}]]"]
 } -constraints [linsert $constraints 0 knownBug] -cleanup {
     rename LongList {}
-} -returnCodes ok  -result [expr {1<<24}]
+}  -result [expr {1<<24}]
 # This is the one that should cause overflow
 test compile-16.21.$noComp {TclCompileScript: word expansion} -body {
     proc LongList {} {return [lrepeat [expr {1<<16}] x]}
     llength [run "list [string repeat {{*}[LongList] } [expr {1<<16}]]"]
 } -constraints [linsert $constraints 0 knownBug] -cleanup {
     rename LongList {}
-} -returnCodes ok  -result [expr {wide(1)<<32}]
+}  -result [expr {wide(1)<<32}]
 test compile-16.22.$noComp {
     Bug 845412: TclCompileScript: word expansion not mandatory
 } -body {
@@ -680,7 +680,7 @@ test compile-16.22.$noComp {
     run "ReturnResults [string repeat {x } 260]"
 } -constraints $constraints -cleanup {
     rename ReturnResults {}
-} -returnCodes ok -result [string trim [string repeat {x } 260]]
+} -result [string trim [string repeat {x } 260]]
 test compile-16.23.$noComp {
     Bug 1032805: defer parse error until run time
 } -constraints $constraints -body {
@@ -692,7 +692,7 @@ test compile-16.23.$noComp {
     }
 } -cleanup {
     namespace delete x
-} -returnCodes ok -result {syntax {}{}}
+} -result {syntax {}{}}
 test compile-16.24.$noComp {
     Bug 1638414: bad list constant as first expanded term
 } -constraints $constraints -body {
diff --git a/tests/interp.test b/tests/interp.test
index 385d3e2..fa263e2 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -1640,7 +1640,7 @@ test interp-20.50.1 {Bug 2486550} -setup {
 } -cleanup {
     unset -nocomplain m 0
     interp delete child
-} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?"
+} -result {wrong # args: should be "coroutine name cmd ?arg ...?"
     while executing
 "coroutine"
     invoked from within
diff --git a/tests/io.test b/tests/io.test
index 5c45918..e4f68be 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -13,12 +13,12 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-if {"::tcltest" ni [namespace children]} {
-    package require tcltest 2.5
-}
-
 namespace eval ::tcl::test::io {
-    namespace import ::tcltest::*
+
+    if {"::tcltest" ni [namespace children]} {
+	package require tcltest 2.5
+	namespace import -force ::tcltest::*
+    }
 
     variable umaskValue
     variable path
@@ -8952,59 +8952,101 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup {
     removeFile io-74.1
 } -returnCodes error -match glob -result {can not find channel named "*"}
 
-# Note: the following tests 75.1 to 75.3 are in preparation for TCL 9.0, where
-# those should result in an error result
+# The following tests 75.1 to 75.5 exercise strict or tolerant channel
+# encoding.
+# TCL 8.7 only offers tolerant channel encoding, what is tested here.
 test io-75.1 {multibyte encoding error read results in raw bytes} -constraints deprecated -setup {
-	set fn [makeFile {} io-75.1]
+    set fn [makeFile {} io-75.1]
     set f [open $fn w+]
     fconfigure $f -encoding binary
-	# In UTF-8, a byte 0xCx starts a multibyte sequence and must be followed
-	# by a byte > 0x7F. This is violated to get an invalid sequence.
-	puts -nonewline $f "A\xC0\x40"
-	flush $f
-	seek $f 0
-	fconfigure $f -encoding utf-8 -buffering none
+    # In UTF-8, a byte 0xCx starts a multibyte sequence and must be followed
+    # by a byte > 0x7F. This is violated to get an invalid sequence.
+    puts -nonewline $f "A\xC0\x40"
+    flush $f
+    seek $f 0
+    fconfigure $f -encoding utf-8 -buffering none
 } -body {
-	read $f
+    set d [read $f]
+    binary scan $d H* hd
+    set hd
 } -cleanup {
-	close $f
-	removeFile io-75.1
-} -returnCodes ok -result "A\xC0\x40"
-# for TCL 9.0, the result is error
+    close $f
+    removeFile io-75.1
+} -result "41c040"
 
 test io-75.2 {unrepresentable character write passes and is replaced by ?} -constraints deprecated -setup {
-	set fn [makeFile {} io-75.2]
+    set fn [makeFile {} io-75.2]
     set f [open $fn w+]
     fconfigure $f -encoding iso8859-1
 } -body {
-	# the following command gets in result error in TCL 9.0
-	puts -nonewline $f "A\u2022"
-	flush $f
-	seek $f 0
-	read $f
+    puts -nonewline $f "A\u2022"
+    flush $f
+    seek $f 0
+    read $f
 } -cleanup {
-	close $f
-	removeFile io-75.2
-} -returnCodes ok -result "A?"
+    close $f
+    removeFile io-75.2
+} -result "A?"
 
 # Incomplete sequence test.
 # This error may IMHO only be detected with the close.
 # But the read already returns the incomplete sequence.
 test io-75.3 {incomplete multibyte encoding read is ignored} -setup {
-	set fn [makeFile {} io-75.3]
+    set fn [makeFile {} io-75.3]
     set f [open $fn w+]
     fconfigure $f -encoding binary
-	puts -nonewline $f "A\xC0"
-	flush $f
-	seek $f 0
-	fconfigure $f -encoding utf-8 -buffering none
+    puts -nonewline $f "A\xC0"
+    flush $f
+    seek $f 0
+    fconfigure $f -encoding utf-8 -buffering none
 } -body {
-	set d [read $f]
-	close $f
-	set d
+    set d [read $f]
+    close $f
+    binary scan $d H* hd
+    set hd
 } -cleanup {
-	removeFile io-75.3
-} -returnCodes ok -result "A\xC0"
+    removeFile io-75.3
+} -result "41c0"
+
+# As utf-8 has a special treatment in multi-byte decoding, also test another
+# one.
+test io-75.4 {shiftjis encoding error read results in raw bytes} -setup {
+    set fn [makeFile {} io-75.4]
+    set f [open $fn w+]
+    fconfigure $f -encoding binary
+    # In shiftjis, \x81 starts a two-byte sequence.
+    # But 2nd byte \xFF is not allowed
+    puts -nonewline $f "A\x81\xFFA"
+    flush $f
+    seek $f 0
+    fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf
+} -body {
+    set d [read $f]
+    binary scan $d H* hd
+    set hd
+} -cleanup {
+    close $f
+    removeFile io-75.4
+} -result "4181ff41"
+
+test io-75.5 {incomplete shiftjis encoding read is ignored} -setup {
+    set fn [makeFile {} io-75.5]
+    set f [open $fn w+]
+    fconfigure $f -encoding binary
+    # \x81 announces a two byte sequence.
+    puts -nonewline $f "A\x81"
+    flush $f
+    seek $f 0
+    fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf
+} -body {
+    set d [read $f]
+    close $f
+    binary scan $d H* hd
+    set hd
+} -cleanup {
+    removeFile io-75.5
+} -result "4181"
+
 
 # ### ### ### ######### ######### #########
 
diff --git a/tests/result.test b/tests/result.test
index 845c26e..5ae29b2 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -109,14 +109,14 @@ test result-6.0 {Bug 1209759} -constraints testreturn -body {
     # Might panic if bug is not fixed.
     proc foo {} {testreturn}
     foo
-} -returnCodes ok  -result {}
+}  -result {}
 test result-6.1 {Bug 1209759} -constraints testreturn -body {
     # Might panic if bug is not fixed.
     proc foo {} {catch {return -level 2}; testreturn}
     foo
 } -cleanup {
     rename foo {}
-} -returnCodes ok -result {}
+} -result {}
 test result-6.2 {Bug 1649062} -setup {
     proc foo {} {
         if {[catch {
diff --git a/tests/safe.test b/tests/safe.test
index c355171..fc7c814 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -1174,7 +1174,7 @@ test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup {
 } -body {
     catch {interp eval $i {load {} Safepfx1}} m o
     dict get $o -errorinfo
-} -returnCodes ok -cleanup {
+} -cleanup {
     unset -nocomplain m o
     safe::interpDelete $i
 } -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure
@@ -1205,7 +1205,7 @@ test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints t
     set i [safe::interpCreate -nestedloadok]
     catch {interp eval $i {interp create x; load {} Safepfx1 x}} m o
     dict get $o -errorinfo
-} -returnCodes ok -cleanup {
+} -cleanup {
     unset -nocomplain m o
     safe::interpDelete $i
 } -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure
@@ -1275,7 +1275,7 @@ test safe-11.7.1 {testing safe encoding} -setup {
 } -body {
     catch {interp eval $i encoding convertfrom} m o
     dict get $o -errorinfo
-} -returnCodes ok -match glob -cleanup {
+} -match glob -cleanup {
     unset -nocomplain m o
     safe::interpDelete $i
 } -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"
@@ -1297,7 +1297,7 @@ test safe-11.8.1 {testing safe encoding} -setup {
 } -body {
     catch {interp eval $i encoding convertto} m o
     dict get $o -errorinfo
-} -returnCodes ok -match glob -cleanup {
+} -match glob -cleanup {
     unset -nocomplain m o
     safe::interpDelete $i
 } -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"