summaryrefslogtreecommitdiffstats
path: root/library/tcltest/tcltest.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'library/tcltest/tcltest.tcl')
-rw-r--r--library/tcltest/tcltest.tcl276
1 files changed, 155 insertions, 121 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 5d89748..d6e6487 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -16,13 +16,13 @@
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
-package require Tcl 8.3 ;# uses [glob -directory]
+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.2.11
+ variable Version 2.3.5
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
@@ -84,7 +84,7 @@ namespace eval tcltest {
# None.
#
proc normalizePath {pathVar} {
- upvar $pathVar path
+ upvar 1 $pathVar path
set oldpwd [pwd]
catch {cd $path}
set path [pwd]
@@ -247,15 +247,15 @@ namespace eval tcltest {
# Kept only for compatibility
Default constraintsSpecified {} AcceptList
- trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
- [array names ::tcltest::testConstraints] ;# }
+ trace add variable constraintsSpecified read [namespace code {
+ set constraintsSpecified [array names testConstraints] ;#}]
# tests that use threads need to know which is the main thread
Default mainThread 1
variable mainThread
- if {[info commands thread::id] != {}} {
+ if {[info commands thread::id] ne {}} {
set mainThread [thread::id]
- } elseif {[info commands testthread] != {}} {
+ } elseif {[info commands testthread] ne {}} {
set mainThread [testthread id]
}
@@ -263,7 +263,7 @@ namespace eval tcltest {
# Tcl tests is the working directory. Whenever this value changes
# change to that directory.
variable workingDirectory
- trace variable workingDirectory w \
+ trace add variable workingDirectory write \
[namespace code {cd $workingDirectory ;#}]
Default workingDirectory [pwd] AcceptAbsolutePath
@@ -277,7 +277,7 @@ namespace eval tcltest {
# Set the location of the execuatble
Default tcltest [info nameofexecutable]
- trace variable tcltest w [namespace code {testConstraint stdio \
+ trace add variable tcltest write [namespace code {testConstraint stdio \
[eval [ConstraintInitializer stdio]] ;#}]
# save the platform information so it can be restored later
@@ -404,11 +404,11 @@ namespace eval tcltest {
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
- if {[string equal $outdir [temporaryDirectory]]} {
+ if {$outdir eq [temporaryDirectory]} {
variable filesExisted
FillFilesExisted
set filename [file tail $filename]
- if {[lsearch -exact $filesExisted $filename] == -1} {
+ if {$filename ni $filesExisted} {
lappend filesExisted $filename
}
}
@@ -448,11 +448,11 @@ namespace eval tcltest {
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
- if {[string equal $outdir [temporaryDirectory]]} {
+ if {$outdir eq [temporaryDirectory]} {
variable filesExisted
FillFilesExisted
set filename [file tail $filename]
- if {[lsearch -exact $filesExisted $filename] == -1} {
+ if {$filename ni $filesExisted} {
lappend filesExisted $filename
}
}
@@ -534,7 +534,7 @@ namespace eval tcltest {
}
default {
# Exact match trumps ambiguity
- if {[lsearch -exact $match $option] >= 0} {
+ if {$option in $match} {
return $option
}
set values [join [lrange $match 0 end-1] ", "]
@@ -549,7 +549,8 @@ namespace eval tcltest {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
- trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
+ trace add variable $varName read [namespace code {
+ ProcessCmdLineArgs ;#}]
}
}
@@ -557,11 +558,11 @@ namespace eval tcltest {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
- foreach pair [trace vinfo $varName] {
- foreach {op cmd} $pair break
- if {[string equal r $op]
- && [string match *ProcessCmdLineArgs* $cmd]} {
- trace vdelete $varName $op $cmd
+ foreach pair [trace info variable $varName] {
+ lassign $pair op cmd
+ if {($op eq "read") &&
+ [string match *ProcessCmdLineArgs* $cmd]} {
+ trace remove variable $varName $op $cmd
}
}
}
@@ -604,22 +605,22 @@ namespace eval tcltest {
if {[llength $args] > 1} {
RemoveAutoConfigureTraces
}
- set code [catch {eval Configure $args} msg]
+ set code [catch {Configure {*}$args} msg]
return -code $code $msg
}
proc AcceptVerbose { level } {
set level [AcceptList $level]
if {[llength $level] == 1} {
- if {![regexp {^(pass|body|skip|start|error)$} $level]} {
+ if {![regexp {^(pass|body|skip|start|error|line)$} $level]} {
# translate single characters abbreviations to expanded list
- set level [string map {p pass b body s skip t start e error} \
+ set level [string map {p pass b body s skip t start e error l line} \
[split $level {}]]
}
}
set valid [list]
foreach v $level {
- if {[regexp {^(pass|body|skip|start|error)$} $v]} {
+ if {[regexp {^(pass|body|skip|start|error|line)$} $v]} {
lappend valid $v
}
}
@@ -633,11 +634,12 @@ namespace eval tcltest {
# Default verbosity is to show bodies of failed tests
Option -verbose {body error} {
- Takes any combination of the values 'p', 's', 'b', 't' and 'e'.
+ Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
Test suite will display all passed tests if 'p' is specified, all
skipped tests if 's' is specified, the bodies of failed tests if
'b' is specified, and when tests start if 't' is specified.
- ErrorInfo is displayed if 'e' is specified.
+ ErrorInfo is displayed if 'e' is specified. Source file line
+ information of failed tests is displayed if 'l' is specified.
} AcceptVerbose verbose
# Match and skip patterns default to the empty list, except for
@@ -697,7 +699,7 @@ namespace eval tcltest {
Option -constraints {} {
Do not skip the listed constraints listed in -constraints.
} AcceptList
- trace variable Option(-constraints) w \
+ trace add variable Option(-constraints) write \
[namespace code {SetSelectedConstraints ;#}]
# Don't run only the "-constraint" specified tests by default
@@ -706,7 +708,7 @@ namespace eval tcltest {
variable testConstraints
if {!$Option(-limitconstraints)} {return}
foreach c [array names testConstraints] {
- if {[lsearch -exact $Option(-constraints) $c] == -1} {
+ if {$c ni $Option(-constraints)} {
testConstraint $c 0
}
}
@@ -714,7 +716,7 @@ namespace eval tcltest {
Option -limitconstraints 0 {
whether to run only tests with the constraints
} AcceptBoolean limitConstraints
- trace variable Option(-limitconstraints) w \
+ trace add variable Option(-limitconstraints) write \
[namespace code {ClearUnselectedConstraints ;#}]
# A test application has to know how to load the tested commands
@@ -735,7 +737,7 @@ namespace eval tcltest {
}
set directory [AcceptDirectory $directory]
if {![file writable $directory]} {
- if {[string equal [workingDirectory] $directory]} {
+ if {[workingDirectory] eq $directory} {
# Special exception: accept the default value
# even if the directory is not writable
return $directory
@@ -749,7 +751,7 @@ namespace eval tcltest {
Option -tmpdir [workingDirectory] {
Save temporary files in the specified directory.
} AcceptTemporaryDirectory temporaryDirectory
- trace variable Option(-tmpdir) w \
+ trace add variable Option(-tmpdir) write \
[namespace code {normalizePath Option(-tmpdir) ;#}]
# Tests should not rely on the current working directory.
@@ -758,17 +760,17 @@ namespace eval tcltest {
Option -testdir [workingDirectory] {
Search tests in the specified directory.
} AcceptDirectory testsDirectory
- trace variable Option(-testdir) w \
+ trace add variable Option(-testdir) write \
[namespace code {normalizePath Option(-testdir) ;#}]
proc AcceptLoadFile { file } {
- if {[string equal "" $file]} {return $file}
+ if {$file eq {}} {return $file}
set file [file join [temporaryDirectory] $file]
return [AcceptReadable $file]
}
proc ReadLoadScript {args} {
variable Option
- if {[string equal "" $Option(-loadfile)]} {return}
+ if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
loadScript [read $tmp]
close $tmp
@@ -776,7 +778,7 @@ namespace eval tcltest {
Option -loadfile {} {
Read the script to load the tested commands from the specified file.
} AcceptLoadFile loadFile
- trace variable Option(-loadfile) w [namespace code ReadLoadScript]
+ trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
proc AcceptOutFile { file } {
if {[string equal stderr $file]} {return $file}
@@ -788,16 +790,39 @@ namespace eval tcltest {
Option -outfile stdout {
Send output from test runs to the specified file.
} AcceptOutFile outputFile
- trace variable Option(-outfile) w \
+ trace add variable Option(-outfile) write \
[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 variable Option(-errfile) w \
+ trace add variable Option(-errfile) write \
[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
+ }
}
#####################################################################
@@ -853,7 +878,7 @@ proc tcltest::DebugPArray {level arrayvar} {
variable debug
if {$debug >= $level} {
- catch {upvar $arrayvar $arrayvar}
+ catch {upvar 1 $arrayvar $arrayvar}
parray $arrayvar
}
return
@@ -937,8 +962,7 @@ proc tcltest::testConstraint {constraint {value ""}} {
if {[catch {expr {$value && $value}} msg]} {
return -code error $msg
}
- if {[limitConstraints]
- && [lsearch -exact $Option(-constraints) $constraint] == -1} {
+ if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
set value 0
}
set testConstraints($constraint) $value
@@ -962,11 +986,7 @@ proc tcltest::interpreter { {interp ""} } {
if {[llength [info level 0]] == 1} {
return $tcltest
}
- if {[string equal {} $interp]} {
- set tcltest {}
- } else {
- set tcltest $interp
- }
+ set tcltest $interp
}
#####################################################################
@@ -1031,7 +1051,7 @@ proc tcltest::PrintError {errorMsg} {
[expr {80 - $InitialMsgLen}]]]
puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
- while {![string equal end $beginningIndex]} {
+ while {$beginningIndex ne "end"} {
puts -nonewline [errorChannel] \
[string repeat " " $InitialMsgLen]
if {($endingIndex - $beginningIndex)
@@ -1084,7 +1104,7 @@ proc tcltest::PrintError {errorMsg} {
proc tcltest::SafeFetch {n1 n2 op} {
variable testConstraints
DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
- if {[string equal {} $n2]} {return}
+ if {$n2 eq {}} {return}
if {![info exists testConstraints($n2)]} {
if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
testConstraint $n2 0
@@ -1229,9 +1249,8 @@ proc tcltest::DefineConstraintInitializers {} {
# are running as root on Unix.
ConstraintInitializer root {expr \
- {[string equal unix $::tcl_platform(platform)]
- && ([string equal root $::tcl_platform(user)]
- || [string equal "" $::tcl_platform(user)])}}
+ {($::tcl_platform(platform) eq "unix") &&
+ ($::tcl_platform(user) in {root {}})}}
ConstraintInitializer notRoot {expr {![testConstraint root]}}
# Set nonBlockFiles constraint: 1 means this platform supports
@@ -1239,7 +1258,7 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer nonBlockFiles {
set code [expr {[catch {set f [open defs r]}]
- || [catch {fconfigure $f -blocking off}]}]
+ || [catch {chan configure $f -blocking off}]}]
catch {close $f}
set code
}
@@ -1265,10 +1284,10 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer unixExecs {
set code 1
- if {[string equal macintosh $::tcl_platform(platform)]} {
+ if {$::tcl_platform(platform) eq "macintosh"} {
set code 0
}
- if {[string equal windows $::tcl_platform(platform)]} {
+ if {$::tcl_platform(platform) eq "windows"} {
if {[catch {
set file _tcl_test_remove_me.txt
makeFile {hello} $file
@@ -1362,7 +1381,7 @@ proc tcltest::Usage { {option ""} } {
set allOpts [concat -help [Configure]]
foreach opt $allOpts {
set foo [Usage $opt]
- foreach [list x type($opt) usage($opt)] $foo break
+ lassign $foo x type($opt) usage($opt)
set line($opt) " $opt $type($opt) "
set length($opt) [string length $line($opt)]
if {$length($opt) > $max} {set max $length($opt)}
@@ -1386,7 +1405,7 @@ proc tcltest::Usage { {option ""} } {
append msg $u
}
return $msg\n
- } elseif {[string equal -help $option]} {
+ } elseif {$option eq "-help"} {
return [list -help "" "Display this usage information."]
} else {
set type [lindex [info args $Verify($option)] 0]
@@ -1412,7 +1431,7 @@ proc tcltest::Usage { {option ""} } {
proc tcltest::ProcessFlags {flagArray} {
# Process -help first
- if {[lsearch -exact $flagArray {-help}] != -1} {
+ if {"-help" in $flagArray} {
PrintUsageInfo
exit 1
}
@@ -1421,14 +1440,14 @@ proc tcltest::ProcessFlags {flagArray} {
RemoveAutoConfigureTraces
} else {
set args $flagArray
- while {[llength $args]>1 && [catch {eval [linsert $args 0 configure]} 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 {[lsearch -exact $moreOptions $option] == -1} {
+ if {$option ni $moreOptions} {
# Nope. Report the error, including additional options,
# but keep going
if {[llength $moreOptions]} {
@@ -1447,7 +1466,7 @@ proc tcltest::ProcessFlags {flagArray} {
# To recover, find that unknown option and remove up to it.
# then retry
- while {![string equal [lindex $args 0] $option]} {
+ while {[lindex $args 0] ne $option} {
set args [lrange $args 2 end]
}
set args [lrange $args 2 end]
@@ -1553,7 +1572,7 @@ proc tcltest::Replace::puts {args} {
}
2 {
# Either -nonewline or channelId has been specified
- if {[string equal -nonewline [lindex $args 0]]} {
+ if {[lindex $args 0] eq "-nonewline"} {
append outData [lindex $args end]
return
# return [Puts -nonewline [lindex $args end]]
@@ -1563,7 +1582,7 @@ proc tcltest::Replace::puts {args} {
}
}
3 {
- if {[string equal -nonewline [lindex $args 0]]} {
+ if {[lindex $args 0] eq "-nonewline"} {
# Both -nonewline and channelId are specified, unless
# it's an error. -nonewline is supposed to be argv[0].
set channel [lindex $args 1]
@@ -1573,12 +1592,10 @@ proc tcltest::Replace::puts {args} {
}
if {[info exists channel]} {
- if {[string equal $channel [[namespace parent]::outputChannel]]
- || [string equal $channel stdout]} {
+ if {$channel in [list [[namespace parent]::outputChannel] stdout]} {
append outData [lindex $args end]$newline
return
- } elseif {[string equal $channel [[namespace parent]::errorChannel]]
- || [string equal $channel stderr]} {
+ } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} {
append errData [lindex $args end]$newline
return
}
@@ -1586,7 +1603,7 @@ proc tcltest::Replace::puts {args} {
# If we haven't returned by now, we don't know how to handle the
# input. Let puts handle it.
- return [eval Puts $args]
+ return [Puts {*}$args]
}
# tcltest::Eval --
@@ -1615,8 +1632,7 @@ proc tcltest::Eval {script {ignoreOutput 1}} {
set outData {}
set errData {}
rename ::puts [namespace current]::Replace::Puts
- namespace eval :: \
- [list namespace import [namespace origin Replace::puts]]
+ namespace eval :: [list namespace import [namespace origin Replace::puts]]
namespace import Replace::puts
}
set result [uplevel 1 $script]
@@ -1748,7 +1764,7 @@ proc tcltest::SubstArguments {argList} {
set argList {}
}
- if {$token != {}} {
+ if {$token ne {}} {
# 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.
@@ -1855,10 +1871,7 @@ 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.
- foreach item {constraints setup cleanup body result returnCodes
- match} {
- set $item {}
- }
+ lassign {} constraints setup cleanup body result returnCodes match
# Set the default match mode
set match exact
@@ -1870,8 +1883,7 @@ 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 {
@@ -1892,7 +1904,7 @@ proc tcltest::test {name description args} {
-match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
- if {[lsearch -exact $validFlags $flag] == -1} {
+ if {$flag ni $validFlags} {
incr testLevel -1
set sorted [lsort $validFlags]
set options [join [lrange $sorted 0 end-1] ", "]
@@ -1908,7 +1920,7 @@ proc tcltest::test {name description args} {
# Check the values supplied for -match
variable CustomMatch
- if {[lsearch [array names CustomMatch] $match] == -1} {
+ if {$match ni [array names CustomMatch]} {
incr testLevel -1
set sorted [lsort [array names CustomMatch]]
set values [join [lrange $sorted 0 end-1] ", "]
@@ -1972,7 +1984,7 @@ proc tcltest::test {name description args} {
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
- foreach {actualAnswer returnCode} $testResult break
+ lassign $testResult actualAnswer returnCode
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCode(body) $::errorCode
@@ -2008,11 +2020,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 {[string length $msg] > 0} {
+ if {$msg ne {}} {
append coreMsg "\nError:\
Problem renaming core file: $msg"
}
@@ -2022,7 +2034,7 @@ proc tcltest::test {name description args} {
# check if the return code matched the expected return code
set codeFailure 0
- if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
+ if {!$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
@@ -2089,7 +2101,28 @@ proc tcltest::test {name description args} {
if {![IsVerbose body]} {
set body ""
}
- puts [outputChannel] "\n==== $name\
+ puts [outputChannel] "\n"
+ if {[IsVerbose line]} {
+ if {![catch {set testFrame [info frame -1]}] &&
+ [dict get $testFrame type] eq "source"} {
+ set testFile [dict get $testFrame file]
+ set testLine [dict get $testFrame line]
+ } else {
+ set testFile [file normalize [uplevel 1 {info script}]]
+ if {[file readable $testFile]} {
+ set testFd [open $testFile r]
+ set testLine [expr {[lsearch -regexp \
+ [split [read $testFd] "\n"] \
+ "^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
+ close $testFd
+ }
+ }
+ if {[info exists testLine]} {
+ puts [outputChannel] "$testFile:$testLine: error: test failed:\
+ $name [string trim $description]"
+ }
+ }
+ puts [outputChannel] "==== $name\
[string trim $description] FAILED"
if {[string length $body]} {
puts [outputChannel] "==== Contents of test case:"
@@ -2125,7 +2158,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)] && ([lsearch $returnCodes 1]<0)} {
+ if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
puts [outputChannel] "---- errorInfo: $errorInfo(body)"
puts [outputChannel] "---- errorCode: $errorCode(body)"
}
@@ -2206,7 +2239,7 @@ proc tcltest::Skipped {name constraints} {
}
return 1
}
- if {[string equal {} $constraints]} {
+ if {$constraints eq {}} {
# If we're limited to the listed constraints and there aren't
# any listed, then we shouldn't run the test.
if {[limitConstraints]} {
@@ -2337,6 +2370,14 @@ 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
@@ -2349,7 +2390,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 {}
@@ -2359,7 +2400,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
}
set newFiles {}
foreach file $currentFiles {
- if {[lsearch -exact $filesExisted $file] == -1} {
+ if {$file ni $filesExisted} {
lappend newFiles $file
}
}
@@ -2442,8 +2483,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# then add current file to failFile list if any tests in this
# file failed
- if {$currentFailure \
- && ([lsearch -exact $failFiles $testFileName] == -1)} {
+ if {$currentFailure && ($testFileName ni $failFiles)} {
lappend failFiles $testFileName
}
set currentFailure false
@@ -2503,11 +2543,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 {[string length $msg] > 0} {
+ if {$msg ne {}} {
PrintError "Problem renaming file: $msg"
}
} else {
@@ -2552,7 +2592,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# None
# a lower case version is needed for compatibility with tcltest 1.0
-proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args}
+proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args}
proc tcltest::GetMatchingFiles { args } {
if {[llength $args]} {
@@ -2585,7 +2625,7 @@ proc tcltest::GetMatchingFiles { args } {
# Add to result list all files in match list and not in skip list
foreach file $matchFileList {
- if {[lsearch -exact $skipFileList $file] == -1} {
+ if {$file ni $skipFileList} {
lappend matchingFiles $file
}
}
@@ -2632,7 +2672,7 @@ proc tcltest::GetMatchingDirectories {rootdir} {
foreach pattern [matchDirectories] {
foreach path [glob -directory $rootdir -types d -nocomplain -- \
$pattern] {
- if {[lsearch -exact $skipDirs $path] == -1} {
+ if {$path ni $skipDirs} {
set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
if {[file exists [file join $path all.tcl]]} {
lappend matchDirs $path
@@ -2685,7 +2725,7 @@ proc tcltest::runAllTests { {shell ""} } {
# [file system] first available in Tcl 8.4
if {![catch {file system [testsDirectory]} result]
- && ![string equal native [lindex $result 0]]} {
+ && ([lindex $result 0] ne "native")} {
# 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
@@ -2732,10 +2772,10 @@ proc tcltest::runAllTests { {shell ""} } {
# needs to read and process output of children.
set childargv [list]
foreach opt [Configure] {
- if {[string equal $opt -outfile]} {continue}
+ if {$opt eq "-outfile"} {continue}
set value [Configure $opt]
# Don't bother passing default configuration options
- if {[string equal $value $DefaultValue($opt)]} {
+ if {$value eq $DefaultValue($opt)} {
continue
}
lappend childargv $opt $value
@@ -2828,11 +2868,6 @@ proc tcltest::runAllTests { {shell ""} } {
# none.
proc tcltest::loadTestedCommands {} {
- variable l
- if {[string equal {} [loadScript]]} {
- return
- }
-
return [uplevel 1 [loadScript]]
}
@@ -2875,16 +2910,15 @@ proc tcltest::saveState {} {
proc tcltest::restoreState {} {
variable saveState
foreach p [uplevel 1 {::info procs}] {
- if {([lsearch [lindex $saveState 0] $p] < 0)
- && ![string equal [namespace current]::$p \
- [uplevel 1 [list ::namespace origin $p]]]} {
+ if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne
+ [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 {[lsearch [lindex $saveState 1] $p] < 0} {
+ if {$p ni [lindex $saveState 1]} {
DebugPuts 2 "[lindex [info level 0] 0]:\
Removing variable $p"
uplevel 1 [list ::catch [list ::unset $p]]
@@ -2945,15 +2979,15 @@ proc tcltest::makeFile {contents name {directory ""}} {
putting ``$contents'' into $fullName"
set fd [open $fullName w]
- fconfigure $fd -translation lf
- if {[string equal [string index $contents end] \n]} {
+ chan configure $fd -translation lf
+ if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
- if {[lsearch -exact $filesMade $fullName] == -1} {
+ if {$fullName ni $filesMade} {
lappend filesMade $fullName
}
return $fullName
@@ -2993,7 +3027,7 @@ proc tcltest::removeFile {name {directory ""}} {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
- return [file delete $fullName]
+ return [file delete -- $fullName]
}
# tcltest::makeDirectory --
@@ -3023,7 +3057,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 {[lsearch -exact $filesMade $fullName] == -1} {
+ if {$fullName ni $filesMade} {
lappend filesMade $fullName
}
return $fullName
@@ -3064,7 +3098,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 --
@@ -3161,7 +3195,7 @@ proc tcltest::LeakFiles {old} {
}
set leak {}
foreach p $new {
- if {[lsearch $old $p] < 0} {
+ if {$p ni $old} {
lappend leak $p
}
}
@@ -3232,7 +3266,7 @@ proc tcltest::RestoreLocale {} {
#
proc tcltest::threadReap {} {
- if {[info commands testthread] != {}} {
+ if {[info commands testthread] ne {}} {
# testthread built into tcltest
@@ -3252,7 +3286,7 @@ proc tcltest::threadReap {} {
}
testthread errorproc ThreadError
return [llength [testthread names]]
- } elseif {[info commands thread::id] != {}} {
+ } elseif {[info commands thread::id] ne {}} {
# Thread extension
@@ -3284,15 +3318,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 variable testConstraints r [namespace code SafeFetch]
+ 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
# 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 {[string equal [namespace current] \
- [namespace qualifiers [namespace which initConstraintsHook]]]} {
+ if {[namespace current] eq
+ [namespace qualifiers [namespace which initConstraintsHook]]} {
InitConstraints
} else {
proc initConstraintsHook {} {}
@@ -3318,7 +3352,7 @@ namespace eval tcltest {
-option value ?-option value ...?"
return
}
- if {[catch {eval [linsert $options 0 Configure]} msg]} {
+ if {[catch {Configure {*}$options} msg]} {
Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg"
return
}
@@ -3329,15 +3363,15 @@ namespace eval tcltest {
proc LoadTimeCmdLineArgParsingRequired {} {
set required false
- if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
+ if {[info exists ::argv] && ("-help" in $::argv)} {
# 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 {[string equal [namespace current] [namespace qualifiers \
- [namespace which $hook]]]} {
+ if {[namespace current] eq
+ [namespace qualifiers [namespace which $hook]]} {
set required true
} else {
proc $hook args {}
generated by cgit v0.12 at 2024-09-15 12:37:54 (GMT)