summaryrefslogtreecommitdiffstats
path: root/library/tcltest
diff options
context:
space:
mode:
Diffstat (limited to 'library/tcltest')
-rw-r--r--library/tcltest/pkgIndex.tcl2
-rw-r--r--library/tcltest/tcltest.tcl249
2 files changed, 115 insertions, 136 deletions
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
index 4b0a9bc..5b33ac7 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.3.5 [list source [file join $dir tcltest.tcl]]
+package ifneeded tcltest 2.3.1 [list source [file join $dir tcltest.tcl]]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index d6e6487..f363c80 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -15,6 +15,8 @@
# Copyright (c) 2000 by Ajuba Solutions
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
+#
+# RCS: @(#) $Id: tcltest.tcl,v 1.104 2009/04/08 16:05:15 dgp Exp $
package require Tcl 8.5 ;# -verbose line uses [info frame]
namespace eval tcltest {
@@ -22,7 +24,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.3.5
+ variable Version 2.3.1
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
@@ -84,7 +86,7 @@ namespace eval tcltest {
# None.
#
proc normalizePath {pathVar} {
- upvar 1 $pathVar path
+ upvar $pathVar path
set oldpwd [pwd]
catch {cd $path}
set path [pwd]
@@ -247,15 +249,15 @@ namespace eval tcltest {
# Kept only for compatibility
Default constraintsSpecified {} AcceptList
- trace add variable constraintsSpecified read [namespace code {
- set constraintsSpecified [array names testConstraints] ;#}]
+ trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
+ [array names ::tcltest::testConstraints] ;# }
# tests that use threads need to know which is the main thread
Default mainThread 1
variable mainThread
- if {[info commands thread::id] ne {}} {
+ if {[info commands thread::id] != {}} {
set mainThread [thread::id]
- } elseif {[info commands testthread] ne {}} {
+ } elseif {[info commands testthread] != {}} {
set mainThread [testthread id]
}
@@ -263,7 +265,7 @@ namespace eval tcltest {
# Tcl tests is the working directory. Whenever this value changes
# change to that directory.
variable workingDirectory
- trace add variable workingDirectory write \
+ trace variable workingDirectory w \
[namespace code {cd $workingDirectory ;#}]
Default workingDirectory [pwd] AcceptAbsolutePath
@@ -277,7 +279,7 @@ namespace eval tcltest {
# Set the location of the execuatble
Default tcltest [info nameofexecutable]
- trace add variable tcltest write [namespace code {testConstraint stdio \
+ trace variable tcltest w [namespace code {testConstraint stdio \
[eval [ConstraintInitializer stdio]] ;#}]
# save the platform information so it can be restored later
@@ -404,11 +406,11 @@ namespace eval tcltest {
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
- if {$outdir eq [temporaryDirectory]} {
+ if {[string equal $outdir [temporaryDirectory]]} {
variable filesExisted
FillFilesExisted
set filename [file tail $filename]
- if {$filename ni $filesExisted} {
+ if {[lsearch -exact $filesExisted $filename] == -1} {
lappend filesExisted $filename
}
}
@@ -448,11 +450,11 @@ namespace eval tcltest {
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
- if {$outdir eq [temporaryDirectory]} {
+ if {[string equal $outdir [temporaryDirectory]]} {
variable filesExisted
FillFilesExisted
set filename [file tail $filename]
- if {$filename ni $filesExisted} {
+ if {[lsearch -exact $filesExisted $filename] == -1} {
lappend filesExisted $filename
}
}
@@ -483,10 +485,8 @@ namespace eval tcltest {
variable Verify
variable Usage
variable OptionControlledVariables
- variable DefaultValue
set Usage($option) $usage
set Verify($option) $verify
- set DefaultValue($option) $value
if {[catch {$verify $value} msg]} {
return -code error $msg
} else {
@@ -534,7 +534,7 @@ namespace eval tcltest {
}
default {
# Exact match trumps ambiguity
- if {$option in $match} {
+ if {[lsearch -exact $match $option] >= 0} {
return $option
}
set values [join [lrange $match 0 end-1] ", "]
@@ -549,8 +549,7 @@ namespace eval tcltest {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
- trace add variable $varName read [namespace code {
- ProcessCmdLineArgs ;#}]
+ trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
}
}
@@ -558,11 +557,11 @@ namespace eval tcltest {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
- foreach pair [trace info variable $varName] {
- lassign $pair op cmd
- if {($op eq "read") &&
- [string match *ProcessCmdLineArgs* $cmd]} {
- trace remove variable $varName $op $cmd
+ foreach pair [trace vinfo $varName] {
+ foreach {op cmd} $pair break
+ if {[string equal r $op]
+ && [string match *ProcessCmdLineArgs* $cmd]} {
+ trace vdelete $varName $op $cmd
}
}
}
@@ -602,9 +601,7 @@ namespace eval tcltest {
}
}
proc configure args {
- if {[llength $args] > 1} {
- RemoveAutoConfigureTraces
- }
+ RemoveAutoConfigureTraces
set code [catch {Configure {*}$args} msg]
return -code $code $msg
}
@@ -699,7 +696,7 @@ namespace eval tcltest {
Option -constraints {} {
Do not skip the listed constraints listed in -constraints.
} AcceptList
- trace add variable Option(-constraints) write \
+ trace variable Option(-constraints) w \
[namespace code {SetSelectedConstraints ;#}]
# Don't run only the "-constraint" specified tests by default
@@ -708,15 +705,15 @@ namespace eval tcltest {
variable testConstraints
if {!$Option(-limitconstraints)} {return}
foreach c [array names testConstraints] {
- if {$c ni $Option(-constraints)} {
+ if {[lsearch -exact $Option(-constraints) $c] == -1} {
testConstraint $c 0
}
}
}
- Option -limitconstraints 0 {
+ Option -limitconstraints false {
whether to run only tests with the constraints
} AcceptBoolean limitConstraints
- trace add variable Option(-limitconstraints) write \
+ trace variable Option(-limitconstraints) w \
[namespace code {ClearUnselectedConstraints ;#}]
# A test application has to know how to load the tested commands
@@ -737,7 +734,7 @@ namespace eval tcltest {
}
set directory [AcceptDirectory $directory]
if {![file writable $directory]} {
- if {[workingDirectory] eq $directory} {
+ if {[string equal [workingDirectory] $directory]} {
# Special exception: accept the default value
# even if the directory is not writable
return $directory
@@ -751,7 +748,7 @@ namespace eval tcltest {
Option -tmpdir [workingDirectory] {
Save temporary files in the specified directory.
} AcceptTemporaryDirectory temporaryDirectory
- trace add variable Option(-tmpdir) write \
+ trace variable Option(-tmpdir) w \
[namespace code {normalizePath Option(-tmpdir) ;#}]
# Tests should not rely on the current working directory.
@@ -760,17 +757,17 @@ namespace eval tcltest {
Option -testdir [workingDirectory] {
Search tests in the specified directory.
} AcceptDirectory testsDirectory
- trace add variable Option(-testdir) write \
+ trace variable Option(-testdir) w \
[namespace code {normalizePath Option(-testdir) ;#}]
proc AcceptLoadFile { file } {
- if {$file eq {}} {return $file}
+ if {[string equal "" $file]} {return $file}
set file [file join [temporaryDirectory] $file]
return [AcceptReadable $file]
}
proc ReadLoadScript {args} {
variable Option
- if {$Option(-loadfile) eq {}} {return}
+ if {[string equal "" $Option(-loadfile)]} {return}
set tmp [open $Option(-loadfile) r]
loadScript [read $tmp]
close $tmp
@@ -778,7 +775,7 @@ namespace eval tcltest {
Option -loadfile {} {
Read the script to load the tested commands from the specified file.
} AcceptLoadFile loadFile
- trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
+ trace variable Option(-loadfile) w [namespace code ReadLoadScript]
proc AcceptOutFile { file } {
if {[string equal stderr $file]} {return $file}
@@ -790,39 +787,16 @@ namespace eval tcltest {
Option -outfile stdout {
Send output from test runs to the specified file.
} AcceptOutFile outputFile
- trace add variable Option(-outfile) write \
+ trace variable Option(-outfile) w \
[namespace code {outputChannel $Option(-outfile) ;#}]
# errors go to stderr by default
Option -errfile stderr {
Send errors from test runs to the specified file.
} AcceptOutFile errorFile
- trace add variable Option(-errfile) write \
+ trace variable Option(-errfile) w \
[namespace code {errorChannel $Option(-errfile) ;#}]
- proc loadIntoSlaveInterpreter {slave args} {
- variable Version
- interp eval $slave [package ifneeded tcltest $Version]
- interp eval $slave "tcltest::configure {*}{$args}"
- interp alias $slave ::tcltest::ReportToMaster \
- {} ::tcltest::ReportedFromSlave
- }
- proc ReportedFromSlave {total passed skipped failed because newfiles} {
- variable numTests
- variable skippedBecause
- variable createdNewFiles
- incr numTests(Total) $total
- incr numTests(Passed) $passed
- incr numTests(Skipped) $skipped
- incr numTests(Failed) $failed
- foreach {constraint count} $because {
- incr skippedBecause($constraint) $count
- }
- foreach {testfile created} $newfiles {
- lappend createdNewFiles($testfile) {*}$created
- }
- return
- }
}
#####################################################################
@@ -878,7 +852,7 @@ proc tcltest::DebugPArray {level arrayvar} {
variable debug
if {$debug >= $level} {
- catch {upvar 1 $arrayvar $arrayvar}
+ catch {upvar $arrayvar $arrayvar}
parray $arrayvar
}
return
@@ -962,7 +936,8 @@ proc tcltest::testConstraint {constraint {value ""}} {
if {[catch {expr {$value && $value}} msg]} {
return -code error $msg
}
- if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
+ if {[limitConstraints]
+ && [lsearch -exact $Option(-constraints) $constraint] == -1} {
set value 0
}
set testConstraints($constraint) $value
@@ -986,7 +961,11 @@ proc tcltest::interpreter { {interp ""} } {
if {[llength [info level 0]] == 1} {
return $tcltest
}
- set tcltest $interp
+ if {[string equal {} $interp]} {
+ set tcltest {}
+ } else {
+ set tcltest $interp
+ }
}
#####################################################################
@@ -1051,7 +1030,7 @@ proc tcltest::PrintError {errorMsg} {
[expr {80 - $InitialMsgLen}]]]
puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
- while {$beginningIndex ne "end"} {
+ while {![string equal end $beginningIndex]} {
puts -nonewline [errorChannel] \
[string repeat " " $InitialMsgLen]
if {($endingIndex - $beginningIndex)
@@ -1104,7 +1083,7 @@ proc tcltest::PrintError {errorMsg} {
proc tcltest::SafeFetch {n1 n2 op} {
variable testConstraints
DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
- if {$n2 eq {}} {return}
+ if {[string equal {} $n2]} {return}
if {![info exists testConstraints($n2)]} {
if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
testConstraint $n2 0
@@ -1249,8 +1228,9 @@ proc tcltest::DefineConstraintInitializers {} {
# are running as root on Unix.
ConstraintInitializer root {expr \
- {($::tcl_platform(platform) eq "unix") &&
- ($::tcl_platform(user) in {root {}})}}
+ {[string equal unix $::tcl_platform(platform)]
+ && ([string equal root $::tcl_platform(user)]
+ || [string equal "" $::tcl_platform(user)])}}
ConstraintInitializer notRoot {expr {![testConstraint root]}}
# Set nonBlockFiles constraint: 1 means this platform supports
@@ -1258,7 +1238,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
}
@@ -1284,10 +1264,10 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer unixExecs {
set code 1
- if {$::tcl_platform(platform) eq "macintosh"} {
+ if {[string equal macintosh $::tcl_platform(platform)]} {
set code 0
}
- if {$::tcl_platform(platform) eq "windows"} {
+ if {[string equal windows $::tcl_platform(platform)]} {
if {[catch {
set file _tcl_test_remove_me.txt
makeFile {hello} $file
@@ -1381,7 +1361,7 @@ proc tcltest::Usage { {option ""} } {
set allOpts [concat -help [Configure]]
foreach opt $allOpts {
set foo [Usage $opt]
- lassign $foo x type($opt) usage($opt)
+ foreach [list x type($opt) usage($opt)] $foo break
set line($opt) " $opt $type($opt) "
set length($opt) [string length $line($opt)]
if {$length($opt) > $max} {set max $length($opt)}
@@ -1405,7 +1385,7 @@ proc tcltest::Usage { {option ""} } {
append msg $u
}
return $msg\n
- } elseif {$option eq "-help"} {
+ } elseif {[string equal -help $option]} {
return [list -help "" "Display this usage information."]
} else {
set type [lindex [info args $Verify($option)] 0]
@@ -1431,7 +1411,7 @@ proc tcltest::Usage { {option ""} } {
proc tcltest::ProcessFlags {flagArray} {
# Process -help first
- if {"-help" in $flagArray} {
+ if {[lsearch -exact $flagArray {-help}] != -1} {
PrintUsageInfo
exit 1
}
@@ -1440,14 +1420,14 @@ proc tcltest::ProcessFlags {flagArray} {
RemoveAutoConfigureTraces
} else {
set args $flagArray
- while {[llength $args] > 1 && [catch {configure {*}$args} msg]} {
+ while {[llength $args]>1 && [catch {configure {*}$args} msg]} {
# Something went wrong parsing $args for tcltest options
# Check whether the problem is "unknown option"
if {[regexp {^unknown option (\S+):} $msg -> option]} {
# Could be this is an option the Hook knows about
set moreOptions [processCmdLineArgsAddFlagsHook]
- if {$option ni $moreOptions} {
+ if {[lsearch -exact $moreOptions $option] == -1} {
# Nope. Report the error, including additional options,
# but keep going
if {[llength $moreOptions]} {
@@ -1466,7 +1446,7 @@ proc tcltest::ProcessFlags {flagArray} {
# To recover, find that unknown option and remove up to it.
# then retry
- while {[lindex $args 0] ne $option} {
+ while {![string equal [lindex $args 0] $option]} {
set args [lrange $args 2 end]
}
set args [lrange $args 2 end]
@@ -1572,7 +1552,7 @@ proc tcltest::Replace::puts {args} {
}
2 {
# Either -nonewline or channelId has been specified
- if {[lindex $args 0] eq "-nonewline"} {
+ if {[string equal -nonewline [lindex $args 0]]} {
append outData [lindex $args end]
return
# return [Puts -nonewline [lindex $args end]]
@@ -1582,7 +1562,7 @@ proc tcltest::Replace::puts {args} {
}
}
3 {
- if {[lindex $args 0] eq "-nonewline"} {
+ if {[string equal -nonewline [lindex $args 0]]} {
# Both -nonewline and channelId are specified, unless
# it's an error. -nonewline is supposed to be argv[0].
set channel [lindex $args 1]
@@ -1592,10 +1572,12 @@ proc tcltest::Replace::puts {args} {
}
if {[info exists channel]} {
- if {$channel in [list [[namespace parent]::outputChannel] stdout]} {
+ if {[string equal $channel [[namespace parent]::outputChannel]]
+ || [string equal $channel stdout]} {
append outData [lindex $args end]$newline
return
- } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} {
+ } elseif {[string equal $channel [[namespace parent]::errorChannel]]
+ || [string equal $channel stderr]} {
append errData [lindex $args end]$newline
return
}
@@ -1764,7 +1746,7 @@ proc tcltest::SubstArguments {argList} {
set argList {}
}
- if {$token ne {}} {
+ if {$token != {}} {
# If we saw a word with quote before, then there is a
# multi-word token starting with that word. In this case,
# add the text and the current word to this token.
@@ -1871,7 +1853,10 @@ proc tcltest::test {name description args} {
# Pre-define 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 match
+ foreach item {constraints setup cleanup body result returnCodes
+ match} {
+ set $item {}
+ }
# Set the default match mode
set match exact
@@ -1883,7 +1868,8 @@ proc tcltest::test {name description args} {
# The old test format can't have a 3rd argument (constraints or
# script) that starts with '-'.
- if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} {
+ if {[string match -* [lindex $args 0]]
+ || ([llength $args] <= 1)} {
if {[llength $args] == 1} {
set list [SubstArguments [lindex $args 0]]
foreach {element value} $list {
@@ -1904,7 +1890,7 @@ proc tcltest::test {name description args} {
-match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
- if {$flag ni $validFlags} {
+ if {[lsearch -exact $validFlags $flag] == -1} {
incr testLevel -1
set sorted [lsort $validFlags]
set options [join [lrange $sorted 0 end-1] ", "]
@@ -1920,7 +1906,7 @@ proc tcltest::test {name description args} {
# Check the values supplied for -match
variable CustomMatch
- if {$match ni [array names CustomMatch]} {
+ if {[lsearch [array names CustomMatch] $match] == -1} {
incr testLevel -1
set sorted [lsort [array names CustomMatch]]
set values [join [lrange $sorted 0 end-1] ", "]
@@ -1984,7 +1970,7 @@ proc tcltest::test {name description args} {
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
- lassign $testResult actualAnswer returnCode
+ foreach {actualAnswer returnCode} $testResult break
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCode(body) $::errorCode
@@ -2020,11 +2006,11 @@ proc tcltest::test {name description args} {
if {([preserveCore] > 1) && ($coreFailure)} {
append coreMsg "\nMoving file to:\
[file join [temporaryDirectory] core-$name]"
- catch {file rename -force -- \
+ catch {file rename -force \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$name]
} msg
- if {$msg ne {}} {
+ if {[string length $msg] > 0} {
append coreMsg "\nError:\
Problem renaming core file: $msg"
}
@@ -2034,7 +2020,7 @@ proc tcltest::test {name description args} {
# check if the return code matched the expected return code
set codeFailure 0
- if {!$setupFailure && ($returnCode ni $returnCodes)} {
+ if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
set codeFailure 1
}
@@ -2113,12 +2099,12 @@ proc tcltest::test {name description args} {
set testFd [open $testFile r]
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
- "^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
+ "^\[ \t\]*test [string map {. \\.} $name] "]+1}]
close $testFd
}
}
if {[info exists testLine]} {
- puts [outputChannel] "$testFile:$testLine: error: test failed:\
+ puts [outputChannel] "$testFile:$testLine: test failed:\
$name [string trim $description]"
}
}
@@ -2158,7 +2144,7 @@ proc tcltest::test {name description args} {
puts [outputChannel] "---- Return code should have been\
one of: $returnCodes"
if {[IsVerbose error]} {
- if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
+ if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} {
puts [outputChannel] "---- errorInfo: $errorInfo(body)"
puts [outputChannel] "---- errorCode: $errorCode(body)"
}
@@ -2239,7 +2225,7 @@ proc tcltest::Skipped {name constraints} {
}
return 1
}
- if {$constraints eq {}} {
+ if {[string equal {} $constraints]} {
# If we're limited to the listed constraints and there aren't
# any listed, then we shouldn't run the test.
if {[limitConstraints]} {
@@ -2370,14 +2356,6 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
FillFilesExisted
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) \
- $numTests(Failed) [array get skippedBecause] \
- [array get createdNewFiles]
- set testSingleFile false
- }
-
# Call the cleanup hook
cleanupTestsHook
@@ -2390,7 +2368,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
foreach file $filesMade {
if {[file exists $file]} {
DebugDo 1 {Warn "cleanupTests deleting $file..."}
- catch {file delete -force -- $file}
+ catch {file delete -force $file}
}
}
set currentFiles {}
@@ -2400,7 +2378,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
}
set newFiles {}
foreach file $currentFiles {
- if {$file ni $filesExisted} {
+ if {[lsearch -exact $filesExisted $file] == -1} {
lappend newFiles $file
}
}
@@ -2483,7 +2461,8 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# then add current file to failFile list if any tests in this
# file failed
- if {$currentFailure && ($testFileName ni $failFiles)} {
+ if {$currentFailure \
+ && ([lsearch -exact $failFiles $testFileName] == -1)} {
lappend failFiles $testFileName
}
set currentFailure false
@@ -2543,11 +2522,11 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
puts [outputChannel] "produced core file! \
Moving file to: \
[file join [temporaryDirectory] core-$testFileName]"
- catch {file rename -force -- \
+ catch {file rename -force \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$testFileName]
} msg
- if {$msg ne {}} {
+ if {[string length $msg] > 0} {
PrintError "Problem renaming file: $msg"
}
} else {
@@ -2625,7 +2604,7 @@ proc tcltest::GetMatchingFiles { args } {
# Add to result list all files in match list and not in skip list
foreach file $matchFileList {
- if {$file ni $skipFileList} {
+ if {[lsearch -exact $skipFileList $file] == -1} {
lappend matchingFiles $file
}
}
@@ -2672,7 +2651,7 @@ proc tcltest::GetMatchingDirectories {rootdir} {
foreach pattern [matchDirectories] {
foreach path [glob -directory $rootdir -types d -nocomplain -- \
$pattern] {
- if {$path ni $skipDirs} {
+ if {[lsearch -exact $skipDirs $path] == -1} {
set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
if {[file exists [file join $path all.tcl]]} {
lappend matchDirs $path
@@ -2708,7 +2687,6 @@ proc tcltest::runAllTests { {shell ""} } {
variable numTestFiles
variable numTests
variable failFiles
- variable DefaultValue
FillFilesExisted
if {[llength [info level 0]] == 1} {
@@ -2725,7 +2703,7 @@ proc tcltest::runAllTests { {shell ""} } {
# [file system] first available in Tcl 8.4
if {![catch {file system [testsDirectory]} result]
- && ([lindex $result 0] ne "native")} {
+ && ![string equal native [lindex $result 0]]} {
# If we aren't running in the native filesystem, then we must
# run the tests in a single process (via 'source'), because
# trying to run then via a pipe will fail since the files don't
@@ -2772,13 +2750,8 @@ proc tcltest::runAllTests { {shell ""} } {
# needs to read and process output of children.
set childargv [list]
foreach opt [Configure] {
- if {$opt eq "-outfile"} {continue}
- set value [Configure $opt]
- # Don't bother passing default configuration options
- if {$value eq $DefaultValue($opt)} {
- continue
- }
- lappend childargv $opt $value
+ if {[string equal $opt -outfile]} {continue}
+ lappend childargv $opt [Configure $opt]
}
set cmd [linsert $childargv 0 | $shell $file]
if {[catch {
@@ -2868,6 +2841,11 @@ proc tcltest::runAllTests { {shell ""} } {
# none.
proc tcltest::loadTestedCommands {} {
+ variable l
+ if {[string equal {} [loadScript]]} {
+ return
+ }
+
return [uplevel 1 [loadScript]]
}
@@ -2910,15 +2888,16 @@ proc tcltest::saveState {} {
proc tcltest::restoreState {} {
variable saveState
foreach p [uplevel 1 {::info procs}] {
- if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne
- [uplevel 1 [list ::namespace origin $p]])} {
+ if {([lsearch [lindex $saveState 0] $p] < 0)
+ && ![string equal [namespace current]::$p \
+ [uplevel 1 [list ::namespace origin $p]]]} {
DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
uplevel 1 [list ::catch [list ::rename $p {}]]
}
}
foreach p [uplevel 1 {::info vars}] {
- if {$p ni [lindex $saveState 1]} {
+ if {[lsearch [lindex $saveState 1] $p] < 0} {
DebugPuts 2 "[lindex [info level 0] 0]:\
Removing variable $p"
uplevel 1 [list ::catch [list ::unset $p]]
@@ -2979,15 +2958,15 @@ proc tcltest::makeFile {contents name {directory ""}} {
putting ``$contents'' into $fullName"
set fd [open $fullName w]
- chan configure $fd -translation lf
- if {[string index $contents end] eq "\n"} {
+ fconfigure $fd -translation lf
+ if {[string equal [string index $contents end] \n]} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
- if {$fullName ni $filesMade} {
+ if {[lsearch -exact $filesMade $fullName] == -1} {
lappend filesMade $fullName
}
return $fullName
@@ -3027,7 +3006,7 @@ proc tcltest::removeFile {name {directory ""}} {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
- return [file delete -- $fullName]
+ return [file delete $fullName]
}
# tcltest::makeDirectory --
@@ -3057,7 +3036,7 @@ proc tcltest::makeDirectory {name {directory ""}} {
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
file mkdir $fullName
- if {$fullName ni $filesMade} {
+ if {[lsearch -exact $filesMade $fullName] == -1} {
lappend filesMade $fullName
}
return $fullName
@@ -3098,7 +3077,7 @@ proc tcltest::removeDirectory {name {directory ""}} {
Warn "removeDirectory removing \"$fullName\":\n not a directory"
}
}
- return [file delete -force -- $fullName]
+ return [file delete -force $fullName]
}
# tcltest::viewFile --
@@ -3195,7 +3174,7 @@ proc tcltest::LeakFiles {old} {
}
set leak {}
foreach p $new {
- if {$p ni $old} {
+ if {[lsearch $old $p] < 0} {
lappend leak $p
}
}
@@ -3266,7 +3245,7 @@ proc tcltest::RestoreLocale {} {
#
proc tcltest::threadReap {} {
- if {[info commands testthread] ne {}} {
+ if {[info commands testthread] != {}} {
# testthread built into tcltest
@@ -3286,7 +3265,7 @@ proc tcltest::threadReap {} {
}
testthread errorproc ThreadError
return [llength [testthread names]]
- } elseif {[info commands thread::id] ne {}} {
+ } elseif {[info commands thread::id] != {}} {
# Thread extension
@@ -3318,15 +3297,15 @@ namespace eval tcltest {
# Set up the constraints in the testConstraints array to be lazily
# initialized by a registered initializer, or by "false" if no
# initializer is registered.
- trace add variable testConstraints read [namespace code SafeFetch]
+ trace variable testConstraints r [namespace code SafeFetch]
# Only initialize constraints at package load time if an
# [initConstraintsHook] has been pre-defined. 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.
- if {[namespace current] eq
- [namespace qualifiers [namespace which initConstraintsHook]]} {
+ if {[string equal [namespace current] \
+ [namespace qualifiers [namespace which initConstraintsHook]]]} {
InitConstraints
} else {
proc initConstraintsHook {} {}
@@ -3363,15 +3342,15 @@ namespace eval tcltest {
proc LoadTimeCmdLineArgParsingRequired {} {
set required false
- if {[info exists ::argv] && ("-help" in $::argv)} {
+ if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
# The command line asks for -help, so give it (and exit)
# right now. ([configure] does not process -help)
set required true
}
foreach hook { PrintUsageInfoHook processCmdLineArgsHook
processCmdLineArgsAddFlagsHook } {
- if {[namespace current] eq
- [namespace qualifiers [namespace which $hook]]} {
+ if {[string equal [namespace current] [namespace qualifiers \
+ [namespace which $hook]]]} {
set required true
} else {
proc $hook args {}
generated by cgit v0.12 at 2025-09-01 21:55:35 (GMT)