Backport tcltest 2.5.6 from Tcl9.0b1

2 files changed, 50 insertions, 13 deletions

diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
index 18b05e5..9903e32 100644
--- a/library/tcltest/pkgIndex.tcl
+++ b/library/tcltest/pkgIndex.tcl
@@ -9,4 +9,4 @@
 # full path name of this file's directory.
 
 if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
-package ifneeded tcltest 2.5.5 [list source [file join $dir tcltest.tcl]]
+package ifneeded tcltest 2.5.6 [list source [file join $dir tcltest.tcl]]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 3b89cf7..d13e97f 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -22,13 +22,14 @@ namespace eval tcltest {
     # When the version number changes, be sure to update the pkgIndex.tcl file,
     # and the install directory in the Makefiles.  When the minor version
     # changes (new feature) be sure to update the man page as well.
-    variable Version 2.5.5
+    variable Version 2.5.6
 
     # Compatibility support for dumb variables defined in tcltest 1
     # Do not use these.  Call [package provide Tcl] and [info patchlevel]
     # yourself.  You don't need tcltest to wrap it for you.
     variable version [package provide Tcl]
     variable patchLevel [info patchlevel]
+    variable fullutf [package vsatisfies $version 8.7-]
 
 ##### Export the public tcltest procs; several categories
     #
@@ -400,7 +401,7 @@ namespace eval tcltest {
 	    default {
 		set outputChannel [open $filename a]
 		if {[package vsatisfies [package provide Tcl] 8.7-]} {
-		    fconfigure $outputChannel -encoding utf-8
+		    fconfigure $outputChannel -profile tcl8 -encoding utf-8
 		}
 		set ChannelsWeOpened($outputChannel) 1
 
@@ -447,7 +448,7 @@ namespace eval tcltest {
 	    default {
 		set errorChannel [open $filename a]
 		if {[package vsatisfies [package provide Tcl] 8.7-]} {
-		    fconfigure $errorChannel -encoding utf-8
+		    fconfigure $errorChannel -profile tcl8 -encoding utf-8
 		}
 		set ChannelsWeOpened($errorChannel) 1
 
@@ -792,7 +793,7 @@ namespace eval tcltest {
 	if {$Option(-loadfile) eq {}} {return}
 	set tmp [open $Option(-loadfile) r]
 	if {[package vsatisfies [package provide Tcl] 8.7-]} {
-	    fconfigure $tmp -encoding utf-8
+	    fconfigure $tmp -profile tcl8 -encoding utf-8
 	}
 	loadScript [read $tmp]
 	close $tmp
@@ -1134,6 +1135,38 @@ proc tcltest::SafeFetch {n1 n2 op} {
     }
 }
 
+# tcltest::Asciify --
+#
+#       Transforms the passed string to contain only printable ascii characters.
+#       Useful for printing to terminals. Non-printables are mapped to
+#       \x, \u or \U sequences.
+#
+# Arguments:
+#       s - string to transform
+#
+# Results:
+#       The transformed strings
+#
+# Side effects:
+#       None.
+
+proc tcltest::Asciify {s} {
+    variable fullutf
+    set print ""
+    foreach c [split $s ""] {
+        if {[string is print $c] && (($c <= "\x7E") || ($c == "\n"))} {
+            append print $c
+        } elseif {$c < "\u0100"} {
+            append print \\x[format %02X [scan $c %c]]
+        } elseif {$fullutf && ($c >= "\U10000")} {
+            append print \\U[format %08X [scan $c %c]]
+        } else {
+            append print \\u[format %04X [scan $c %c]]
+        }
+    }
+    return $print
+}
+
 # tcltest::ConstraintInitializer --
 #
 #	Get or set a script that when evaluated in the tcltest namespace
@@ -1340,7 +1373,7 @@ proc tcltest::DefineConstraintInitializers {} {
 	set code 0
 	if {![catch {set f [open "|[list [interpreter]]" w]}]} {
 	    if {[package vsatisfies [package provide Tcl] 8.7-]} {
-		fconfigure $f -encoding utf-8
+		fconfigure $f -profile tcl8 -encoding utf-8
 	    }
 	    if {![catch {puts $f exit}]} {
 		if {![catch {close $f}]} {
@@ -2190,7 +2223,7 @@ proc tcltest::test {name description args} {
 	    if {[file readable $testFile]} {
 		set testFd [open $testFile r]
 		if {[package vsatisfies [package provide Tcl] 8.7-]} {
-		    fconfigure $testFd -encoding utf-8
+		    fconfigure $testFd -profile tcl8 -encoding utf-8
 		}
 		set testLine [expr {[lsearch -regexp \
 			[split [read $testFd] "\n"] \
@@ -2221,9 +2254,13 @@ proc tcltest::test {name description args} {
 	if {$scriptCompare} {
 	    puts [outputChannel] "---- Error testing result: $scriptMatch"
 	} else {
-	    puts [outputChannel] "---- Result was:\n$actualAnswer"
+	    if {[catch {
+		puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]"
+	    } errMsg]} {
+		puts [outputChannel] "\n---- Result was:\n<error printing result: $errMsg>"
+	    }
 	    puts [outputChannel] "---- Result should have been\
-		    ($match matching):\n$result"
+		    ($match matching):\n[Asciify $result]"
 	}
     }
     if {$errorCodeFailure} {
@@ -2583,7 +2620,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
 	# loop is running, which is the real issue.
 	# Actually, this doesn't belong here at all.  A package
 	# really has no business [exit]-ing an application.
-	if {![info exists ::tk_version] && ![testConstraint interactive]} {
+	if {[info exists ::tk_version] && ![testConstraint interactive]} {
 	    exit
 	}
     } else {
@@ -2902,7 +2939,7 @@ proc tcltest::runAllTests { {shell ""} } {
 		incr numTestFiles
 		set pipeFd [open $cmd "r"]
 		if {[package vsatisfies [package provide Tcl] 8.7-]} {
-		    fconfigure $pipeFd -encoding utf-8
+		    fconfigure $pipeFd -profile tcl8 -encoding utf-8
 		}
 		while {[gets $pipeFd line] >= 0} {
 		    if {[regexp [join {
@@ -3102,7 +3139,7 @@ proc tcltest::makeFile {contents name {directory ""}} {
     set fd [open $fullName w]
     fconfigure $fd -translation lf
     if {[package vsatisfies [package provide Tcl] 8.7-]} {
-	fconfigure $fd -encoding utf-8
+	fconfigure $fd -profile tcl8 -encoding utf-8
     }
     if {[string index $contents end] eq "\n"} {
 	puts -nonewline $fd $contents
@@ -3253,7 +3290,7 @@ proc tcltest::viewFile {name {directory ""}} {
     set fullName [file join $directory $name]
     set f [open $fullName]
     if {[package vsatisfies [package provide Tcl] 8.7-]} {
-	fconfigure $f -encoding utf-8
+	fconfigure $f -profile tcl8 -encoding utf-8
     }
     set data [read -nonewline $f]
     close $f