summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/tcltest/tcltest.tcl91
1 files changed, 38 insertions, 53 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 87cb023..7951d49 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -13,7 +13,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.40 2002/03/25 20:55:16 dgp Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.41 2002/03/25 21:34:34 dgp Exp $
# create the "tcltest" namespace for all testing variables and procedures
@@ -41,6 +41,17 @@ namespace eval tcltest {
variable $varName $value
}
}
+ proc ArrayDefault {varName value} {
+ variable $varName
+ if {[array exists $varName]} {
+ return
+ }
+ if {[info exists $varName]} {
+ # Pre-initialized value is a scalar: destroy it!
+ unset $varName
+ }
+ array set $varName $value
+ }
# tcltest::verbose defaults to {body}
Default verbose body
@@ -99,20 +110,11 @@ namespace eval tcltest {
# tcltest::numTests will store test files as indices and the list
# of files (that should not have been) left behind by the test files.
-
- if {![info exists [namespace current]::createdNewFiles]} {
- variable createdNewFiles
- array set tcltest::createdNewFiles {}
- }
+ ArrayDefault createdNewFiles {}
# initialize tcltest::numTests array to keep track fo the number of
# tests that pass, fail, and are skipped.
-
- if {![info exists [namespace current]::numTests]} {
- variable numTests
- array set tcltest::numTests \
- [list Total 0 Passed 0 Skipped 0 Failed 0]
- }
+ ArrayDefault 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
@@ -121,20 +123,12 @@ namespace eval tcltest {
# means that the test didn't match the argument given to the -match flag;
# both of these constraints are counted only if tcltest::debug is set to
# true.
-
- if {![info exists [namespace current]::skippedBecause]} {
- variable skippedBecause
- array set tcltest::skippedBecause {}
- }
+ ArrayDefault skippedBecause {}
# initialize the tcltest::testConstraints array to keep track of valid
# predefined constraints (see the explanation for the
# tcltest::initConstraints proc for more details).
-
- if {![info exists [namespace current]::testConstraints]} {
- variable testConstraints
- array set tcltest::testConstraints {}
- }
+ ArrayDefault testConstraints {}
Default constraintsSpecified {}
# Don't run only the constrained tests by default
@@ -148,26 +142,19 @@ namespace eval tcltest {
Default loadFile {}
# tests that use threads need to know which is the main thread
-
- if {![info exists [namespace current]::mainThread]} {
- variable mainThread 1
- if {[info commands thread::id] != {}} {
- set mainThread [thread::id]
- } elseif {[info commands testthread] != {}} {
- set mainThread [testthread id]
- }
+ Default mainThread 1
+ variable mainThread
+ if {[info commands thread::id] != {}} {
+ set mainThread [thread::id]
+ } elseif {[info commands testthread] != {}} {
+ set mainThread [testthread id]
}
# save the original environment so that it can be restored later
-
- if {![info exists [namespace current]::originalEnv]} {
- variable originalEnv
- array set tcltest::originalEnv [array get ::env]
- }
+ ArrayDefault originalEnv [array get ::env]
# Set tcltest::workingDirectory to [pwd]. The default output directory
# for Tcl tests is the working directory.
-
Default workingDirectory [pwd]
Default temporaryDirectory $workingDirectory
@@ -176,7 +163,7 @@ namespace eval tcltest {
# tcltest::testsDirectory.
if {![info exists [namespace current]::testsDirectory]} {
- set oldpwd [pwd]
+ variable oldpwd [pwd]
catch {cd [file join [file dirname [info script]] .. .. tests]}
variable testsDirectory [pwd]
cd $oldpwd
@@ -192,11 +179,8 @@ namespace eval tcltest {
# Internationalization support -- used in tcltest::set_iso8859_1_locale
# and tcltest::restore_locale. Those commands are used in cmdIL.test.
- if {![info exists previousLocale]} {
- variable previousLocale
- }
- if {![info exists isoLocale]} {
+ if {![info exists [namespace current]::isoLocale]} {
variable isoLocale fr
switch -- $tcl_platform(platform) {
"unix" {
@@ -205,14 +189,14 @@ namespace eval tcltest {
switch -exact -- $tcl_platform(os) {
"FreeBSD" {
- set tcltest::isoLocale fr_FR.ISO_8859-1
+ set isoLocale fr_FR.ISO_8859-1
}
HP-UX {
- set tcltest::isoLocale fr_FR.iso88591
+ set isoLocale fr_FR.iso88591
}
Linux -
IRIX {
- set tcltest::isoLocale fr
+ set isoLocale fr
}
default {
@@ -220,12 +204,12 @@ namespace eval tcltest {
# define it to something else on your system
#if you want to test those.
- set tcltest::isoLocale iso_8859_1
+ set isoLocale iso_8859_1
}
}
}
"windows" {
- set tcltest::isoLocale French
+ set isoLocale French
}
}
}
@@ -237,11 +221,10 @@ namespace eval tcltest {
Default originalTclPlatform [array get tcl_platform]
# If a core file exists, save its modification time.
- if {![info exists coreModificationTime]} {
- if {[file exists [file join $tcltest::workingDirectory core]]} {
- variable coreModificationTime [file mtime [file join \
- $tcltest::workingDirectory core]]
- }
+ variable workingDirectory
+ if {[file exists [file join $workingDirectory core]]} {
+ Default coreModificationTime \
+ [file mtime [file join $workingDirectory core]]
}
# stdout and stderr buffers for use when we want to store them
@@ -3303,8 +3286,9 @@ proc tcltest::leakfiles {old} {
# None.
proc tcltest::set_iso8859_1_locale {} {
+ variable previousLocale
if {[info commands testlocale] != ""} {
- set tcltest::previousLocale [testlocale ctype]
+ set previousLocale [testlocale ctype]
testlocale ctype $tcltest::isoLocale
}
return
@@ -3324,8 +3308,9 @@ proc tcltest::set_iso8859_1_locale {} {
# None.
proc tcltest::restore_locale {} {
+ variable previousLocale
if {[info commands testlocale] != ""} {
- testlocale ctype $tcltest::previousLocale
+ testlocale ctype $previousLocale
}
return
}