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.tcl86
1 files changed, 47 insertions, 39 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 18ebf71..0899364 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -16,7 +16,7 @@
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.58 2002/06/26 03:25:06 dgp Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.59 2002/06/27 17:31:05 dgp Exp $
package require Tcl 8.3 ;# uses [glob -directory]
namespace eval tcltest {
@@ -1227,8 +1227,7 @@ proc tcltest::DefineConstraintInitializers {} {
}
#####################################################################
-# Handle command line arguments (from argv) and default arg settings
-# (in TCLTEST_OPTIONS).
+# Usage and command line arguments processing.
# tcltest::PrintUsageInfo
#
@@ -1292,7 +1291,6 @@ proc tcltest::Usage { {option ""} } {
}
}
-
# tcltest::ProcessFlags --
#
# process command line arguments supplied in the flagArray - this
@@ -1326,9 +1324,15 @@ proc tcltest::ProcessFlags {flagArray} {
# Check whether the problem is "unknown option"
if {[regexp {^unknown option (\S+):} $msg -> option]} {
# Could be this is an option the Hook knows about
- if {[lsearch -exact \
- [processCmdLineArgsAddFlagHook] $option] == -1} {
- # Nope. Report the error, but keep going
+ set moreOptions [processCmdLineArgsAddFlagHook]
+ if {[lsearch -exact $moreOptions $option] == -1} {
+ # Nope. Report the error, including additional options,
+ # but keep going
+ if {[llength $moreOptions]} {
+ append msg ", "
+ append msg [join [lrange $moreOptions 0 end -1] ", "]
+ append msg "or [lindex $moreOptions end]"
+ }
puts [errorChannel] "WARNING: $msg"
}
} else {
@@ -1355,14 +1359,11 @@ proc tcltest::ProcessFlags {flagArray} {
# tcltest::ProcessCmdLineArgs --
#
-# Use command line args to set tcltest namespace variables.
-#
-# This procedure must be run after constraints are initialized,
-# because some constraints can be overridden.
+# This procedure must be run after constraint initialization is
+# set up (by [DefineConstraintInitializers]) because some constraints
+# can be overridden.
#
-# Set variables based on the contents of the environment variable
-# TCLTEST_OPTIONS first, then override with command-line options,
-# if specified.
+# Perform configuration according to the command-line options.
#
# Arguments:
# none
@@ -1375,29 +1376,16 @@ proc tcltest::ProcessFlags {flagArray} {
#
proc tcltest::ProcessCmdLineArgs {} {
- global argv
variable originalEnv
variable testConstraints
- # If the TCLTEST_OPTIONS environment variable exists, parse it
- # first, then the argv list. The command line argument parsing will
- # be a two-pass affair from now on, so that TCLTEST_OPTIONS contain
- # the default options. These can be overridden by the command line
- # flags.
-
- if {[info exists ::env(TCLTEST_OPTIONS)]} {
- ProcessFlags $::env(TCLTEST_OPTIONS)
- }
-
# The "argv" var doesn't exist in some cases, so use {}.
- if {(![info exists argv]) || ([llength $argv] < 1)} {
- set flagArray {}
+ if {![info exists ::argv]} {
+ ProcessFlags {}
} else {
- set flagArray $argv
+ ProcessFlags $::argv
}
- ProcessFlags $flagArray
-
# Spit out everything you know if we're at a debug level 2 or
# greater
DebugPuts 2 "Flags passed into tcltest:"
@@ -1418,7 +1406,6 @@ proc tcltest::ProcessCmdLineArgs {} {
DebugPArray 2 originalEnv
DebugPuts 2 "Constraints:"
DebugPArray 2 testConstraints
- return
}
#####################################################################
@@ -3233,13 +3220,34 @@ namespace eval tcltest {
customMatch glob [list string match]
customMatch regexp [list regexp --]
- proc LoadTimeConfigurationRequired {} {
- set required false
- if {[info exists ::env(TCLTEST_OPTIONS)]} {
- # Respect the environment variable at package load time,
- # so that it effectively establishes new defaults.
- set required true
+ # If the TCLTEST_OPTIONS environment variable exists, configure
+ # tcltest according to the option values it specifies. This has
+ # the effect of resetting tcltest's default configuration.
+ proc ConfigureFromEnvironment {} {
+ upvar #0 env(TCLTEST_OPTIONS) options
+ if {[catch {llength $options} msg]} {
+ puts [errorChannel] "WARNING: invalid\
+ TCLTEST_OPTIONS \"$options\":\n invalid Tcl list: $msg"
+ return
+ }
+ if {[llength $::env(TCLTEST_OPTIONS)] < 2} {
+ puts [errorChannel] "WARNING: invalid\
+ TCLTEST_OPTIONS: \"$options\":\n should be\
+ -option value ?-option value ...?"
+ return
+ }
+ if {[catch {eval Configure $::env(TCLTEST_OPTIONS)} msg]} {
+ puts [errorChannel] "WARNING: invalid\
+ TCLTEST_OPTIONS: \"$options\":\n $msg"
+ return
}
+ }
+ if {[info exists ::env(TCLTEST_OPTIONS)]} {
+ ConfigureFromEnvironment
+ }
+
+ proc LoadTimeCmdLineArgParsingRequired {} {
+ set required false
if {[info exists ::argv] && [lsearch -exact $::argv -help]} {
# The command line asks for -help, so give it (and exit)
# right now. ([configure] does not process -help)
@@ -3260,10 +3268,10 @@ namespace eval tcltest {
# Only initialize configurable options from the command line arguments
# at package load time if necessary for backward compatibility. This
# lets the tcltest user call [configure] for themselves if they wish.
- # Traves are established for auto-configuration from the command line
+ # Traces are established for auto-configuration from the command line
# if any configurable options are accessed before the user calls
# [configure].
- if {[LoadTimeConfigurationRequired]} {
+ if {[LoadTimeCmdLineArgParsingRequired]} {
ProcessCmdLineArgs
} else {
EstablishAutoConfigureTraces