From f99c2266c1650f9febe04af2e792e921bd2cbe16 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 9 Jan 2024 10:32:52 +0000 Subject: Backport tcltest 2.5.6 from Tcl9.0b1 --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 61 +++++++++++++++++++++++++++++++++++--------- unix/Makefile.in | 4 +-- win/Makefile.in | 4 +-- 4 files changed, 54 insertions(+), 17 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" + } 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 diff --git a/unix/Makefile.in b/unix/Makefile.in index 9267ef7..239b22b 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -964,9 +964,9 @@ install-libraries: libraries @echo "Installing package msgcat 1.6.1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm" - @echo "Installing package tcltest 2.5.5 as a Tcl Module" + @echo "Installing package tcltest 2.5.6 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ - "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.tm" + "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.6.tm" @echo "Installing package platform 1.0.19 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.19.tm" diff --git a/win/Makefile.in b/win/Makefile.in index 7b0f209..ba543a9 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -747,8 +747,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm"; - @echo "Installing package tcltest 2.5.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.tm"; + @echo "Installing package tcltest 2.5.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.6.tm"; @echo "Installing package platform 1.0.19 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.19.tm"; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12