diff options
Diffstat (limited to 'library/tcltest/tcltest.tcl')
| -rw-r--r-- | library/tcltest/tcltest.tcl | 151 |
1 files changed, 105 insertions, 46 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 9d7bccc..daec879 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.10 1999/08/27 01:17:04 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.11 1999/08/27 18:12:26 jenn Exp $ package provide tcltest 1.0 @@ -32,28 +32,40 @@ namespace eval tcltest { } # ::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 @@ -61,12 +73,15 @@ namespace eval 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. - - variable debug 0 + if {![info exists debug]} { + variable debug 0 + } # Save any arguments that we might want to pass through to other programs. # This is used by the -args flag. - variable parameters {} + 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 @@ -75,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. @@ -86,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. - 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 @@ -107,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 - 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" { @@ -184,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 -- |