This commit is contained in:
ton
2024-10-07 10:13:40 +07:00
parent aa1631742f
commit 3a7d696db6
9729 changed files with 1832837 additions and 161742 deletions

View File

@@ -32,7 +32,7 @@ namespace eval msgcat {
# Configuration values per Package (e.g. client namespace).
# The dict key is of the form "<option> <namespace>" and the value is the
# configuration option. A nonexisting key is an unset option.
# configuration option. A non-existing key is an unset option.
variable PackageConfig [dict create mcfolder {} loadcmd {} changecmd {}\
unknowncmd {} loadedlocales {} loclist {}]
@@ -179,7 +179,7 @@ namespace eval msgcat {
# Find the translation for the given string based on the current
# locale setting. Check the local namespace first, then look in each
# parent namespace until the source is found. If additional args are
# specified, use the format command to work them into the traslated
# specified, use the format command to work them into the translated
# string.
# If no catalog item is found, mcunknown is called in the caller frame
# and its result is returned.
@@ -578,7 +578,7 @@ proc msgcat::mcforgetpackage {} {
# mcfolder
# The message catalog folder of the package.
# This is automatically set by mcload.
# If the value is changed using the set subcommand, an evntual
# If the value is changed using the set subcommand, an eventual
# loadcmd is invoked and all message files of the package locale are
# loaded.
#
@@ -1013,7 +1013,7 @@ proc msgcat::mcflmset {pairs} {
# by an application specific routine for error reporting
# purposes. The default behavior is to return the source string.
# If additional args are specified, the format command will be used
# to work them into the traslated string.
# to work them into the translated string.
#
# Arguments:
# locale The current locale.
@@ -1034,9 +1034,9 @@ proc msgcat::mcunknown {args} {
# - Default global handler, if mcunknown is not redefined.
# - Per package handler, if the package sets unknowncmd to the empty
# string.
# It returna the source string if the argument list is empty.
# It returns the source string if the argument list is empty.
# If additional args are specified, the format command will be used
# to work them into the traslated string.
# to work them into the translated string.
#
# Arguments:
# locale (unused) The current locale.

View File

@@ -16,20 +16,22 @@
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
package require Tcl 8.5- ;# -verbose line uses [info frame]
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.7
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# Do not use these. Call [package require] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
variable version [package require Tcl 8.5-]
variable patchLevel [info patchlevel]
# Detect if we can use code points >= \U10000
variable fullutf [package vsatisfies $version 8.7-]
##### Export the public tcltest procs; several categories
#
# Export the main functional commands that do useful things
@@ -41,7 +43,7 @@ namespace eval tcltest {
outputChannel testConstraint
# Export commands that are duplication (candidates for deprecation)
if {![package vsatisfies [package provide Tcl] 8.7-]} {
if {!$fullutf} {
namespace export bytestring ;# dups [encoding convertfrom identity]
}
namespace export debug ;# [configure -debug]
@@ -153,7 +155,7 @@ namespace eval tcltest {
}
##### Initialize internal arrays of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
# has not already preinitialized them. This is done to support
# compatibility with older tests that directly access internals
# rather than go through command interfaces.
#
@@ -163,7 +165,7 @@ namespace eval tcltest {
return
}
if {[info exists $varName]} {
# Pre-initialized value is a scalar: destroy it!
# Preinitialized value is a scalar: Destroy it!
unset $varName
}
array set $varName $value
@@ -196,7 +198,7 @@ namespace eval tcltest {
ArrayDefault testConstraints {}
##### Initialize internal variables of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
# has not already preinitialized them. This is done to support
# compatibility with older tests that directly access internals
# rather than go through command interfaces.
#
@@ -229,7 +231,7 @@ namespace eval tcltest {
# check the current working dir for files created by the tests.
# filesMade keeps track of such files created using the makeFile and
# makeDirectory procedures. filesExisted stores the names of
# pre-existing files.
# preexisting files.
#
# Note that $filesExisted lists only those files that exist in
# the original [temporaryDirectory].
@@ -298,7 +300,7 @@ namespace eval tcltest {
# keep track of test level for nested test commands
variable testLevel 0
# the variables and procs that existed when saveState was called are
# the variables and procedures that existed when saveState was called are
# stored in a variable of the same name
Default saveState {}
@@ -345,6 +347,7 @@ namespace eval tcltest {
proc outputChannel { {filename ""} } {
variable outputChannel
variable ChannelsWeOpened
variable fullutf
# This is very subtle and tricky, so let me try to explain.
# (Hopefully this longer comment will be clear when I come
@@ -354,12 +357,12 @@ namespace eval tcltest {
# be kept in sync with the [configure -outfile] configuration
# option ( and underlying variable Option(-outfile) ). This is
# accomplished with a write trace on Option(-outfile) that will
# update [outputChannel] whenver a new value is written. That
# update [outputChannel] whenever a new value is written. That
# much is easy.
#
# The trick is that in order to maintain compatibility with
# version 1 of tcltest, we must allow every configuration option
# to get its inital value from command line arguments. This is
# to get its initial value from command line arguments. This is
# accomplished by setting initial read traces on all the
# configuration options to parse the command line option the first
# time they are read. These traces are cancelled whenever the
@@ -399,8 +402,8 @@ namespace eval tcltest {
}
default {
set outputChannel [open $filename a]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $outputChannel -encoding utf-8
if {$fullutf} {
fconfigure $outputChannel -profile tcl8 -encoding utf-8
}
set ChannelsWeOpened($outputChannel) 1
@@ -427,6 +430,7 @@ namespace eval tcltest {
proc errorChannel { {filename ""} } {
variable errorChannel
variable ChannelsWeOpened
variable fullutf
# This is subtle and tricky. See the comment above in
# [outputChannel] for a detailed explanation.
@@ -446,8 +450,8 @@ namespace eval tcltest {
}
default {
set errorChannel [open $filename a]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $errorChannel -encoding utf-8
if {$fullutf} {
fconfigure $errorChannel -profile tcl8 -encoding utf-8
}
set ChannelsWeOpened($errorChannel) 1
@@ -482,7 +486,7 @@ namespace eval tcltest {
# Initialize the default values of the configurable options that are
# historically associated with an exported variable. If that variable
# is already set, support compatibility by accepting its pre-set value.
# is already set, support compatibility by accepting its preset value.
# Use [trace] to establish ongoing connection between the deprecated
# exported variable and the modern option kept as a true internal var.
# Also set up usage string and value testing for the option.
@@ -761,7 +765,7 @@ namespace eval tcltest {
# even if the directory is not writable
return $directory
}
return -code error "\"$directory\" is not writeable"
return -code error "\"$directory\" is not writable"
}
return $directory
}
@@ -789,10 +793,12 @@ namespace eval tcltest {
}
proc ReadLoadScript {args} {
variable Option
variable fullutf
if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $tmp -encoding utf-8
if {$fullutf} {
fconfigure $tmp -profile tcl8 -encoding utf-8
}
loadScript [read $tmp]
close $tmp
@@ -852,7 +858,7 @@ namespace eval tcltest {
# tcltest::Debug* --
#
# Internal helper procedures to write out debug information
# dependent on the chosen level. A test shell may overide
# dependent on the chosen level. A test shell may override
# them, f.e. to redirect the output into a different
# channel, or even into a GUI.
@@ -1134,6 +1140,37 @@ 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, except \n.
#
# Arguments:
# s - string to transform
#
# Results:
# The transformed strings
#
# Side effects:
# None.
proc tcltest::Asciify {s} {
set print ""
foreach c [split $s ""] {
if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} {
append print $c
} elseif {$c < "\u0100"} {
append print \\x[format %02X [scan $c %c]]
} elseif {$c > "\uFFFF"} {
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
@@ -1337,10 +1374,12 @@ proc tcltest::DefineConstraintInitializers {} {
}
ConstraintInitializer stdio {
variable fullutf
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $f -encoding utf-8
if {$fullutf} {
fconfigure $f -profile tcl8 -encoding utf-8
}
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
@@ -1758,7 +1797,7 @@ proc tcltest::SubstArguments {argList} {
# We need to split the argList up into tokens but cannot use list
# operations as they throw away some significant quoting, and
# [split] ignores braces as it should. Therefore what we do is
# gradually build up a string out of whitespace seperated strings.
# gradually build up a string out of whitespace-separated strings.
# We cannot use [split] to split the argList into whitespace
# separated strings as it throws away the whitespace which maybe
# important so we have to do it all by hand.
@@ -1865,7 +1904,7 @@ proc tcltest::SubstArguments {argList} {
# match - specifies type of matching to do on result,
# output, errorOutput; this must be a string
# previously registered by a call to [customMatch].
# The strings exact, glob, and regexp are pre-registered
# The strings exact, glob, and regexp are preregistered
# by the tcltest package. Default value is exact.
#
# Arguments:
@@ -1884,6 +1923,8 @@ proc tcltest::test {name description args} {
global tcl_platform
variable testLevel
variable coreModTime
variable fullutf
DebugPuts 3 "test $name $args"
DebugDo 1 {
variable TestNames
@@ -1896,7 +1937,7 @@ proc tcltest::test {name description args} {
FillFilesExisted
incr testLevel
# Pre-define everything to null except output and errorOutput. We
# Predefine everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
lassign {} constraints setup cleanup body result returnCodes errorCode match
@@ -2189,8 +2230,8 @@ proc tcltest::test {name description args} {
set testFile [file normalize [uplevel 1 {info script}]]
if {[file readable $testFile]} {
set testFd [open $testFile r]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $testFd -encoding utf-8
if {$fullutf} {
fconfigure $testFd -profile tcl8 -encoding utf-8
}
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
@@ -2221,9 +2262,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} {
@@ -2365,6 +2410,7 @@ proc tcltest::Skipped {name constraints} {
# make sure that the constraints are satisfied.
set doTest 0
set constraints [string trim $constraints]
if {[string match {*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
catch {set doTest [uplevel #0 [list expr $constraints]]}
@@ -2491,7 +2537,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# Remove files and directories created by the makeFile and
# makeDirectory procedures. Record the names of files in
# workingDirectory that were not pre-existing, and associate them
# workingDirectory that were not preexisting, and associate them
# with the test file that created them.
if {!$calledFromAllFile} {
@@ -2582,7 +2628,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 {![catch {package present Tk}] && ![testConstraint interactive]} {
if {[info exists ::tk_version] && ![testConstraint interactive]} {
exit
}
} else {
@@ -2815,6 +2861,7 @@ proc tcltest::runAllTests { {shell ""} } {
variable numTests
variable failFiles
variable DefaultValue
variable fullutf
FillFilesExisted
if {[llength [info level 0]] == 1} {
@@ -2900,8 +2947,8 @@ proc tcltest::runAllTests { {shell ""} } {
if {[catch {
incr numTestFiles
set pipeFd [open $cmd "r"]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $pipeFd -encoding utf-8
if {$fullutf} {
fconfigure $pipeFd -profile tcl8 -encoding utf-8
}
while {[gets $pipeFd line] >= 0} {
if {[regexp [join {
@@ -3087,6 +3134,8 @@ proc tcltest::normalizeMsg {msg} {
proc tcltest::makeFile {contents name {directory ""}} {
variable filesMade
variable fullutf
FillFilesExisted
if {[llength [info level 0]] == 3} {
@@ -3100,8 +3149,8 @@ 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
if {$fullutf} {
fconfigure $fd -profile tcl8 -encoding utf-8
}
if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
@@ -3245,14 +3294,16 @@ proc tcltest::removeDirectory {name {directory ""}} {
# None.
proc tcltest::viewFile {name {directory ""}} {
variable fullutf
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
set f [open $fullName]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $f -encoding utf-8
if {$fullutf} {
fconfigure $f -profile tcl8 -encoding utf-8
}
set data [read -nonewline $f]
close $f
@@ -3287,7 +3338,7 @@ proc tcltest::viewFile {name {directory ""}} {
# Side effects:
# None
if {![package vsatisfies [package provide Tcl] 8.7-]} {
if {!$::tcltest::fullutf} {
proc tcltest::bytestring {string} {
return [encoding convertfrom identity $string]
}
@@ -3449,7 +3500,7 @@ proc tcltest::threadReap {} {
# Initialize the constraints and set up command line arguments
namespace eval tcltest {
# Define initializers for all the built-in contraint definitions
# Define initializers for all the built-in constraint definitions
DefineConstraintInitializers
# Set up the constraints in the testConstraints array to be lazily
@@ -3458,7 +3509,7 @@ namespace eval tcltest {
trace add variable testConstraints read [namespace code SafeFetch]
# Only initialize constraints at package load time if an
# [initConstraintsHook] has been pre-defined. This is only
# [initConstraintsHook] has been predefined. This is only
# for compatibility support. The modern way to add a custom
# test constraint is to just call the [testConstraint] command
# straight away, without all this "hook" nonsense.