diff options
author | jenn <jenn> | 1999-09-22 21:05:50 (GMT) |
---|---|---|
committer | jenn <jenn> | 1999-09-22 21:05:50 (GMT) |
commit | 9454094a1f693f120591e40414c8a59e243960c0 (patch) | |
tree | 7866197b7b39cb39795ac78fa3c3f5654f17cacc /library | |
parent | 7552a963efde72b3d7406e35bcef945224644285 (diff) | |
download | tcl-9454094a1f693f120591e40414c8a59e243960c0.zip tcl-9454094a1f693f120591e40414c8a59e243960c0.tar.gz tcl-9454094a1f693f120591e40414c8a59e243960c0.tar.bz2 |
* library/tcltest1.0/tcltest.tcl: Added a -args flag that sets a
variable named ::tcltest::parameters based on whatever's being
sent in as the argument to the -args flag. Modified tcltest so
that tcltest namespace variables are only initialized to their
default values if they did not previously exist. Modified the
::tcltest::testConstraints variable so that it isn't unset every
time ::tcltest::initConstraints is called. Modified command line
processing so that they are only processed if ::tcltest doesn't
have a child namespace (if there is a child namespace, then the
command line arguments *must* be processed in that namespace).
Diffstat (limited to 'library')
-rw-r--r-- | library/tcltest/tcltest.tcl | 223 | ||||
-rw-r--r-- | library/tcltest1.0/tcltest.tcl | 223 |
2 files changed, 300 insertions, 146 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 039c560..dd2f175 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.9 1999/07/30 01:35:27 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.9.4.1 1999/09/22 21:05:50 jenn Exp $ package provide tcltest 1.0 @@ -26,43 +26,62 @@ namespace eval tcltest { # Export the public tcltest procs set procList [list test cleanupTests saveState restoreState \ normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring safeFetch threadReap getMatchingTestFiles] + viewFile bytestring safeFetch threadReap getMatchingFiles] foreach proc $procList { namespace export $proc } # ::tcltest::verbose defaults to "b" - - variable verbose "b" + if {![info exists verbose]} { + variable verbose "b" + } # Match and skip patterns default to the empty list, except for # matchFiles, which defaults to all .test files in the testsDirectory - variable match {} - variable skip {} - - variable matchFiles {*.test} - variable skipFiles {} + if {![info exists match]} { + variable match {} + } + if {![info exists skip]} { + variable skip {} + } + if {![info exists matchFiles]} { + variable matchFiles {*.test} + } + if {![info exists skipFiles]} { + variable skipFiles {} + } # By default, don't save core files - variable preserveCore 0 + if {![info exists preserveCore]} { + variable preserveCore 0 + } # output goes to stdout by default - - variable outputChannel stdout + if {![info exists outputChannel]} { + variable outputChannel stdout + } # errors go to stderr by default - - variable errorChannel stderr + if {![info exists errorChannel]} { + variable errorChannel stderr + } # debug output doesn't get printed by default; debug level 1 spits - # up only the tets that were skipped because they didn't match or were + # up only the tests that were skipped because they didn't match or were # specifically skipped. A debug level of 2 would spit up the tcltest # variables and flags provided; a debug level of 3 causes some additional # output regarding operations of the test harness. The tcltest package # currently implements only up to debug level 3. + if {![info exists debug]} { + variable debug 0 + } - variable debug 0 + # Save any arguments that we might want to pass through to other programs. + # This is used by the -args flag. + if {![info exists parameters]} { + variable parameters {} + } # Count the number of files tested (0 if all.tcl wasn't called). # The all.tcl file will set testSingleFile to false, so stats will @@ -71,10 +90,18 @@ namespace eval tcltest { # current test file has had any failures. The failFiles list # stores the names of test files that had failures. - variable numTestFiles 0 - variable testSingleFile true - variable currentFailure false - variable failFiles {} + if {![info exists numTestFiles]} { + variable numTestFiles 0 + } + if {![info exists testSingleFile]} { + variable testSingleFile true + } + if {![info exists currentFailure]} { + variable currentFailure false + } + if {![info exists failFiles]} { + variable failFiles {} + } # Tests should remove all files they create. The test suite will # check the current working dir for files created by the tests. @@ -82,18 +109,29 @@ namespace eval tcltest { # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. # ::tcltest::filesExisted stores the names of pre-existing files. - variable filesMade {} - variable filesExisted {} + if {![info exists filesMade]} { + variable filesMade {} + } + if {![info exists filesExisted]} { + variable filesExisted {} + } # ::tcltest::numTests will store test files as indices and the list # of files (that should not have been) left behind by the test files. - array set ::tcltest::createdNewFiles {} + if {![info exists createdNewFiles]} { + variable createdNewFiles + array set ::tcltest::createdNewFiles {} + } # initialize ::tcltest::numTests array to keep track fo the number of - # tests that pass, fial, and are skipped. + # tests that pass, fail, and are skipped. - array set ::tcltest::numTests [list Total 0 Passed 0 Skipped 0 Failed 0] + if {![info exists numTests]} { + variable numTests + array set ::tcltest::numTests \ + [list Total 0 Passed 0 Skipped 0 Failed 0] + } # initialize ::tcltest::skippedBecause array to keep track of # constraints that kept tests from running; a constraint name of @@ -103,49 +141,70 @@ namespace eval tcltest { # both of these constraints are counted only if ::tcltest::debug is set to # true. - array set ::tcltest::skippedBecause {} + if {![info exists skippedBecause]} { + variable skippedBecause + array set ::tcltest::skippedBecause {} + } # initialize the ::tcltest::testConstraints array to keep track of valid # predefined constraints (see the explanation for the # ::tcltest::initConstraints proc for more details). - array set ::tcltest::testConstraints {} + if {![info exists testConstraints]} { + variable testConstraints + array set ::tcltest::testConstraints {} + } # Don't run only the constrained tests by default - variable limitConstraints false + if {![info exists limitConstraints]} { + variable limitConstraints false + } - # tests that use thread need to know which is the main thread + # tests that use threads need to know which is the main thread - variable mainThread 1 - if {[info commands testthread] != {}} { - set mainThread [testthread names] + if {![info exists mainThread]} { + variable mainThread 1 + if {[info commands testthread] != {}} { + set mainThread [testthread names] + } } # save the original environment so that it can be restored later - array set ::tcltest::originalEnv [array get ::env] + if {![info exists originalEnv]} { + variable originalEnv + array set ::tcltest::originalEnv [array get ::env] + } # Set ::tcltest::workingDirectory to [pwd]. The default output directory # for Tcl tests is the working directory. - variable workingDirectory [pwd] - variable temporaryDirectory $workingDirectory + if {![info exists workingDirectory]} { + variable workingDirectory [pwd] + } + if {![info exists temporaryDirectory]} { + variable temporaryDirectory $workingDirectory + } # Tests should not rely on the current working directory. # Files that are part of the test suite should be accessed relative to # ::tcltest::testsDirectory. - set oDir [pwd] - catch {cd [file join [file dirname [info script]] .. .. tests]} - variable testsDirectory [pwd] - cd $oDir + if {![info exists testsDirectory]} { + set oDir [pwd] + catch {cd [file join [file dirname [info script]] .. .. tests]} + variable testsDirectory [pwd] + cd $oDir + } # the variables and procs that existed when ::tcltest::saveState was # called are stored in a variable of the same name - variable saveState {} + if {![info exists saveState]} { + variable saveState {} + } # Internationalization support - if {![info exists ::tcltest::isoLocale]} { + if {![info exists isoLocale]} { variable isoLocale fr switch $tcl_platform(platform) { "unix" { @@ -180,18 +239,22 @@ namespace eval tcltest { } # Set the location of the execuatble - variable tcltest [info nameofexecutable] + if {![info exists tcltest]} { + variable tcltest [info nameofexecutable] + } # save the platform information so it can be restored later - variable originalTclPlatform [array get tcl_platform] - + if {![info exists originalTclPlatform]} { + variable originalTclPlatform [array get tcl_platform] + } # If a core file exists, save its modification time. - if {[file exists [file join $::tcltest::workingDirectory core]]} { - variable coreModificationTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + if {![info exists coreModificationTime]} { + if {[file exists [file join $::tcltest::workingDirectory core]]} { + variable coreModificationTime [file mtime [file join \ + $::tcltest::workingDirectory core]] + } } - } # ::tcltest::AddToSkippedBecause -- @@ -207,7 +270,7 @@ namespace eval tcltest { # previously exist - otherwise, it just increments it. proc ::tcltest::AddToSkippedBecause { constraint } { - # add the constraint to the list of constraints the kept tests + # add the constraint to the list of constraints that kept tests # from running if {[info exists ::tcltest::skippedBecause($constraint)]} { @@ -270,7 +333,9 @@ proc ::tcltest::PrintError {errorMsg} { return } -proc ::tcltest::initConstraintsHook {} {} +if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { + proc ::tcltest::initConstraintsHook {} {} +} # ::tcltest::initConstraints -- # @@ -291,8 +356,6 @@ proc ::tcltest::initConstraintsHook {} {} proc ::tcltest::initConstraints {} { global tcl_platform tcl_interactive tk_version - catch {unset ::tcltest::testConstraints} - # The following trace procedure makes it so that we can safely refer to # non-existent members of the ::tcltest::testConstraints array without # causing an error. Instead, reading a non-existent member will return 0. @@ -339,9 +402,10 @@ proc ::tcltest::initConstraints {} { set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) \ "Win32s"] - # The following Constraints switches are used to mark tests that should work, - # but have been temporarily disabled on certain platforms because they don't - # and we haven't gotten around to fixing the underlying problem. + # The following Constraints switches are used to mark tests that should + # work, but have been temporarily disabled on certain platforms because + # they don't and we haven't gotten around to fixing the underlying + # problem. set ::tcltest::testConstraints(tempNotPc) \ [expr {!$::tcltest::testConstraints(pc)}] @@ -437,7 +501,7 @@ proc ::tcltest::initConstraints {} { # to the "e" format of floating-point numbers. set ::tcltest::testConstraints(eformat) 1 - if {[string compare "[format %g 5e-5]" "5e-05"] != 0} { + if {![string equal "[format %g 5e-5]" "5e-05"]} { set ::tcltest::testConstraints(eformat) 0 } @@ -550,7 +614,9 @@ proc ::tcltest::initConstraints {} { # Hook used for customization of display of usage information. # -proc ::tcltest::PrintUsageInfoHook {} {} +if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} { + proc ::tcltest::PrintUsageInfoHook {} {} +} # ::tcltest::PrintUsageInfo # @@ -612,7 +678,9 @@ proc ::tcltest::PrintUsageInfo {} { # processed by ::tcltest::processCmdLineArgs. # -proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} +if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { + proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} +} # ::tcltest::processCmdLineArgsHook -- # @@ -623,7 +691,9 @@ proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} # flags The flags that have been pulled out of argv # -proc ::tcltest::processCmdLineArgsHook {flag} {} +if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} { + proc ::tcltest::processCmdLineArgsHook {flag} {} +} # ::tcltest::processCmdLineArgs -- # @@ -672,7 +742,7 @@ proc ::tcltest::processCmdLineArgs {} { # -help is not listed since it has already been processed lappend defaultFlags -verbose -match -skip -constraints \ -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints + -preservecore -limitconstraints -args set defaultFlags [concat $defaultFlags \ [ ::tcltest::processCmdLineArgsAddFlagsHook ]] @@ -685,6 +755,11 @@ proc ::tcltest::processCmdLineArgs {} { } } + # Set ::tcltest::parameters to the arg of the -args flag, if given + if {[info exists flag(-args)]} { + set ::tcltest::parameters $flag(-args) + } + # Set ::tcltest::verbose to the arg of the -verbose flag, if given if {[info exists flag(-verbose)]} { @@ -751,9 +826,9 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-tmpdir)]} { set ::tcltest::temporaryDirectory $flag(-tmpdir) - if {[string compare \ + if {![string equal \ [file pathtype $::tcltest::temporaryDirectory] \ - "absolute"] != 0} { + "absolute"]} { set ::tcltest::temporaryDirectory [file join [pwd] \ $::tcltest::temporaryDirectory] } @@ -793,7 +868,7 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-outfile)]} { set tmp $flag(-outfile) - if {[string compare [file pathtype $tmp] "absolute"] != 0} { + if {![string equal [file pathtype $tmp] "absolute"]} { set tmp [file join $::tcltest::temporaryDirectory $tmp] } set ::tcltest::outputChannel [open $tmp w] @@ -801,7 +876,7 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-errfile)]} { set tmp $flag(-errfile) - if {[string compare [file pathtype $tmp] "absolute"] != 0} { + if {![string equal [file pathtype $tmp] "absolute"]} { set tmp [file join $::tcltest::temporaryDirectory $tmp] } set ::tcltest::errorChannel [open $tmp w] @@ -1050,7 +1125,9 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { # additional things that should be done at cleanup. # -proc ::tcltest::cleanupTestsHook {} {} +if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { + proc ::tcltest::cleanupTestsHook {} {} +} # test -- # @@ -1135,16 +1212,14 @@ proc ::tcltest::test {name description script expectedAnswer args} { if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { # something like {a || b} should be turned into # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.a-zA-Z0-9]+} $constraints \ + regsub -all {[.\w]+} $constraints \ {$::tcltest::testConstraints(&)} c catch {set doTest [eval expr $c]} } else { # just simple constraints such as {unixOnly fonts}. - set doTest 1 foreach constraint $constraints { if {(![info exists ::tcltest::testConstraints($constraint)]) \ @@ -1191,7 +1266,7 @@ proc ::tcltest::test {name description script expectedAnswer args} { } set code [catch {uplevel $script} actualAnswer] - if {([string compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} { + if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} { incr ::tcltest::numTests(Passed) if {[string first p $::tcltest::verbose] != -1} { puts $::tcltest::outputChannel "++++ $name PASSED" @@ -1261,7 +1336,7 @@ proc ::tcltest::test {name description script expectedAnswer args} { } } -# ::tcltest::getMatchingTestFiles +# ::tcltest::getMatchingFiles # # Looks at the patterns given to match and skip files # and uses them to put together a list of the tests that will be run. @@ -1379,7 +1454,7 @@ proc ::tcltest::restoreState {} { if {$::tcltest::debug > 2} { puts "::tcltest::restoreState: Removing variable $p" } - uplevel #0 "unset $p" + uplevel #0 "catch {unset $p}" } } } @@ -1508,7 +1583,7 @@ proc ::tcltest::viewFile {name} { # Example: # grep {regexp a} $someList # -proc ::tcltest:grep { expression searchList } { +proc ::tcltest::grep { expression searchList } { foreach element $searchList { if {[regsub -all CURRENT_ELEMENT $expression $element \ newExpression] == 0} { @@ -1591,7 +1666,9 @@ proc ::tcltest::threadReap {} { # Initialize the constraints and set up command line arguments namespace eval tcltest { ::tcltest::initConstraints - ::tcltest::processCmdLineArgs + if {[namespace children ::tcltest] == {}} { + ::tcltest::processCmdLineArgs + } } return diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl index 039c560..dd2f175 100644 --- a/library/tcltest1.0/tcltest.tcl +++ b/library/tcltest1.0/tcltest.tcl @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.9 1999/07/30 01:35:27 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.9.4.1 1999/09/22 21:05:50 jenn Exp $ package provide tcltest 1.0 @@ -26,43 +26,62 @@ namespace eval tcltest { # Export the public tcltest procs set procList [list test cleanupTests saveState restoreState \ normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring safeFetch threadReap getMatchingTestFiles] + viewFile bytestring safeFetch threadReap getMatchingFiles] foreach proc $procList { namespace export $proc } # ::tcltest::verbose defaults to "b" - - variable verbose "b" + if {![info exists verbose]} { + variable verbose "b" + } # Match and skip patterns default to the empty list, except for # matchFiles, which defaults to all .test files in the testsDirectory - variable match {} - variable skip {} - - variable matchFiles {*.test} - variable skipFiles {} + if {![info exists match]} { + variable match {} + } + if {![info exists skip]} { + variable skip {} + } + if {![info exists matchFiles]} { + variable matchFiles {*.test} + } + if {![info exists skipFiles]} { + variable skipFiles {} + } # By default, don't save core files - variable preserveCore 0 + if {![info exists preserveCore]} { + variable preserveCore 0 + } # output goes to stdout by default - - variable outputChannel stdout + if {![info exists outputChannel]} { + variable outputChannel stdout + } # errors go to stderr by default - - variable errorChannel stderr + if {![info exists errorChannel]} { + variable errorChannel stderr + } # debug output doesn't get printed by default; debug level 1 spits - # up only the tets that were skipped because they didn't match or were + # up only the tests that were skipped because they didn't match or were # specifically skipped. A debug level of 2 would spit up the tcltest # variables and flags provided; a debug level of 3 causes some additional # output regarding operations of the test harness. The tcltest package # currently implements only up to debug level 3. + if {![info exists debug]} { + variable debug 0 + } - variable debug 0 + # Save any arguments that we might want to pass through to other programs. + # This is used by the -args flag. + if {![info exists parameters]} { + variable parameters {} + } # Count the number of files tested (0 if all.tcl wasn't called). # The all.tcl file will set testSingleFile to false, so stats will @@ -71,10 +90,18 @@ namespace eval tcltest { # current test file has had any failures. The failFiles list # stores the names of test files that had failures. - variable numTestFiles 0 - variable testSingleFile true - variable currentFailure false - variable failFiles {} + if {![info exists numTestFiles]} { + variable numTestFiles 0 + } + if {![info exists testSingleFile]} { + variable testSingleFile true + } + if {![info exists currentFailure]} { + variable currentFailure false + } + if {![info exists failFiles]} { + variable failFiles {} + } # Tests should remove all files they create. The test suite will # check the current working dir for files created by the tests. @@ -82,18 +109,29 @@ namespace eval tcltest { # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. # ::tcltest::filesExisted stores the names of pre-existing files. - variable filesMade {} - variable filesExisted {} + if {![info exists filesMade]} { + variable filesMade {} + } + if {![info exists filesExisted]} { + variable filesExisted {} + } # ::tcltest::numTests will store test files as indices and the list # of files (that should not have been) left behind by the test files. - array set ::tcltest::createdNewFiles {} + if {![info exists createdNewFiles]} { + variable createdNewFiles + array set ::tcltest::createdNewFiles {} + } # initialize ::tcltest::numTests array to keep track fo the number of - # tests that pass, fial, and are skipped. + # tests that pass, fail, and are skipped. - array set ::tcltest::numTests [list Total 0 Passed 0 Skipped 0 Failed 0] + if {![info exists numTests]} { + variable numTests + array set ::tcltest::numTests \ + [list Total 0 Passed 0 Skipped 0 Failed 0] + } # initialize ::tcltest::skippedBecause array to keep track of # constraints that kept tests from running; a constraint name of @@ -103,49 +141,70 @@ namespace eval tcltest { # both of these constraints are counted only if ::tcltest::debug is set to # true. - array set ::tcltest::skippedBecause {} + if {![info exists skippedBecause]} { + variable skippedBecause + array set ::tcltest::skippedBecause {} + } # initialize the ::tcltest::testConstraints array to keep track of valid # predefined constraints (see the explanation for the # ::tcltest::initConstraints proc for more details). - array set ::tcltest::testConstraints {} + if {![info exists testConstraints]} { + variable testConstraints + array set ::tcltest::testConstraints {} + } # Don't run only the constrained tests by default - variable limitConstraints false + if {![info exists limitConstraints]} { + variable limitConstraints false + } - # tests that use thread need to know which is the main thread + # tests that use threads need to know which is the main thread - variable mainThread 1 - if {[info commands testthread] != {}} { - set mainThread [testthread names] + if {![info exists mainThread]} { + variable mainThread 1 + if {[info commands testthread] != {}} { + set mainThread [testthread names] + } } # save the original environment so that it can be restored later - array set ::tcltest::originalEnv [array get ::env] + if {![info exists originalEnv]} { + variable originalEnv + array set ::tcltest::originalEnv [array get ::env] + } # Set ::tcltest::workingDirectory to [pwd]. The default output directory # for Tcl tests is the working directory. - variable workingDirectory [pwd] - variable temporaryDirectory $workingDirectory + if {![info exists workingDirectory]} { + variable workingDirectory [pwd] + } + if {![info exists temporaryDirectory]} { + variable temporaryDirectory $workingDirectory + } # Tests should not rely on the current working directory. # Files that are part of the test suite should be accessed relative to # ::tcltest::testsDirectory. - set oDir [pwd] - catch {cd [file join [file dirname [info script]] .. .. tests]} - variable testsDirectory [pwd] - cd $oDir + if {![info exists testsDirectory]} { + set oDir [pwd] + catch {cd [file join [file dirname [info script]] .. .. tests]} + variable testsDirectory [pwd] + cd $oDir + } # the variables and procs that existed when ::tcltest::saveState was # called are stored in a variable of the same name - variable saveState {} + if {![info exists saveState]} { + variable saveState {} + } # Internationalization support - if {![info exists ::tcltest::isoLocale]} { + if {![info exists isoLocale]} { variable isoLocale fr switch $tcl_platform(platform) { "unix" { @@ -180,18 +239,22 @@ namespace eval tcltest { } # Set the location of the execuatble - variable tcltest [info nameofexecutable] + if {![info exists tcltest]} { + variable tcltest [info nameofexecutable] + } # save the platform information so it can be restored later - variable originalTclPlatform [array get tcl_platform] - + if {![info exists originalTclPlatform]} { + variable originalTclPlatform [array get tcl_platform] + } # If a core file exists, save its modification time. - if {[file exists [file join $::tcltest::workingDirectory core]]} { - variable coreModificationTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + if {![info exists coreModificationTime]} { + if {[file exists [file join $::tcltest::workingDirectory core]]} { + variable coreModificationTime [file mtime [file join \ + $::tcltest::workingDirectory core]] + } } - } # ::tcltest::AddToSkippedBecause -- @@ -207,7 +270,7 @@ namespace eval tcltest { # previously exist - otherwise, it just increments it. proc ::tcltest::AddToSkippedBecause { constraint } { - # add the constraint to the list of constraints the kept tests + # add the constraint to the list of constraints that kept tests # from running if {[info exists ::tcltest::skippedBecause($constraint)]} { @@ -270,7 +333,9 @@ proc ::tcltest::PrintError {errorMsg} { return } -proc ::tcltest::initConstraintsHook {} {} +if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { + proc ::tcltest::initConstraintsHook {} {} +} # ::tcltest::initConstraints -- # @@ -291,8 +356,6 @@ proc ::tcltest::initConstraintsHook {} {} proc ::tcltest::initConstraints {} { global tcl_platform tcl_interactive tk_version - catch {unset ::tcltest::testConstraints} - # The following trace procedure makes it so that we can safely refer to # non-existent members of the ::tcltest::testConstraints array without # causing an error. Instead, reading a non-existent member will return 0. @@ -339,9 +402,10 @@ proc ::tcltest::initConstraints {} { set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) \ "Win32s"] - # The following Constraints switches are used to mark tests that should work, - # but have been temporarily disabled on certain platforms because they don't - # and we haven't gotten around to fixing the underlying problem. + # The following Constraints switches are used to mark tests that should + # work, but have been temporarily disabled on certain platforms because + # they don't and we haven't gotten around to fixing the underlying + # problem. set ::tcltest::testConstraints(tempNotPc) \ [expr {!$::tcltest::testConstraints(pc)}] @@ -437,7 +501,7 @@ proc ::tcltest::initConstraints {} { # to the "e" format of floating-point numbers. set ::tcltest::testConstraints(eformat) 1 - if {[string compare "[format %g 5e-5]" "5e-05"] != 0} { + if {![string equal "[format %g 5e-5]" "5e-05"]} { set ::tcltest::testConstraints(eformat) 0 } @@ -550,7 +614,9 @@ proc ::tcltest::initConstraints {} { # Hook used for customization of display of usage information. # -proc ::tcltest::PrintUsageInfoHook {} {} +if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} { + proc ::tcltest::PrintUsageInfoHook {} {} +} # ::tcltest::PrintUsageInfo # @@ -612,7 +678,9 @@ proc ::tcltest::PrintUsageInfo {} { # processed by ::tcltest::processCmdLineArgs. # -proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} +if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { + proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} +} # ::tcltest::processCmdLineArgsHook -- # @@ -623,7 +691,9 @@ proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} # flags The flags that have been pulled out of argv # -proc ::tcltest::processCmdLineArgsHook {flag} {} +if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} { + proc ::tcltest::processCmdLineArgsHook {flag} {} +} # ::tcltest::processCmdLineArgs -- # @@ -672,7 +742,7 @@ proc ::tcltest::processCmdLineArgs {} { # -help is not listed since it has already been processed lappend defaultFlags -verbose -match -skip -constraints \ -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints + -preservecore -limitconstraints -args set defaultFlags [concat $defaultFlags \ [ ::tcltest::processCmdLineArgsAddFlagsHook ]] @@ -685,6 +755,11 @@ proc ::tcltest::processCmdLineArgs {} { } } + # Set ::tcltest::parameters to the arg of the -args flag, if given + if {[info exists flag(-args)]} { + set ::tcltest::parameters $flag(-args) + } + # Set ::tcltest::verbose to the arg of the -verbose flag, if given if {[info exists flag(-verbose)]} { @@ -751,9 +826,9 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-tmpdir)]} { set ::tcltest::temporaryDirectory $flag(-tmpdir) - if {[string compare \ + if {![string equal \ [file pathtype $::tcltest::temporaryDirectory] \ - "absolute"] != 0} { + "absolute"]} { set ::tcltest::temporaryDirectory [file join [pwd] \ $::tcltest::temporaryDirectory] } @@ -793,7 +868,7 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-outfile)]} { set tmp $flag(-outfile) - if {[string compare [file pathtype $tmp] "absolute"] != 0} { + if {![string equal [file pathtype $tmp] "absolute"]} { set tmp [file join $::tcltest::temporaryDirectory $tmp] } set ::tcltest::outputChannel [open $tmp w] @@ -801,7 +876,7 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-errfile)]} { set tmp $flag(-errfile) - if {[string compare [file pathtype $tmp] "absolute"] != 0} { + if {![string equal [file pathtype $tmp] "absolute"]} { set tmp [file join $::tcltest::temporaryDirectory $tmp] } set ::tcltest::errorChannel [open $tmp w] @@ -1050,7 +1125,9 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { # additional things that should be done at cleanup. # -proc ::tcltest::cleanupTestsHook {} {} +if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { + proc ::tcltest::cleanupTestsHook {} {} +} # test -- # @@ -1135,16 +1212,14 @@ proc ::tcltest::test {name description script expectedAnswer args} { if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { # something like {a || b} should be turned into # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.a-zA-Z0-9]+} $constraints \ + regsub -all {[.\w]+} $constraints \ {$::tcltest::testConstraints(&)} c catch {set doTest [eval expr $c]} } else { # just simple constraints such as {unixOnly fonts}. - set doTest 1 foreach constraint $constraints { if {(![info exists ::tcltest::testConstraints($constraint)]) \ @@ -1191,7 +1266,7 @@ proc ::tcltest::test {name description script expectedAnswer args} { } set code [catch {uplevel $script} actualAnswer] - if {([string compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} { + if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} { incr ::tcltest::numTests(Passed) if {[string first p $::tcltest::verbose] != -1} { puts $::tcltest::outputChannel "++++ $name PASSED" @@ -1261,7 +1336,7 @@ proc ::tcltest::test {name description script expectedAnswer args} { } } -# ::tcltest::getMatchingTestFiles +# ::tcltest::getMatchingFiles # # Looks at the patterns given to match and skip files # and uses them to put together a list of the tests that will be run. @@ -1379,7 +1454,7 @@ proc ::tcltest::restoreState {} { if {$::tcltest::debug > 2} { puts "::tcltest::restoreState: Removing variable $p" } - uplevel #0 "unset $p" + uplevel #0 "catch {unset $p}" } } } @@ -1508,7 +1583,7 @@ proc ::tcltest::viewFile {name} { # Example: # grep {regexp a} $someList # -proc ::tcltest:grep { expression searchList } { +proc ::tcltest::grep { expression searchList } { foreach element $searchList { if {[regsub -all CURRENT_ELEMENT $expression $element \ newExpression] == 0} { @@ -1591,7 +1666,9 @@ proc ::tcltest::threadReap {} { # Initialize the constraints and set up command line arguments namespace eval tcltest { ::tcltest::initConstraints - ::tcltest::processCmdLineArgs + if {[namespace children ::tcltest] == {}} { + ::tcltest::processCmdLineArgs + } } return |