ag/cpython-source-deps
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import Tcl 8.6.11

Browse Source
This commit is contained in:
Steve Dower
2021-03-30 00:51:39 +01:00
parent 3bb8e3e086
commit 1aadb2455c
923 changed files with 79104 additions and 62616 deletions
Download Patch File Download Diff File Expand all files Collapse all files

159
library/tcltest/tcltest.tcl
View File

@@ -11,8 +11,8 @@
# Microsystems.
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
# Copyright (c) 1998-1999 Scriptics Corporation.
# Copyright (c) 2000 Ajuba Solutions
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
@@ -22,7 +22,7 @@ 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.1
variable Version 2.5.3
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
@@ -41,7 +41,9 @@ namespace eval tcltest {
outputChannel testConstraint
# Export commands that are duplication (candidates for deprecation)
namespace export bytestring ;# dups [encoding convertfrom identity]
if {![package vsatisfies [package provide Tcl] 8.7-]} {
namespace export bytestring ;# dups [encoding convertfrom identity]
}
namespace export debug ;# [configure -debug]
namespace export errorFile ;# [configure -errfile]
namespace export limitConstraints ;# [configure -limitconstraints]
@@ -640,7 +642,7 @@ namespace eval tcltest {
proc IsVerbose {level} {
variable Option
return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
return [expr {[lsearch -exact $Option(-verbose) $level] >= 0}]
}
# Default verbosity is to show bodies of failed tests
@@ -811,14 +813,14 @@ namespace eval tcltest {
trace add variable Option(-errfile) write \
[namespace code {errorChannel $Option(-errfile) ;#}]
proc loadIntoSlaveInterpreter {slave args} {
proc loadIntoChildInterpreter {child args} {
variable Version
interp eval $slave [package ifneeded tcltest $Version]
interp eval $slave "tcltest::configure {*}{$args}"
interp alias $slave ::tcltest::ReportToMaster \
{} ::tcltest::ReportedFromSlave
interp eval $child [package ifneeded tcltest $Version]
interp eval $child "tcltest::configure {*}{$args}"
interp alias $child ::tcltest::ReportToParent \
{} ::tcltest::ReportedFromChild
}
proc ReportedFromSlave {total passed skipped failed because newfiles} {
proc ReportedFromChild {total passed skipped failed because newfiles} {
variable numTests
variable skippedBecause
variable createdNewFiles
@@ -970,7 +972,7 @@ proc tcltest::testConstraint {constraint {value ""}} {
return $testConstraints($constraint)
}
# Check for boolean values
if {[catch {expr {$value && $value}} msg]} {
if {[catch {expr {$value && 1}} msg]} {
return -code error $msg
}
if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
@@ -1269,7 +1271,7 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer nonBlockFiles {
set code [expr {[catch {set f [open defs r]}]
|| [catch {chan configure $f -blocking off}]}]
|| [catch {fconfigure $f -blocking off}]}]
catch {close $f}
set code
}
@@ -1982,16 +1984,24 @@ proc tcltest::test {name description args} {
}
}
# First, run the setup script
# First, run the setup script (or a hook if it presents):
if {[set cmd [namespace which -command [namespace current]::SetupTest]] ne ""} {
set setup [list $cmd $setup]
}
set processTest 1
set code [catch {uplevel 1 $setup} setupMsg]
if {$code == 1} {
set errorInfo(setup) $::errorInfo
set errorCodeRes(setup) $::errorCode
if {$errorCodeRes(setup) eq "BYPASS-SKIPPED-TEST"} {
_noticeSkipped $name $setupMsg
set processTest [set code 0]
}
}
set setupFailure [expr {$code != 0}]
# Only run the test body if the setup was successful
if {!$setupFailure} {
if {$processTest && !$setupFailure} {
# Register startup time
if {[IsVerbose msec] || [IsVerbose usec]} {
@@ -2014,16 +2024,20 @@ proc tcltest::test {name description args} {
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCodeRes(body) $::errorCode
if {$errorCodeRes(body) eq "BYPASS-SKIPPED-TEST"} {
_noticeSkipped $name $actualAnswer
set processTest [set returnCode 0]
}
}
}
# check if the return code matched the expected return code
set codeFailure 0
if {!$setupFailure && ($returnCode ni $returnCodes)} {
if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
set errorCodeFailure 0
if {!$setupFailure && !$codeFailure && $returnCode == 1 && \
if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \
![string match $errorCode $errorCodeRes(body)]} {
set errorCodeFailure 1
}
@@ -2032,7 +2046,7 @@ proc tcltest::test {name description args} {
# them. If the comparison fails, then so did the test.
set outputFailure 0
variable outData
if {[info exists output] && !$codeFailure} {
if {$processTest && [info exists output] && !$codeFailure} {
if {[set outputCompare [catch {
CompareStrings $outData $output $match
} outputMatch]] == 0} {
@@ -2044,7 +2058,7 @@ proc tcltest::test {name description args} {
set errorFailure 0
variable errData
if {[info exists errorOutput] && !$codeFailure} {
if {$processTest && [info exists errorOutput] && !$codeFailure} {
if {[set errorCompare [catch {
CompareStrings $errData $errorOutput $match
} errorMatch]] == 0} {
@@ -2056,7 +2070,9 @@ proc tcltest::test {name description args} {
# check if the answer matched the expected answer
# Only check if we ran the body of the test (no setup failure)
if {$setupFailure || $codeFailure} {
if {!$processTest} {
set scriptFailure 0
} elseif {$setupFailure || $codeFailure} {
set scriptFailure 0
} elseif {[set scriptCompare [catch {
CompareStrings $actualAnswer $result $match
@@ -2066,7 +2082,10 @@ proc tcltest::test {name description args} {
set scriptFailure 1
}
# Always run the cleanup script
# Always run the cleanup script (or a hook if it presents):
if {[set cmd [namespace which -command [namespace current]::CleanupTest]] ne ""} {
set cleanup [list $cmd $cleanup]
}
set code [catch {uplevel 1 $cleanup} cleanupMsg]
if {$code == 1} {
set errorInfo(cleanup) $::errorInfo
@@ -2117,6 +2136,12 @@ proc tcltest::test {name description args} {
}
}
# if skipped, it is safe to return here
if {!$processTest} {
incr testLevel -1
return
}
# if we didn't experience any failures, then we passed
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
@@ -2177,7 +2202,7 @@ proc tcltest::test {name description args} {
puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
}
}
if {$scriptFailure} {
if {$processTest && $scriptFailure} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
@@ -2244,6 +2269,32 @@ proc tcltest::test {name description args} {
return
}
# Skip --
#
# Skips a running test and add a reason to skipped "constraints". Can be used
# to conditional intended abort of the test.
#
# Side Effects: Maintains tally of total tests seen and tests skipped.
#
proc tcltest::Skip {reason} {
return -code error -errorcode BYPASS-SKIPPED-TEST $reason
}
proc tcltest::_noticeSkipped {name reason} {
variable testLevel
variable numTests
if {[IsVerbose skip]} {
puts [outputChannel] "++++ $name SKIPPED: $reason"
}
if {$testLevel == 1} {
incr numTests(Skipped)
AddToSkippedBecause $reason
}
}
# Skipped --
#
# Given a test name and it constraints, returns a boolean indicating
@@ -2324,14 +2375,7 @@ proc tcltest::Skipped {name constraints} {
}
if {!$doTest} {
if {[IsVerbose skip]} {
puts [outputChannel] "++++ $name SKIPPED: $constraints"
}
if {$testLevel == 1} {
incr numTests(Skipped)
AddToSkippedBecause $constraints
}
_noticeSkipped $name $constraints
return 1
}
}
@@ -2354,6 +2398,10 @@ proc tcltest::RunTest {name script} {
memory tag $name
}
# run the test script (or a hook if it presents):
if {[set cmd [namespace which -command [namespace current]::EvalTest]] ne ""} {
set script [list $cmd $script]
}
set code [catch {uplevel 1 $script} actualAnswer]
return [list $actualAnswer $code]
@@ -2416,8 +2464,8 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
set testFileName [file tail [info script]]
# Hook to handle reporting to a parent interpreter
if {[llength [info commands [namespace current]::ReportToMaster]]} {
ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \
if {[llength [info commands [namespace current]::ReportToParent]]} {
ReportToParent $numTests(Total) $numTests(Passed) $numTests(Skipped) \
$numTests(Failed) [array get skippedBecause] \
[array get createdNewFiles]
set testSingleFile false
@@ -2752,7 +2800,6 @@ proc tcltest::runAllTests { {shell ""} } {
variable numTests
variable failFiles
variable DefaultValue
set failFilesAccum {}
FillFilesExisted
if {[llength [info level 0]] == 1} {
@@ -2808,8 +2855,18 @@ proc tcltest::runAllTests { {shell ""} } {
flush [outputChannel]
if {[singleProcess]} {
incr numTestFiles
uplevel 1 [list ::source $file]
if {[catch {
incr numTestFiles
uplevel 1 [list ::source $file]
} msg]} {
puts [outputChannel] "Test file error: $msg"
# append the name of the test to a list to be reported
# later
lappend testFileFailures $file
}
if {$numTests(Failed) > 0} {
set failFilesSet 1
}
} else {
# Pass along our configuration to the child processes.
# EXCEPT for the -outfile, because the parent process
@@ -2842,7 +2899,7 @@ proc tcltest::runAllTests { {shell ""} } {
}
if {$Failed > 0} {
lappend failFiles $testFile
lappend failFilesAccum $testFile
set failFilesSet 1
}
} elseif {[regexp [join {
{^Number of tests skipped }
@@ -2889,7 +2946,7 @@ proc tcltest::runAllTests { {shell ""} } {
puts [outputChannel] ""
puts [outputChannel] [string repeat ~ 44]
}
return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}]
return [expr {[info exists testFileFailures] || [info exists failFilesSet]}]
}
#####################################################################
@@ -3024,7 +3081,10 @@ proc tcltest::makeFile {contents name {directory ""}} {
putting ``$contents'' into $fullName"
set fd [open $fullName w]
chan configure $fd -translation lf
fconfigure $fd -translation lf
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $fd -encoding utf-8
}
if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
} else {
@@ -3061,11 +3121,12 @@ proc tcltest::removeFile {name {directory ""}} {
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
if {$idx == -1} {
if {$idx < 0} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not created by makeFile"
}
} else {
set filesMade [lreplace $filesMade $idx $idx]
}
if {![file isfile $fullName]} {
DebugDo 1 {
@@ -3137,7 +3198,7 @@ proc tcltest::removeDirectory {name {directory ""}} {
DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
if {$idx == -1} {
if {$idx < 0} {
DebugDo 1 {
Warn "removeDirectory removing \"$fullName\":\n not created\
by makeDirectory"
@@ -3172,6 +3233,9 @@ 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
}
set data [read -nonewline $f]
close $f
return $data
@@ -3186,13 +3250,16 @@ proc tcltest::viewFile {name {directory ""}} {
# procedures that are supposed to accept strings with embedded NULL
# bytes.
# 2. Confirm that a string result has a certain pattern of bytes, for
# instance to confirm that "\xe0\0" in a Tcl script is stored
# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
# instance to confirm that "\xE0\0" in a Tcl script is stored
# internally in UTF-8 as the sequence of bytes "\xC3\xA0\xC0\x80".
#
# Generally, it's a bad idea to examine the bytes in a Tcl string or to
# construct improperly formed strings in this manner, because it involves
# exposing that Tcl uses UTF-8 internally.
#
# This function doesn't work any more in Tcl 8.7, since the 'identity'
# is gone (TIP #345)
#
# Arguments:
# string being converted
#
@@ -3202,8 +3269,10 @@ proc tcltest::viewFile {name {directory ""}} {
# Side effects:
# None
proc tcltest::bytestring {string} {
return [encoding convertfrom identity $string]
if {![package vsatisfies [package provide Tcl] 8.7-]} {
proc tcltest::bytestring {string} {
return [encoding convertfrom identity $string]
}
}
# tcltest::OpenFiles --