summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2002-06-25 01:13:38 (GMT)
committerdgp <dgp@users.sourceforge.net>2002-06-25 01:13:38 (GMT)
commiteca141d09f28440e73a5f323d01499837bbe4e9d (patch)
tree47d7689875630a938a7e91ec0f3a4eee6b0e3949
parent8ec6b9addefee0835769d744c4f9cabb7ae872ff (diff)
downloadtcl-eca141d09f28440e73a5f323d01499837bbe4e9d.zip
tcl-eca141d09f28440e73a5f323d01499837bbe4e9d.tar.gz
tcl-eca141d09f28440e73a5f323d01499837bbe4e9d.tar.bz2
* Implementation of TIP 101. Adds and exports a [configure] command
from tcltest.
-rw-r--r--ChangeLog6
-rw-r--r--library/tcltest/tcltest.tcl1532
-rw-r--r--tests/parseOld.test6
-rwxr-xr-xtests/tcltest.test53
4 files changed, 749 insertions, 848 deletions
diff --git a/ChangeLog b/ChangeLog
index c7e853d..db05d56 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2002-06-24 Don Porter <dgp@users.sourceforge.net>
+
+ * library/tcltest/tcltest.tcl: Implementation of TIP 101. Adds
+ * tests/parseOld.test: and exports a [configure] command
+ * tests/tcltest.test: from tcltest.
+
2002-06-22 Don Porter <dgp@users.sourceforge.net>
* changes: updated changes file for 8.4b1 release.
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index b2b020b..095a40f 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -13,36 +13,146 @@
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
+# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.55 2002/06/22 04:19:46 dgp Exp $
-
-# create the "tcltest" namespace for all testing variables and
-# procedures
-
-package require Tcl 8.3
+# RCS: @(#) $Id: tcltest.tcl,v 1.56 2002/06/25 01:13:38 dgp Exp $
+package require Tcl 8.3 ;# uses [glob -directory]
namespace eval tcltest {
+ variable Version 2.1
+
+ # Compatibility support for dumb variables defined in tcltest 1
+ # Do not use these. Call [package provide Tcl] and [info patchlevel]
+ # yourself. You don't need tcltest to wrap it for you.
+ variable version [package provide Tcl]
+ variable patchLevel [info patchlevel]
- # Export the public tcltest procs
- namespace export bytestring cleanupTests customMatch debug errorChannel \
- errorFile interpreter limitConstraints loadFile loadScript \
- loadTestedCommands makeDirectory makeFile match \
- matchDirectories matchFiles normalizeMsg normalizePath \
- outputChannel outputFile preserveCore removeDirectory \
- removeFile runAllTests singleProcess skip skipDirectories \
- skipFiles temporaryDirectory test testConstraint \
- testsDirectory verbose viewFile workingDirectory
- # Export the tcltest 1 compatibility procs
+##### Export the public tcltest procs; several categories
+ #
+ # Export the main functional commands that do useful things
+ namespace export cleanupTests loadTestedCommands makeDirectory \
+ makeFile removeDirectory removeFile runAllTests test
+
+ # Export configuration commands that control the functional commands
+ namespace export configure customMatch errorChannel interpreter \
+ outputChannel testConstraint
+
+ # Export commands that are duplication (candidates for deprecation)
+ namespace export bytestring ;# dups [encoding convertfrom identity]
+ namespace export debug ;# [configure -debug]
+ namespace export errorFile ;# [configure -errfile]
+ namespace export limitConstraints ;# [configure -limitconstraints]
+ namespace export loadFile ;# [configure -loadfile]
+ namespace export loadScript ;# [configure -load]
+ namespace export match ;# [configure -match]
+ namespace export matchFiles ;# [configure -file]
+ namespace export matchDirectories ;# [configure -relateddir]
+ namespace export normalizeMsg ;# application of [customMatch]
+ namespace export normalizePath ;# [file normalize] (8.4)
+ namespace export outputFile ;# [configure -outfile]
+ namespace export preserveCore ;# [configure -preservecore]
+ namespace export singleProcess ;# [configure -singleproc]
+ namespace export skip ;# [configure -skip]
+ namespace export skipFiles ;# [configure -notfile]
+ namespace export skipDirectories ;# [configure -asidefromdir]
+ namespace export temporaryDirectory ;# [configure -tmpdir]
+ namespace export testsDirectory ;# [configure -testdir]
+ namespace export verbose ;# [configure -verbose]
+ namespace export viewFile ;# bizarre [read]-ish thing
+ namespace export workingDirectory ;# [cd] [pwd]
+
+ # Export deprecated commands for tcltest 1 compatibility
namespace export getMatchingFiles mainThread restoreState saveState \
threadReap
- proc Default {varName value} {
- variable $varName
- if {![info exists $varName]} {
- variable $varName $value
+ # tcltest::normalizePath --
+ #
+ # This procedure resolves any symlinks in the path thus creating
+ # a path without internal redirection. It assumes that the
+ # incoming path is absolute.
+ #
+ # Arguments
+ # pathVar - name of variable containing path to modify.
+ #
+ # Results
+ # The path is modified in place.
+ #
+ # Side Effects:
+ # None.
+ #
+ proc normalizePath {pathVar} {
+ upvar $pathVar path
+ set oldpwd [pwd]
+ catch {cd $path}
+ set path [pwd]
+ cd $oldpwd
+ return $path
+ }
+
+##### Verification commands used to test values of variables and options
+ #
+ # Verification command that accepts everything
+ proc AcceptAll {value} {
+ return $value
+ }
+
+ # Verification command that accepts valid Tcl lists
+ proc AcceptList { list } {
+ return [lrange $list 0 end]
+ }
+
+ # Verification command that accepts a glob pattern
+ proc AcceptPattern { pattern } {
+ return [AcceptAll $pattern]
+ }
+
+ # Verification command that accepts integers
+ proc AcceptInteger { level } {
+ return [incr level 0]
+ }
+
+ # Verification command that accepts boolean values
+ proc AcceptBoolean { boolean } {
+ return [expr {$boolean && $boolean}]
+ }
+
+ # Verification command that accepts (syntactically) valid Tcl scripts
+ proc AcceptScript { script } {
+ if {![info complete $script]} {
+ return -code error "invalid Tcl script: $script"
+ }
+ return $script
+ }
+
+ # Verification command that accepts (converts to) absolute pathnames
+ proc AcceptAbsolutePath { path } {
+ return [file join [pwd] $path]
+ }
+
+ # Verification command that accepts existing readable directories
+ proc AcceptReadable { path } {
+ if {![file readable $path]} {
+ return -code error "\"$path\" is not readable"
}
+ return $path
}
+ proc AcceptDirectory { directory } {
+ set directory [AcceptAbsolutePath $directory]
+ if {![file exists $directory]} {
+ return -code error "\"$directory\" does not exist"
+ }
+ if {![file isdir $directory]} {
+ return -code error "\"$directory\" is not a directory"
+ }
+ return [AcceptReadable $directory]
+ }
+
+##### Initialize internal arrays of tcltest, but only if the caller
+ # has not already pre-initialized them. This is done to support
+ # compatibility with older tests that directly access internals
+ # rather than go through command interfaces.
+ #
proc ArrayDefault {varName value} {
variable $varName
if {[array exists $varName]} {
@@ -55,41 +165,48 @@ namespace eval tcltest {
array set $varName $value
}
- # verbose defaults to {body}
- Default verbose body
+ # save the original environment so that it can be restored later
+ ArrayDefault originalEnv [array get ::env]
- # Match and skip patterns default to the empty list, except for
- # matchFiles, which defaults to all .test files in the
- # testsDirectory and matchDirectories, which defaults to all
- # directories.
- Default match {}
- Default skip {}
- Default matchFiles {*.test}
- Default skipFiles {}
- Default matchDirectories {*}
- Default skipDirectories {}
+ # initialize numTests array to keep track fo the number of tests
+ # that pass, fail, and are skipped.
+ ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
- # By default, don't save core files
- Default preserveCore 0
+ # numTests will store test files as indices and the list of files
+ # (that should not have been) left behind by the test files.
+ ArrayDefault createdNewFiles {}
- # output goes to stdout by default
- Default outputChannel stdout
- Default outputFile stdout
+ # initialize skippedBecause array to keep track of constraints that
+ # kept tests from running; a constraint name of "userSpecifiedSkip"
+ # means that the test appeared on the list of tests that matched the
+ # -skip value given to the flag; "userSpecifiedNonMatch" 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.
+ ArrayDefault skippedBecause {}
- # errors go to stderr by default
- Default errorChannel stderr
- Default errorFile stderr
+ # initialize the testConstraints array to keep track of valid
+ # predefined constraints (see the explanation for the
+ # InitConstraints proc for more details).
+ ArrayDefault testConstraints {}
- # debug output doesn't get printed by default; debug level 1 spits
- # 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.
- Default debug 0
+##### Initialize internal variables of tcltest, but only if the caller
+ # has not already pre-initialized them. This is done to support
+ # compatibility with older tests that directly access internals
+ # rather than go through command interfaces.
+ #
+ proc Default {varName value {verify AcceptAll}} {
+ variable $varName
+ if {![info exists $varName]} {
+ variable $varName [$verify $value]
+ } else {
+ variable $varName [$verify [set $varName]]
+ }
+ }
# Save any arguments that we might want to pass through to other
# programs. This is used by the -args flag.
+ # FINDUSER
Default parameters {}
# Count the number of files tested (0 if runAllTests wasn't called).
@@ -98,57 +215,36 @@ namespace eval tcltest {
# The currentFailure var stores the boolean value of whether the
# current test file has had any failures. The failFiles list
# stores the names of test files that had failures.
- Default numTestFiles 0
- Default testSingleFile true
- Default currentFailure false
- Default failFiles {}
+ Default numTestFiles 0 AcceptInteger
+ Default testSingleFile true AcceptBoolean
+ Default currentFailure false AcceptBoolean
+ Default failFiles {} AcceptList
# Tests should remove all files they create. The test suite will
# check the current working dir for files created by the tests.
# filesMade keeps track of such files created using the makeFile and
# makeDirectory procedures. filesExisted stores the names of
# pre-existing files.
- Default filesMade {}
- Default filesExisted {}
-
- # numTests will store test files as indices and the list of files
- # (that should not have been) left behind by the test files.
- ArrayDefault createdNewFiles {}
-
- # initialize numTests array to keep track fo the number of tests
- # that pass, fail, and are skipped.
- ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
-
- # initialize skippedBecause array to keep track of constraints that
- # kept tests from running; a constraint name of "userSpecifiedSkip"
- # means that the test appeared on the list of tests that matched the
- # -skip value given to the flag; "userSpecifiedNonMatch" 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.
- ArrayDefault skippedBecause {}
+ Default filesMade {} AcceptList
+ Default filesExisted {} AcceptList
+ variable FilesExistedFilled 0
+ proc FillFilesExisted {} {
+ variable FilesExistedFilled
+ if {$FilesExistedFilled} {return}
+ variable filesExisted
- # initialize the testConstraints array to keep track of valid
- # predefined constraints (see the explanation for the
- # InitConstraints proc for more details).
- ArrayDefault testConstraints {}
- Default ConstraintsSpecifiedByCommandLineArgument {}
+ # Save the names of files that already exist in the scratch directory.
+ foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
+ lappend filesExisted [file tail $file]
+ }
+ set FilesExistedFilled 1
+ }
# Kept only for compatibility
- Default constraintsSpecified {}
+ Default constraintsSpecified {} AcceptList
trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
[array names ::tcltest::testConstraints] ;# }
- # Don't run only the "-constraint" specified tests by default
- Default limitConstraints false
-
- # A test application has to know how to load the tested commands
- # into the interpreter.
- Default loadScript {}
-
- # and the filename of the script file, if it exists
- Default loadFile {}
-
# tests that use threads need to know which is the main thread
Default mainThread 1
variable mainThread
@@ -158,49 +254,40 @@ namespace eval tcltest {
set mainThread [testthread id]
}
- # save the original environment so that it can be restored later
- ArrayDefault originalEnv [array get ::env]
-
# Set workingDirectory to [pwd]. The default output directory for
- # Tcl tests is the working directory.
- Default workingDirectory [pwd]
- Default temporaryDirectory $workingDirectory
+ # Tcl tests is the working directory. Whenever this value changes
+ # change to that directory.
+ variable workingDirectory
+ trace variable workingDirectory w \
+ [namespace code {cd $workingDirectory ;#}]
- # tcltest::normalizePath --
- #
- # This procedure resolves any symlinks in the path thus creating
- # a path without internal redirection. It assumes that the
- # incoming path is absolute.
- #
- # Arguments
- # pathVar contains the name of the variable containing the path
- # to modify.
- #
- # Results
- # The path is modified in place.
- #
- # Side Effects:
- # None.
- #
- proc normalizePath {pathVar} {
- upvar $pathVar path
- set oldpwd [pwd]
- catch {cd $path}
- set path [pwd]
- cd $oldpwd
- return $path
+ Default workingDirectory [pwd] AcceptAbsolutePath
+ proc workingDirectory { {dir ""} } {
+ variable workingDirectory
+ if {[llength [info level 0]] == 1} {
+ return $workingDirectory
+ }
+ set workingDirectory [AcceptAbsolutePath $dir]
}
- # Tests should not rely on the current working directory.
- # Files that are part of the test suite should be accessed relative
- # to tcltest::testsDirectory.
- Default testsDirectory [file join \
- [file dirname [info script]] .. .. tests]
- variable testsDirectory
- normalizePath testsDirectory
+ # Set the location of the execuatble
+ Default tcltest [info nameofexecutable]
- # Default is to run each test file in a separate process
- Default singleProcess 0
+ # save the platform information so it can be restored later
+ Default originalTclPlatform [array get tcl_platform]
+
+ # If a core file exists, save its modification time.
+ if {[file exists [file join [workingDirectory] core]]} {
+ Default coreModTime \
+ [file mtime [file join [workingDirectory] core]]
+ }
+
+ # stdout and stderr buffers for use when we want to store them
+ Default outData {}
+ Default errData {}
+
+ # keep track of test level for nested test commands
+ variable testLevel 0
# the variables and procs that existed when saveState was called are
# stored in a variable of the same name
@@ -243,25 +330,377 @@ namespace eval tcltest {
}
}
- # Set the location of the execuatble
- Default tcltest [info nameofexecutable]
+ # output goes to stdout by default
+ Default outputChannel stdout
+ proc outputChannel { {filename ""} } {
+ variable outputChannel
+
+ # Trigger auto-configuration of -outfile option, if needed.
+ # This is tricky because we have to trigger a trace on $debug
+ # so that traces attached to $outputFile are not disabled.
+ # We need them enabled to reflect changes back to outputChannel
+ set dummy [debug]
+
+ if {[llength [info level 0]] == 1} {
+ return $outputChannel
+ }
+ switch -exact -- $filename {
+ stderr -
+ stdout {
+ set outputChannel $filename
+ }
+ default {
+ set outputChannel [open $filename a]
+ }
+ }
+ return $outputChannel
+ }
- # save the platform information so it can be restored later
- Default originalTclPlatform [array get tcl_platform]
+ # errors go to stderr by default
+ Default errorChannel stderr
+ proc errorChannel { {filename ""} } {
+ variable errorChannel
+
+ # Trigger auto-configuration of -errfile option, if needed.
+ # This is tricky because we have to trigger a trace on $debug
+ # so that traces attached to $outputFile are not disabled.
+ # We need them enabled to reflect changes back to outputChannel
+ set dummy [debug]
+
+ if {[llength [info level 0]] == 1} {
+ return $errorChannel
+ }
+ switch -exact -- $filename {
+ stderr -
+ stdout {
+ set errorChannel $filename
+ }
+ default {
+ set errorChannel [open $filename a]
+ }
+ }
+ return $errorChannel
+ }
- # If a core file exists, save its modification time.
- variable workingDirectory
- if {[file exists [file join $workingDirectory core]]} {
- Default coreModTime \
- [file mtime [file join $workingDirectory core]]
+##### Set up the configurable options
+ #
+ # The configurable options of the package
+ variable Option; array set Option {}
+
+ # Usage strings for those options
+ variable Usage; array set Usage {}
+
+ # Verification commands for those options
+ variable Verify; array set Verify {}
+
+ # Initialize the default values of the configurable options that are
+ # historically associated with an exported variable. If that variable
+ # is already set, support compatibility by accepting its pre-set value.
+ # Use [trace] to establish ongoing connection between the deprecated
+ # exported variable and the modern option kept as a true internal var.
+ # Also set up usage string and value testing for the option.
+ proc Option {option value usage {verify AcceptAll} {varName {}}} {
+ variable Option
+ variable Verify
+ variable Usage
+ variable OptionControlledVariables
+ set Usage($option) $usage
+ set Verify($option) $verify
+ set Option($option) [$verify $value]
+ if {[string length $varName]} {
+ variable $varName
+ if {[info exists $varName]} {
+ set Option($option) [$verify [set $varName]]
+ unset $varName
+ }
+ namespace eval [namespace current] \
+ [list upvar 0 Option($option) $varName]
+ # Workaround for Bug 572889. Grrrr....
+ # Track all the variables tied to options
+ lappend OptionControlledVariables $varName
+ # Later, set auto-configure read traces on all
+ # of them, since a single trace on Option does not work.
+ proc $varName {{value {}}} [subst -nocommands {
+ if {[llength [info level 0]] == 2} {
+ Configure $option [set value]
+ }
+ return [Configure $option]
+ }]
+ }
}
- # stdout and stderr buffers for use when we want to store them
- Default outData {}
- Default errData {}
+ proc MatchingOption {option} {
+ variable Option
+ set match [array names Option $option*]
+ switch -- [llength $match] {
+ 0 {
+ set sorted [lsort [array names Option]]
+ set values [join [lrange $sorted 0 end-1] ", "]
+ append values ", or [lindex $sorted end]"
+ return -code error "unknown option $option: should be\
+ one of $values"
+ }
+ 1 {
+ return [lindex $match 0]
+ }
+ default {
+ # Exact match trumps ambiguity
+ if {[lsearch -exact $match $option] >= 0} {
+ return $option
+ }
+ set values [join [lrange $match 0 end-1] ", "]
+ append values ", or [lindex $match end]"
+ return -code error "ambiguous option $option:\
+ could match $values"
+ }
+ }
+ }
+
+ proc EstablishAutoConfigureTraces {} {
+ variable OptionControlledVariables
+ foreach varName [concat $OptionControlledVariables Option] {
+ variable $varName
+ trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
+ }
+ }
+
+ proc RemoveAutoConfigureTraces {} {
+ 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
+ }
+ }
+ }
+ # One the traces are removed, this can become a no-op
+ proc RemoveAutoConfigureTraces {} {}
+ }
+
+ proc Configure args {
+ variable Option
+ variable Verify
+ set n [llength $args]
+ if {$n == 0} {
+ return [lsort [array names Option]]
+ }
+ if {$n == 1} {
+ if {[catch {MatchingOption [lindex $args 0]} option]} {
+ return -code error $option
+ }
+ return $Option($option)
+ }
+ while {[llength $args] > 1} {
+ if {[catch {MatchingOption [lindex $args 0]} option]} {
+ return -code error $option
+ }
+ if {[catch {$Verify($option) [lindex $args 1]} value]} {
+ return -code error "invalid $option\
+ value \"[lindex $args 1]\": $value"
+ }
+ set Option($option) $value
+ set args [lrange $args 2 end]
+ }
+ if {[llength $args]} {
+ if {[catch {MatchingOption [lindex $args 0]} option]} {
+ return -code error $option
+ }
+ return -code error "missing value for option $option"
+ }
+ }
+ proc configure args {
+ RemoveAutoConfigureTraces
+ set code [catch {eval 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]} {
+ # translate single characters abbreviations to expanded list
+ set level [string map {p pass b body s skip t start e error} \
+ [split $level {}]]
+ }
+ }
+ set valid [list]
+ foreach v $level {
+ if {[regexp {^(pass|body|skip|start|error)$} $v]} {
+ lappend valid $v
+ }
+ }
+ return $valid
+ }
+
+ proc IsVerbose {level} {
+ variable Option
+ return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
+ }
+
+ # Default verbosity is to show bodies of failed tests
+ Option -verbose body {
+ Takes any combination of the values 'p', 's', 'b', 't' and 'e'.
+ 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.
+ } AcceptVerbose verbose
+
+ # Match and skip patterns default to the empty list, except for
+ # matchFiles, which defaults to all .test files in the
+ # testsDirectory and matchDirectories, which defaults to all
+ # directories.
+ Option -match {} {
+ Run all tests within the specified files that match one of the
+ list of glob patterns given.
+ } AcceptList match
+
+ Option -skip {} {
+ Skip all tests within the specified tests (via -match) and files
+ that match one of the list of glob patterns given.
+ } AcceptList skip
+
+ Option -file *.test {
+ Run tests in all test files that match the glob pattern given.
+ } AcceptPattern matchFiles
+
+ Option -notfile {} {
+ Skip all test files that match the glob pattern given.
+ } AcceptPattern skipFiles
+
+ Option -relateddir * {
+ Run tests in directories that match the glob pattern given.
+ } AcceptPattern matchDirectories
+
+ Option -asidefromdir {} {
+ Skip tests in directories that match the glob pattern given.
+ } AcceptPattern skipDirectories
+
+ # By default, don't save core files
+ Option -preservecore 0 {
+ If 2, save any core files produced during testing in the directory
+ specified by -tmpdir. If 1, notify the user if core files are
+ created.
+ } AcceptInteger preserveCore
+
+ # debug output doesn't get printed by default; debug level 1 spits
+ # 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.
+ Option -debug 0 {
+ Internal debug level
+ } AcceptInteger debug
+
+ proc SetSelectedConstraints args {
+ variable Option
+ foreach c $Option(-constraints) {
+ testConstraint $c 1
+ }
+ }
+ Option -constraints {} {
+ Do not skip the listed constraints listed in -constraints.
+ } AcceptList
+ trace variable Option(-constraints) w \
+ [namespace code {SetSelectedConstraints ;#}]
+
+ # Don't run only the "-constraint" specified tests by default
+ proc ClearUnselectedConstraints args {
+ variable Option
+ variable testConstraints
+ if {!$Option(-limitconstraints)} {return}
+ foreach c [array names testConstraints] {
+ if {[lsearch -exact $Option(-constraints) $c] == -1} {
+ testConstraint $elt 0
+ }
+ }
+ }
+ Option -limitconstraints false {
+ whether to run only tests with the constraints
+ } AcceptBoolean limitConstraints
+ trace variable Option(-limitconstraints) w \
+ [namespace code {ClearUnselectedConstraints ;#}]
+
+ # A test application has to know how to load the tested commands
+ # into the interpreter.
+ Option -load {} {
+ Specifies the script to load the tested commands.
+ } AcceptScript loadScript
+
+ # Default is to run each test file in a separate process
+ Option -singleproc 0 {
+ whether to run all tests in one process
+ } AcceptBoolean singleProcess
+
+ proc AcceptTemporaryDirectory { directory } {
+ set directory [AcceptAbsolutePath $directory]
+ if {![file exists $directory]} {
+ file mkdir $directory
+ }
+ set directory [AcceptDirectory $directory]
+ if {![file writable $directory]} {
+ return -code error "\"$directory\" is not writeable"
+ }
+ return $directory
+ }
+
+ # Directory where files should be created
+ Option -tmpdir [workingDirectory] {
+ Save temporary files in the specified directory.
+ } AcceptTemporaryDirectory temporaryDirectory
+ trace variable Option(-tmpdir) w \
+ [namespace code {normalizePath Option(-tmpdir) ;#}]
+
+ # Tests should not rely on the current working directory.
+ # Files that are part of the test suite should be accessed relative
+ # to [testsDirectory]
+ Option -testdir [file join [file dirname [info script]] .. .. tests] {
+ Search tests in the specified directory.
+ } AcceptDirectory testsDirectory
+ trace variable Option(-testdir) w \
+ [namespace code {normalizePath Option(-testdir) ;#}]
+
+ proc AcceptLoadFile { file } {
+ if {[string equal "" $file]} {return $file}
+ set file [file join [temporaryDirectory] $file]
+ return [AcceptReadable $file]
+ }
+ proc ReadLoadScript {args} {
+ variable Option
+ if {[string equal "" $Option(-loadfile)]} {return}
+ set tmp [open $Option(-loadfile) r]
+ loadScript [read $tmp]
+ close $tmp
+ }
+ Option -loadfile {} {
+ Read the script to load the tested commands from the specified file.
+ } AcceptLoadFile loadFile
+ trace variable Option(-loadfile) w [namespace code ReadLoadScript]
+
+ proc AcceptOutFile { file } {
+ if {[string equal stderr $file]} {return $file}
+ if {[string equal stdout $file]} {return $file}
+ return [file join [temporaryDirectory] $file]
+ }
+
+ # output goes to stdout by default
+ Option -outfile stdout {
+ Send output from test runs to the specified file.
+ } AcceptOutFile outputFile
+ trace variable Option(-outfile) w \
+ [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 \
+ [namespace code {errorChannel $Option(-errfile) ;#}]
- # keep track of test level for nested test commands
- variable testLevel 0
}
#####################################################################
@@ -357,305 +796,16 @@ proc tcltest::DebugDo {level script} {
#####################################################################
-# tcltest::CheckDirectory --
-#
-# This procedure checks whether the specified path is a readable
-# and/or writable directory. If one of the conditions is not
-# satisfied an error is printed and the application aborted. The
-# procedure assumes that the caller already checked the existence
-# of the path.
-#
-# Arguments
-# rw Information what attributes to check. Allowed values:
-# r, w, rw, wr. If 'r' is part of the value the directory
-# must be readable. 'w' associates to 'writable'.
-# dir The directory to check.
-# errMsg The string to prepend to the actual error message before
-# printing it.
-#
-# Results
-# none
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::CheckDirectory {rw dir errMsg} {
- # Allowed values for 'rw': r, w, rw, wr
-
- if {![file isdir $dir]} {
- return -code error "$errMsg \"$dir\" is not a directory"
- } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
- return -code error "$errMsg \"$dir\" is not writeable"
- } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
- return -code error "$errMsg \"$dir\" is not readable"
- }
- return
-}
-
-# tcltest::MakeAbsolutePath --
-#
-# This procedure checks whether the incoming path is absolute or
-# not. Makes it absolute if it was not.
-#
-# Arguments
-# pathVar contains the name of the variable containing the path to
-# modify.
-# prefix is optional, contains the path to use to make the other an
-# absolute one. The current working directory is used if it
-# was not specified.
-#
-# Results
-# The path is modified in place.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
- upvar $pathVar path
-
- if {![string equal [file pathtype $path] "absolute"]} {
- if {[string equal {} $prefix]} {
- set prefix [pwd]
- }
-
- set path [file join $prefix $path]
- }
- return $path
-}
-
-#####################################################################
-
-# tcltest::<variableName>
-#
-# Accessor functions for tcltest variables that can be modified
-# externally. These are vars that could otherwise be modified
-# using command line arguments to tcltest.
-
-# Many of them are all the same boilerplate:
-
-namespace eval tcltest {
- variable var
- foreach var {
- match skip matchFiles skipFiles matchDirectories
- skipDirectories preserveCore debug loadScript singleProcess
- mainThread ConstraintsSpecifiedByCommandLineArgument
- } {
- proc $var { {new ""} } [subst -nocommands {
- variable $var
- if {[llength [info level 0]] == 1} {
- return [set $var]
- }
- set $var \$new
- }]
- }
- unset var
-}
-
-# The rest have something special to deal with:
-
-# tcltest::verbose --
+# tcltest::mainThread
#
-# Set or return the verbosity level (tcltest::verbose) for tests.
-# This determines what gets printed to the screen and when, with
-# regard to the running of the tests. The proc does not check for
-# invalid values. It assumes that a string that doesn't match its
-# predefined keywords is a string containing letter-specified
-# verbosity levels.
-#
-# Arguments:
-# A string containing any combination of 'pbste' or a list of
-# keywords (listed in parens)
-# p = print output whenever a test passes (pass)
-# b = print the body of the test when it fails (body)
-# s = print when a test is skipped (skip)
-# t = print when a test starts (start)
-# e = print errorInfo and errorCode when a test encounters an
-# error (error)
+# Accessor command for tcltest variable mainThread.
#
-# Results:
-# content of tcltest::verbose
-#
-# Side effects:
-# None.
-
-proc tcltest::verbose { {level ""} } {
- variable verbose
- if {[llength [info level 0]] == 1} {
- return $verbose
- }
- if {[llength $level] > 1} {
- set verbose $level
- } else {
- if {[regexp {pass|body|skip|start|error} $level]} {
- set verbose $level
- } else {
- set levelList [split $level {}]
- set verbose [string map \
- {p pass b body s skip t start e error} $levelList]
- }
- }
- return $verbose
-}
-
-# tcltest::IsVerbose --
-#
-# Returns true if argument is one of the verbosity levels
-# currently being used; returns false otherwise.
-#
-# Arguments:
-# level
-#
-# Results:
-# boolean 1 (true) or 0 (false), depending on whether or not the
-# level provided is one of the ones stored in tcltest::verbose.
-#
-# Side effects:
-# None.
-
-proc tcltest::IsVerbose {level} {
- if {[lsearch -exact [verbose] $level] == -1} {
- return 0
- }
- return 1
-}
-
-# tcltest::outputChannel --
-#
-# set or return the output file descriptor based on the supplied
-# file name (where tcltest puts all of its output)
-#
-# Arguments:
-# output file descriptor
-#
-# Results:
-# file descriptor corresponding to supplied file name (or
-# currently set file descriptor, if no new filename was supplied)
-# - this is the content of tcltest::outputChannel
-#
-# Side effects:
-# None.
-
-proc tcltest::outputChannel { {filename ""} } {
- variable outputChannel
- if {[llength [info level 0]] == 1} {
- return $outputChannel
- }
- switch -exact -- $filename {
- stderr -
- stdout {
- set outputChannel $filename
- }
- default {
- set outputChannel [open $filename w]
- }
- }
- return $outputChannel
-}
-
-# tcltest::outputFile --
-#
-# set or return the output file name (where tcltest puts all of
-# its output); calls [outputChannel] to set the corresponding
-# file descriptor
-#
-# Arguments:
-# output file name
-#
-# Results:
-# file name corresponding to supplied file name (or currently set
-# file name, if no new filename was supplied) - this is the
-# content of tcltest::outputFile
-#
-# Side effects:
-# if the file name supplied is relative, it will be made absolute
-# with respect to the predefined temporaryDirectory
-
-proc tcltest::outputFile { {filename ""} } {
- variable outputFile
- if {[llength [info level 0]] == 1} {
- return $outputFile
- }
- switch -exact -- $filename {
- stderr -
- stdout {
- # do nothing
- }
- default {
- MakeAbsolutePath filename [temporaryDirectory]
- }
- }
- outputChannel $filename
- set outputFile $filename
-}
-
-# tcltest::errorChannel --
-#
-# set or return the error file descriptor based on the supplied
-# file name (where tcltest sends all its errors)
-#
-# Arguments:
-# error file name
-#
-# Results:
-# file descriptor corresponding to the supplied file name (or
-# currently set file descriptor, if no new filename was supplied)
-# - this is the content of tcltest::errorChannel
-#
-# Side effects:
-# opens the descriptor in w mode unless the filename is set to
-# stderr or stdout
-
-proc tcltest::errorChannel { {filename ""} } {
- variable errorChannel
- if {[llength [info level 0]] == 1} {
- return $errorChannel
- }
- switch -exact -- $filename {
- stderr -
- stdout {
- set errorChannel $filename
- }
- default {
- set errorChannel [open $filename w]
- }
- }
- return $errorChannel
-}
-
-# tcltest::errorFile --
-#
-# set or return the error file name; calls [errorChannel] to set
-# the corresponding file descriptor
-#
-# Arguments:
-# error file name
-#
-# Results:
-# content of tcltest::errorFile
-#
-# Side effects:
-# if the file name supplied is relative, it will be made absolute
-# with respect to the predefined temporaryDirectory
-
-proc tcltest::errorFile { {filename ""} } {
- variable errorFile
+proc tcltest::mainThread { {new ""} } {
+ variable mainThread
if {[llength [info level 0]] == 1} {
- return $errorFile
- }
- switch -exact -- $filename {
- stderr -
- stdout {
- # do nothing
- }
- default {
- MakeAbsolutePath filename [temporaryDirectory]
- }
+ return $mainThread
}
- set errorFile $filename
- errorChannel $errorFile
- return $errorFile
+ set mainThread $new
}
# tcltest::testConstraint --
@@ -691,168 +841,6 @@ proc tcltest::testConstraint {constraint {value ""}} {
set testConstraints($constraint) $value
}
-# tcltest::limitConstraints --
-#
-# sets/gets flag indicating whether tests run are limited only
-# to those matching constraints specified by the -constraints
-# command line option.
-#
-# Arguments:
-# new boolean value for the flag
-#
-# Results:
-# content of tcltest::limitConstraints
-#
-# Side effects:
-# None.
-
-proc tcltest::limitConstraints { {value ""} } {
- variable testConstraints
- variable limitConstraints
- DebugPuts 3 "entering limitConstraints $value"
- if {[llength [info level 0]] == 1} {
- return $limitConstraints
- }
- # Check for boolean values
- if {[catch {expr {$value && $value}} msg]} {
- return -code error $msg
- }
- set limitConstraints $value
- if {!$limitConstraints} {return $limitConstraints}
- foreach elt [array names testConstraints] {
- if {[lsearch -exact [ConstraintsSpecifiedByCommandLineArgument] $elt]
- == -1} {
- testConstraint $elt 0
- }
- }
- return $limitConstraints
-}
-
-# tcltest::loadFile --
-#
-# set the load file (containing the load script);
-# put the content of the load file into loadScript
-#
-# Arguments:
-# script's file name
-#
-# Results:
-# content of tcltest::loadFile
-#
-# Side effects:
-# None.
-
-proc tcltest::loadFile { {scriptFile ""} } {
- variable loadFile
- if {[llength [info level 0]] == 1} {
- return $loadFile
- }
- MakeAbsolutePath scriptFile [temporaryDirectory]
- set tmp [open $scriptFile r]
- loadScript [read $tmp]
- close $tmp
- set loadFile $scriptFile
-}
-
-# tcltest::workingDirectory --
-#
-# set workingDirectory to the given path. If the path is
-# relative, make it absolute. Change directory to the stated
-# working directory, if resetting the value
-#
-# Arguments:
-# directory name
-#
-# Results:
-# content of tcltest::workingDirectory
-#
-# Side effects:
-# None.
-
-proc tcltest::workingDirectory { {dir ""} } {
- variable workingDirectory
- if {[llength [info level 0]] == 1} {
- return $workingDirectory
- }
- set workingDirectory $dir
- MakeAbsolutePath workingDirectory
- cd $workingDirectory
- return $workingDirectory
-}
-
-# tcltest::temporaryDirectory --
-#
-# Set temporaryDirectory to the given path. If the path is
-# relative, make it absolute. If the file exists but is not a dir,
-# then return an error.
-#
-# If temporaryDirectory does not already exist, create it. If you
-# cannot create it, then return an error (the file mkdir isn't
-# caught and will propagate).
-#
-# Arguments:
-# directory name
-#
-# Results:
-# content of tcltest::temporaryDirectory
-#
-# Side effects:
-# None.
-
-proc tcltest::temporaryDirectory { {dir ""} } {
- variable temporaryDirectory
- if {[llength [info level 0]] == 1} {
- return $temporaryDirectory
- }
- set temporaryDirectory $dir
- MakeAbsolutePath temporaryDirectory
-
- if {[file exists $temporaryDirectory]} {
- CheckDirectory rw $temporaryDirectory \
- {bad argument for temporary directory: }
- } else {
- file mkdir $temporaryDirectory
- }
-
- normalizePath temporaryDirectory
-}
-
-# tcltest::testsDirectory --
-#
-# Set testsDirectory to the given path. If the path is relative,
-# make it absolute. If the file exists but is not a dir, then
-# return an error.
-#
-# If testsDirectory does not already exist, return an error.
-#
-# Arguments:
-# directory name
-#
-# Results:
-# content of tcltest::testsDirectory
-#
-# Side effects:
-# None.
-
-proc tcltest::testsDirectory { {dir ""} } {
- variable testsDirectory
- if {[llength [info level 0]] == 1} {
- return $testsDirectory
- }
-
- set testsDirectory $dir
- MakeAbsolutePath testsDirectory
- set testDirError "bad argument for tests directory: "
- if {[file exists $testsDirectory]} {
- CheckDirectory r $testsDirectory $testDirError
- } else {
- return -code error \
- "$testDirError \"$testsDirectory\" does not exist"
- }
-
- normalizePath testsDirectory
-}
-
# tcltest::interpreter --
#
# the interpreter name stored in tcltest::tcltest
@@ -1242,15 +1230,6 @@ proc tcltest::DefineConstraintInitializers {} {
# Handle command line arguments (from argv) and default arg settings
# (in TCLTEST_OPTIONS).
-# tcltest::PrintUsageInfoHook
-#
-# Hook used for customization of display of usage information.
-#
-
-if {[llength [info commands tcltest::PrintUsageInfoHook]] == 0} {
- proc tcltest::PrintUsageInfoHook {} {}
-}
-
# tcltest::PrintUsageInfo
#
# Prints out the usage information for package tcltest. This can
@@ -1265,93 +1244,54 @@ if {[llength [info commands tcltest::PrintUsageInfoHook]] == 0} {
# Side Effects:
# none
proc tcltest::PrintUsageInfo {} {
- puts "Usage: [file tail [info nameofexecutable]]\
- script ?-help? ?flag value? ... \n\
- Available flags (and valid input values) are:\n\
- -help Display this usage information.\n\
- -verbose level Takes any combination of the values\n\
- \t 'p', 's', 'b', 't' and 'e'. \
- Test suite will\n\
- \t display all passed tests if 'p' is\n\
- \t specified, all skipped tests if 's'\n\
- \t is specified, the bodies of\n\
- \t failed tests if 'b' is specified,\n\
- \t and when tests start if 't' is specified.\n\
- \t ErrorInfo is displayed\
- if 'e' is specified.\n\
- \t The default value is 'b'.\n\
- -constraints list Do not skip the listed constraints\n\
- -limitconstraints bool Only run tests with the constraints\n\
- \t listed in -constraints.\n\
- -match pattern Run all tests within the specified\n\
- \t files that match the glob pattern\n\
- \t given.\n\
- -skip pattern Skip all tests within the set of\n\
- \t specified tests (via -match) and\n\
- \t files that match the glob pattern\n\
- \t given.\n\
- -file pattern Run tests in all test files that\n\
- \t match the glob pattern given.\n\
- -notfile pattern Skip all test files that match the\n\
- \t glob pattern given.\n\
- -relateddir pattern Run tests in directories that match\n\
- \t the glob pattern given.\n\
- -asidefromdir pattern Skip tests in directories that match\n\
- \t the glob pattern given.\n\
- -preservecore level If 2, save any core files produced\n\
- \t during testing in the directory\n\
- \t specified by -tmpdir. If 1, notify the\n\
- \t user if core files are created. \
- The default\n\
- \t is [preserveCore].\n\
- -tmpdir directory Save temporary files\
- in the specified\n\
- \t directory. The default value is\n\
- \t [temporaryDirectory]\n\
- -testdir directories Search tests in the specified\n\
- \t directories. The default value is\n\
- \t [testsDirectory].\n\
- -outfile file Send output from test runs to the\n\
- \t specified file. The default is\n\
- \t stdout.\n\
- -errfile file Send errors from test runs to the\n\
- \t specified file. The default is\n\
- \t stderr.\n\
- -loadfile file Read the script to load the tested\n\
- \t commands from the specified file.\n\
- -load script Specifies the script\
- to load the tested\n\
- \t commands.\n\
- -debug level Internal debug flag."
+ puts [Usage]
PrintUsageInfoHook
- return
}
-# tcltest::processCmdLineArgsFlagsHook --
-#
-# This hook is used to add to the list of command line arguments
-# that are processed by tcltest::ProcessFlags. It is called at
-# the beginning of ProcessFlags.
-#
-
-if {[llength [info commands \
- tcltest::processCmdLineArgsAddFlagsHook]] == 0} {
- proc tcltest::processCmdLineArgsAddFlagsHook {} {}
+proc tcltest::Usage { {option ""} } {
+ variable Usage
+ variable Verify
+ if {[llength [info level 0]] == 1} {
+ set msg "Usage: [file tail [info nameofexecutable]] script "
+ append msg "?-help? ?flag value? ... \n"
+ append msg "Available flags (and valid input values) are:"
+
+ set max 0
+ set allOpts [concat -help [Configure]]
+ foreach opt $allOpts {
+ set foo [Usage $opt]
+ foreach [list x type($opt) usage($opt)] $foo break
+ set line($opt) " $opt $type($opt) "
+ set length($opt) [string length $line($opt)]
+ if {$length($opt) > $max} {set max $length($opt)}
+ }
+ set rest [expr {72 - $max}]
+ foreach opt $allOpts {
+ append msg \n$line($opt)
+ append msg [string repeat " " [expr {$max - $length($opt)}]]
+ set u [string trim $usage($opt)]
+ catch {append u " (default: \[[Configure $opt]])"}
+ regsub -all {\s*\n\s*} $u " " u
+ while {[string length $u] > $rest} {
+ set break [string wordstart $u $rest]
+ if {$break == 0} {
+ set break [string wordend $u 0]
+ }
+ append msg [string range $u 0 [expr {$break - 1}]]
+ set u [string trim [string range $u $break end]]
+ append msg \n[string repeat " " $max]
+ }
+ append msg $u
+ }
+ return $msg\n
+ } elseif {[string equal -help $option]} {
+ return [list -help "" "Display this usage information."]
+ } else {
+ set type [lindex [info args $Verify($option)] 0]
+ return [list $option $type $Usage($option)]
+ }
}
-# tcltest::processCmdLineArgsHook --
-#
-# This hook is used to actually process the flags added by
-# tcltest::processCmdLineArgsAddFlagsHook. It is called at the
-# end of ProcessFlags.
-#
-# Arguments:
-# flags The flags that have been pulled out of argv
-#
-
-if {[llength [info commands tcltest::processCmdLineArgsHook]] == 0} {
- proc tcltest::processCmdLineArgsHook {flag} {}
-}
# tcltest::ProcessFlags --
#
@@ -1376,125 +1316,39 @@ proc tcltest::ProcessFlags {flagArray} {
exit 1
}
- catch {array set flag $flagArray}
-
- # -help is not listed since it has already been processed
- lappend defaultFlags -verbose -match -skip -constraints \
- -outfile -errfile -debug -tmpdir -file -notfile \
- -preservecore -limitconstraints -testdir \
- -load -loadfile -asidefromdir \
- -relateddir -singleproc
- set defaultFlags \
- [concat $defaultFlags [processCmdLineArgsAddFlagsHook]]
-
- # Set verbose to the arg of the -verbose flag, if given
- if {[info exists flag(-verbose)]} {
- verbose $flag(-verbose)
- }
-
- # Set match to the arg of the -match flag, if given.
- if {[info exists flag(-match)]} {
- match $flag(-match)
- }
-
- # Set skip to the arg of the -skip flag, if given
- if {[info exists flag(-skip)]} {
- skip $flag(-skip)
- }
-
- # Handle the -file and -notfile flags
- if {[info exists flag(-file)]} {
- matchFiles $flag(-file)
- }
- if {[info exists flag(-notfile)]} {
- skipFiles $flag(-notfile)
- }
-
- # Handle -relateddir and -asidefromdir flags
- if {[info exists flag(-relateddir)]} {
- matchDirectories $flag(-relateddir)
- }
- if {[info exists flag(-asidefromdir)]} {
- skipDirectories $flag(-asidefromdir)
- }
-
- # Use the -constraints flag, if given, to turn on constraints that
- # are turned off by default: userInteractive knownBug nonPortable.
-
- if {[info exists flag(-constraints)]} {
- foreach elt $flag(-constraints) {
- testConstraint $elt 1
- }
- ConstraintsSpecifiedByCommandLineArgument $flag(-constraints)
- }
+ if {[llength $flagArray] == 0} {
+ RemoveAutoConfigureTraces
+ } else {
+ set args $flagArray
+ while {[llength $args] && [catch {eval 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
+ if {[lsearch -exact \
+ [processCmdLineArgsAddFlagHook] $option] == -1} {
+ # Nope. Report the error, but keep going
+ puts [errorChannel] "WARNING: $msg"
+ }
+ } else {
+ # error is something other than "unknown option"
+ # notify user of the error; and exit
+ puts [errorChannel] $msg
+ exit 1
+ }
- # Use the -limitconstraints flag, if given, to tell the harness to
- # limit tests run to those that were specified using the
- # -constraints flag. If the -constraints flag was not specified,
- # print out an error and exit.
- if {[info exists flag(-limitconstraints)]} {
- if {![info exists flag(-constraints)]} {
- error "-limitconstraints flag can only\
- be used with -constraints"
+ # To recover, find that unknown option and remove up to it.
+ # then retry
+ while {![string equal [lindex $args 0] $option]} {
+ set args [lrange $args 2 end]
+ }
+ set args [lrange $args 2 end]
}
- limitConstraints $flag(-limitconstraints)
- }
-
- # Set the temporaryDirectory to the arg of -tmpdir, if given.
-
- if {[info exists flag(-tmpdir)]} {
- temporaryDirectory $flag(-tmpdir)
- }
-
- # Set the testsDirectory to the arg of -testdir, if given.
-
- if {[info exists flag(-testdir)]} {
- testsDirectory $flag(-testdir)
- }
-
- # If an alternate error or output files are specified, change the
- # default channels.
-
- if {[info exists flag(-outfile)]} {
- outputFile $flag(-outfile)
- }
-
- if {[info exists flag(-errfile)]} {
- errorFile $flag(-errfile)
- }
-
- # If a load script was specified, either directly or through
- # a file, remember it for later usage.
-
- if {[info exists flag(-load)] && \
- ([lsearch -exact $flagArray -load] > \
- [lsearch -exact $flagArray -loadfile])} {
- loadScript $flag(-load)
- }
-
- if {[info exists flag(-loadfile)] && \
- ([lsearch -exact $flagArray -loadfile] > \
- [lsearch -exact $flagArray -load]) } {
- loadFile $flag(-loadfile)
- }
-
- # If the user specifies debug testing, print out extra information
- # during the run.
- if {[info exists flag(-debug)]} {
- debug $flag(-debug)
- }
-
- # Handle -preservecore
- if {[info exists flag(-preservecore)]} {
- preserveCore $flag(-preservecore)
- }
-
- # Handle -singleproc flag
- if {[info exists flag(-singleproc)]} {
- singleProcess $flag(-singleproc)
}
# Call the hook
+ array set flag $flagArray
processCmdLineArgsHook [array get flag]
return
}
@@ -1898,6 +1752,7 @@ proc tcltest::test {name description args} {
variable testLevel
DebugPuts 3 "test $name $args"
+ FillFilesExisted
incr testLevel
# Pre-define everything to null except output and errorOutput. We
@@ -2239,8 +2094,6 @@ proc tcltest::RunTest {
} {
variable testLevel
variable numTests
- variable skip
- variable match
variable testConstraints
variable originalTclPlatform
variable coreModTime
@@ -2250,7 +2103,7 @@ proc tcltest::RunTest {
}
# skip the test if it's name matches an element of skip
- foreach pattern $skip {
+ foreach pattern [skip] {
if {[string match $pattern $name]} {
if {$testLevel == 1} {
incr numTests(Skipped)
@@ -2261,9 +2114,9 @@ proc tcltest::RunTest {
}
# skip the test if it's name doesn't match any element of match
- if {[llength $match] > 0} {
+ if {[llength [match]] > 0} {
set ok 0
- foreach pattern $match {
+ foreach pattern [match] {
if {[string match $pattern $name]} {
set ok 1
break
@@ -2417,6 +2270,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
variable originalTclPlatform
variable coreModTime
+ FillFilesExisted
set testFileName [file tail [info script]]
# Call the cleanup hook
@@ -2651,7 +2505,7 @@ proc tcltest::GetMatchingFiles { {searchDirectory ""} } {
set matchFileList [concat $matchFileList \
[glob -directory $directory -nocomplain -- $match]]
}
- if {[string compare {} $tcltest::skipFiles]} {
+ if {[string compare {} [skipFiles]]} {
set skipFileList {}
foreach skip [skipFiles] {
set skipFileList [concat $skipFileList \
@@ -2749,12 +2603,12 @@ proc tcltest::GetMatchingDirectories {rootdir} {
# None.
proc tcltest::runAllTests { {shell ""} } {
- global argv
variable testSingleFile
variable numTestFiles
variable numTests
variable failFiles
+ FillFilesExisted
if {[llength [info level 0]] == 1} {
set shell [interpreter]
}
@@ -2807,12 +2661,21 @@ proc tcltest::runAllTests { {shell ""} } {
foreach file [lsort [GetMatchingFiles]] {
set tail [file tail $file]
puts [outputChannel] $tail
+ flush [outputChannel]
if {[singleProcess]} {
incr numTestFiles
uplevel 1 [list ::source $file]
} else {
- set cmd [linsert $argv 0 | $shell $file]
+ # Pass along our configuration to the child processes.
+ # EXCEPT for the -outfile, because the parent process
+ # needs to read and process output of children.
+ set childargv [list]
+ foreach opt [Configure] {
+ if {[string equal $opt -outfile]} {continue}
+ lappend childargv $opt [Configure $opt]
+ }
+ set cmd [linsert $childargv 0 | $shell $file]
if {[catch {
incr numTestFiles
set pipeFd [open $cmd "r"]
@@ -3007,6 +2870,7 @@ proc tcltest::normalizeMsg {msg} {
proc tcltest::makeFile {contents name {directory ""}} {
global tcl_platform
variable filesMade
+ FillFilesExisted
if {[llength [info level 0]] == 3} {
set directory [temporaryDirectory]
@@ -3049,6 +2913,7 @@ proc tcltest::makeFile {contents name {directory ""}} {
# None.
proc tcltest::removeFile {name {directory ""}} {
+ FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
@@ -3077,6 +2942,7 @@ proc tcltest::removeFile {name {directory ""}} {
proc tcltest::makeDirectory {name {directory ""}} {
variable filesMade
+ FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
@@ -3104,6 +2970,7 @@ proc tcltest::makeDirectory {name {directory ""}} {
# None
proc tcltest::removeDirectory {name {directory ""}} {
+ FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
@@ -3128,6 +2995,7 @@ proc tcltest::removeDirectory {name {directory ""}} {
proc tcltest::viewFile {name {directory ""}} {
global tcl_platform
+ FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
@@ -3348,21 +3216,47 @@ namespace eval tcltest {
} else {
proc initConstraintsHook {} {}
}
- ProcessCmdLineArgs
-
- # Save the names of files that already exist in
- # the output directory.
- variable file {}
- foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
- lappend filesExisted [file tail $file]
- }
# Define the standard match commands
customMatch exact [list string equal]
customMatch glob [list string match]
customMatch regexp [list regexp --]
- unset file
-}
-package provide tcltest 2.1
+ 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 {[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)
+ set required true
+ }
+ foreach hook { PrintUsageInfoHook processCmdLineArgsHook
+ processCmdLineArgsAddFlagHook } {
+ if {[string equal [namespace current] [namespace qualifiers \
+ [namespace which $hook]]]} {
+ set required true
+ } else {
+ proc $hook args {}
+ }
+ }
+ return $required
+ }
+ # 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
+ # if any configurable options are accessed before the user calls
+ # [configure].
+ if {[LoadTimeConfigurationRequired]} {
+ ProcessCmdLineArgs
+ } else {
+ EstablishAutoConfigureTraces
+ }
+
+ package provide [namespace tail [namespace current]] $Version
+}
diff --git a/tests/parseOld.test b/tests/parseOld.test
index 2c597bc..80e6338 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: parseOld.test,v 1.10 2001/08/02 01:20:05 hobbs Exp $
+# RCS: @(#) $Id: parseOld.test,v 1.11 2002/06/25 01:13:38 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -23,6 +23,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
tcltest::testConstraint testwordend \
[string equal "testwordend" [info commands testwordend]]
+# Save the argv value for restoration later
+set savedArgv $argv
+
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
set arg1 $a
@@ -536,6 +539,7 @@ test parseOld-15.5 {TclScriptEnd procedure} {
} {0}
# cleanup
+set argv $savedArgv
::tcltest::cleanupTests
return
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 7bfdb66..0e4b36c 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -6,7 +6,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.test,v 1.26 2002/06/07 19:48:41 dgp Exp $
+# RCS: @(#) $Id: tcltest.test,v 1.27 2002/06/25 01:13:38 dgp Exp $
# Note that there are several places where the value of
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
@@ -64,7 +64,7 @@ test tcltest-1.2 {tcltest -help -something} {unixOrPc} {
test tcltest-1.3 {tcltest -h} {unixOrPc} {
set result [catch {exec [interpreter] test.tcl -h} msg]
list $result [regexp Usage $msg]
-} {0 0}
+} {1 0}
# -verbose, implicit & explicit testing of [verbose]
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
@@ -141,7 +141,7 @@ test tcltest-2.7 {tcltest::verbose} {
verbose $oldVerbosity
list $currentVerbosity $newVerbosity
}
- -result {{body a r} {f o o}}
+ -result {body {}}
}
test tcltest-2.8 {tcltest -verbose 'error'} {
@@ -497,12 +497,10 @@ test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
-constraints unixOrPc
-body {
catch {exec [interpreter] a.tcl -tmpdir thisdirectoryisafile} msg
- # The join is necessary because the message can be split on multiple
- # lines
- join $msg
+ set msg
}
- -result {not a directory}
- -match regexp
+ -result {*not a directory*}
+ -match glob
}
# Test non-writeable directories, non-readable directories with directory flags
@@ -524,14 +522,12 @@ switch $tcl_platform(platform) {
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly} {
catch {exec [interpreter] a.tcl -tmpdir $notReadableDir} msg
- # The join is necessary because the message can be split on multiple lines
- list [regexp {not readable} [join $msg]]
+ string match {*not readable*} $msg
} {1}
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc} {
catch {exec [interpreter] a.tcl -tmpdir $notWriteableDir} msg
- # The join is necessary because the message can be split on multiple lines
- list [regexp {not writeable} [join $msg]]
+ string match {*not writeable*} $msg
} {1}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
@@ -576,19 +572,17 @@ test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} {
file delete -force thisdirectorydoesnotexist
catch {exec [interpreter] a.tcl -testdir thisdirectorydoesnotexist} msg
- list [regexp "does not exist" [join $msg]]
+ string match "*does not exist*" $msg
} {1}
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
catch {exec [interpreter] a.tcl -testdir thisdirectoryisafile} msg
- # The join is necessary because the message can be split on multiple lines
- list [regexp "not a directory" [join $msg]]
+ string match "*not a directory*" $msg
} {1}
test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unixOnly} {
catch {exec [interpreter] a.tcl -testdir $notReadableDir} msg
- # The join is necessary because the message can be split on multiple lines
- list [regexp {not readable} [join $msg]]
+ string match {*not readable*} $msg
} {1}
@@ -733,16 +727,19 @@ test tcltest-10.4 {-preservecore 3} {unixOrPc} {
[regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
-test tcltest-10.5 {preserveCore} {
- -body {
- set old [preserveCore]
- set result [preserveCore foo]
- set result2 [preserveCore]
- preserveCore $old
- list $result $result2
- }
- -result {foo foo}
-}
+# Removing this test. It makes no sense to test the ability of
+# [preserveCore] to accept an invalid value that will cause errors
+# in other parts of tcltests' operation.
+#test tcltest-10.5 {preserveCore} {
+# -body {
+# set old [preserveCore]
+# set result [preserveCore foo]
+# set result2 [preserveCore]
+# preserveCore $old
+# list $result $result2
+# }
+# -result {foo foo}
+#}
# -load, -loadfile, [loadScript], [loadFile]
set loadfile [makeFile {
@@ -1005,7 +1002,7 @@ test tcltest-15.7 {skipDirectories} {
# TCLTEST_OPTIONS
test tcltest-19.1 {TCLTEST_OPTIONS default} {
- -constraints {unixOrPc}
+ -constraints {unixOrPc singleTestInterp}
-setup {
if {[info exists ::env(TCLTEST_OPTIONS)]} {
set oldoptions $::env(TCLTEST_OPTIONS)