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.tcl2534
1 files changed, 1202 insertions, 1332 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 4eaaa4f..a64a6c4 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -1,35 +1,39 @@
# tcltest.tcl --
#
-# This file contains support code for the Tcl test suite. It
+# This file contains support code for the Tcl test suite. It
# defines the tcltest namespace and finds and defines the output
-# directory, constraints available, output and error channels, etc. used
-# by Tcl tests. See the tcltest man page for more details.
-#
+# directory, constraints available, output and error channels,
+# etc. used by Tcl tests. See the tcltest man page for more
+# details.
+#
# This design was based on the Tcl testing approach designed and
-# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
+# initially implemented by Mary Ann May-Pumphrey of Sun
+# Microsystems.
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
-#
-# RCS: @(#) $Id: tcltest.tcl,v 1.42 2002/03/25 22:05:03 dgp Exp $
+#
+# RCS: @(#) $Id: tcltest.tcl,v 1.43 2002/03/27 08:19:57 dgp Exp $
-# create the "tcltest" namespace for all testing variables and procedures
+# create the "tcltest" namespace for all testing variables and
+# procedures
package require Tcl 8.3
-namespace eval tcltest {
+namespace eval tcltest {
# Export the public tcltest procs
- namespace export bytestring cleanupTests debug errorChannel errorFile \
- interpreter limitConstraints loadFile loadScript \
+ namespace export bytestring cleanupTests debug errorChannel \
+ errorFile interpreter limitConstraints loadFile loadScript \
loadTestedCommands mainThread makeDirectory makeFile match \
matchDirectories matchFiles normalizeMsg normalizePath \
- outputChannel outputFile preserveCore removeDirectory removeFile \
- restoreState runAllTests saveState singleProcess skip \
- skipDirectories skipFiles temporaryDirectory test testConstraint \
- testsDirectory threadReap verbose viewFile workingDirectory
+ outputChannel outputFile preserveCore removeDirectory \
+ removeFile restoreState runAllTests saveState \
+ singleProcess skip skipDirectories skipFiles \
+ temporaryDirectory test testConstraint testsDirectory \
+ threadReap verbose viewFile workingDirectory
proc Default {varName value} {
variable $varName
@@ -49,12 +53,13 @@ namespace eval tcltest {
array set $varName $value
}
- # tcltest::verbose defaults to {body}
+ # verbose defaults to {body}
Default verbose body
# 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.
+ # matchFiles, which defaults to all .test files in the
+ # testsDirectory and matchDirectories, which defaults to all
+ # directories.
Default match {}
Default skip {}
Default matchFiles {*.test}
@@ -74,15 +79,15 @@ namespace eval tcltest {
Default errorFile stderr
# 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.
+ # 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
- # Save any arguments that we might want to pass through to other programs.
- # This is used by the -args flag.
+ # Save any arguments that we might want to pass through to other
+ # programs. This is used by the -args flag.
Default parameters {}
# Count the number of files tested (0 if runAllTests wasn't called).
@@ -98,40 +103,40 @@ namespace eval tcltest {
# Tests should remove all files they create. The test suite will
# check the current working dir for files created by the tests.
- # tcltest::filesMade keeps track of such files created using the
- # tcltest::makeFile and tcltest::makeDirectory procedures.
- # tcltest::filesExisted stores the names of pre-existing files.
+ # 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 {}
- # tcltest::numTests will store test files as indices and the list
- # of files (that should not have been) left behind by the test files.
+ # 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 tcltest::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 tcltest::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.
+ # 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 {}
- # initialize the tcltest::testConstraints array to keep track of valid
+ # initialize the testConstraints array to keep track of valid
# predefined constraints (see the explanation for the
- # tcltest::initConstraints proc for more details).
+ # InitConstraints proc for more details).
ArrayDefault testConstraints {}
Default constraintsSpecified {}
# Don't run only the constrained tests by default
Default limitConstraints false
- # A test application has to know how to load the tested commands into
- # the interpreter.
+ # 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
@@ -149,32 +154,53 @@ namespace eval tcltest {
# save the original environment so that it can be restored later
ArrayDefault originalEnv [array get ::env]
- # Set tcltest::workingDirectory to [pwd]. The default output directory
- # for Tcl tests is the working directory.
+ # Set workingDirectory to [pwd]. The default output directory for
+ # Tcl tests is the working directory.
Default workingDirectory [pwd]
Default 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.
-
- if {![info exists [namespace current]::testsDirectory]} {
- variable oldpwd [pwd]
- catch {cd [file join [file dirname [info script]] .. .. tests]}
- variable testsDirectory [pwd]
+ # 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
- unset oldpwd
+ return $path
}
+ # 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
+
# Default is to run each test file in a separate process
Default singleProcess 0
- # the variables and procs that existed when tcltest::saveState was
- # called are stored in a variable of the same name
+ # the variables and procs that existed when saveState was called are
+ # stored in a variable of the same name
Default saveState {}
- # Internationalization support -- used in tcltest::set_iso8859_1_locale
- # and tcltest::restore_locale. Those commands are used in cmdIL.test.
+ # Internationalization support -- used in [SetIso8859_1_Locale] and
+ # [RestoreLocale]. Those commands are used in cmdIL.test.
if {![info exists [namespace current]::isoLocale]} {
variable isoLocale fr
@@ -196,9 +222,9 @@ namespace eval tcltest {
}
default {
- # Works on SunOS 4 and Solaris, and maybe others...
- # define it to something else on your system
- #if you want to test those.
+ # Works on SunOS 4 and Solaris, and maybe
+ # others... Define it to something else on your
+ # system if you want to test those.
set isoLocale iso_8859_1
}
@@ -219,7 +245,7 @@ namespace eval tcltest {
# If a core file exists, save its modification time.
variable workingDirectory
if {[file exists [file join $workingDirectory core]]} {
- Default coreModificationTime \
+ Default coreModTime \
[file mtime [file join $workingDirectory core]]
}
@@ -229,7 +255,7 @@ namespace eval tcltest {
# keep track of test level for nested test commands
variable testLevel 0
-}
+}
#####################################################################
@@ -310,7 +336,7 @@ proc tcltest::DebugDo {level script} {
variable debug
if {$debug >= $level} {
- uplevel $script
+ uplevel 1 $script
}
return
}
@@ -344,55 +370,26 @@ proc tcltest::CheckDirectory {rw dir errMsg} {
# Allowed values for 'rw': r, w, rw, wr
if {![file isdir $dir]} {
- set msg "$errMsg \"$dir\" is not a directory"
- error $msg
+ return -code error "$errMsg \"$dir\" is not a directory"
} elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
- set msg "$errMsg \"$dir\" is not writeable"
- error $msg
+ return -code error "$errMsg \"$dir\" is not writeable"
} elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
- set msg "$errMsg \"$dir\" is not readable"
- error $msg
+ return -code error "$errMsg \"$dir\" is not readable"
}
return
}
-# 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 tcltest::normalizePath {pathVar} {
- upvar $pathVar path
-
- set oldpwd [pwd]
- catch {cd $path}
- set path [pwd]
- cd $oldpwd
- return $path
-}
-
-
# tcltest::MakeAbsolutePath --
#
-# This procedure checks whether the incoming path is absolute or not.
-# Makes it absolute if it was not.
+# 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.
+# 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.
+# absolute one. The current working directory is used if it
+# was not specified.
#
# Results
# The path is modified in place.
@@ -404,12 +401,12 @@ proc tcltest::normalizePath {pathVar} {
proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
upvar $pathVar path
- if {![string equal [file pathtype $path] "absolute"]} {
- if {$prefix == {}} {
+ if {![string equal [file pathtype $path] "absolute"]} {
+ if {[string equal {} $prefix]} {
set prefix [pwd]
}
- set path [file join $prefix $path]
+ set path [file join $prefix $path]
}
return $path
}
@@ -417,317 +414,205 @@ proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
#####################################################################
# 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.
+#
+# 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
+ } {
+ 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 --
#
-# 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.
+# 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)
+# 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)
+# e = print errorInfo and errorCode when a test encounters an
+# error (error)
#
# Results:
-# content of tcltest::verbose - this is always the character combination
-# (pbste) instead of the list form.
+# content of tcltest::verbose
#
# Side effects:
# None.
proc tcltest::verbose { {level ""} } {
+ variable verbose
if {[llength [info level 0]] == 1} {
- return $tcltest::verbose
- }
+ return $verbose
+ }
if {[llength $level] > 1} {
- set tcltest::verbose $level
+ set verbose $level
} else {
if {[regexp {pass|body|skip|start|error} $level]} {
- set tcltest::verbose $level
- } else {
+ set verbose $level
+ } else {
set levelList [split $level {}]
- set tcltest::verbose [string map {p pass b body s skip t start e
- error} $levelList]
+ set verbose [string map \
+ {p pass b body s skip t start e error} $levelList]
}
}
- return $tcltest::verbose
+ return $verbose
}
-# tcltest::isVerbose --
+# tcltest::IsVerbose --
#
-# Returns true if argument is one of the verbosity levels currently being
-# used; returns false otherwise.
+# 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.
+# 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 [tcltest::verbose] $level] == -1} {
+proc tcltest::IsVerbose {level} {
+ if {[lsearch -exact [verbose] $level] == -1} {
return 0
}
return 1
}
-
-
-# tcltest::match --
-#
-# Set or return the match patterns (tcltest::match) that determine which
-# tests are run.
-#
-# Arguments:
-# List containing match patterns (glob format)
-#
-# Results:
-# content of tcltest::match
-#
-# Side effects:
-# none
-
-proc tcltest::match { {matchList ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::match
- }
- set tcltest::match $matchList
-}
-
-# tcltest::skip --
-#
-# Set or return the skip patterns (tcltest::skip) that determine which
-# tests are skipped.
-#
-# Arguments:
-# List containing skip patterns (glob format)
-#
-# Results:
-# content of tcltest::skip
-#
-# Side effects:
-# None.
-
-proc tcltest::skip { {skipList ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::skip
- }
- set tcltest::skip $skipList
-}
-
-# tcltest::matchFiles --
-#
-# set or return the match patterns for file sourcing
-#
-# Arguments:
-# list containing match file list (glob format)
-#
-# Results:
-# content of tcltest::matchFiles
-#
-# Side effects:
-# None.
-
-proc tcltest::matchFiles { {matchFileList ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::matchFiles
- }
- set tcltest::matchFiles $matchFileList
-}
-
-# tcltest::skipFiles --
-#
-# set or return the skip patterns for file sourcing
-#
-# Arguments:
-# list containing the skip file list (glob format)
-#
-# Results:
-# content of tcltest::skipFiles
-#
-# Side effects:
-# None.
-
-proc tcltest::skipFiles { {skipFileList ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::skipFiles
- }
- set tcltest::skipFiles $skipFileList
-}
-
-
-# tcltest::matchDirectories --
-#
-# set or return the list of directories for matching (glob pattern list)
-#
-# Arguments:
-# list of glob patterns matching subdirectories of
-# tcltest::testsDirectory
-#
-# Results:
-# content of tcltest::matchDirectories
-#
-# Side effects:
-# None.
-
-proc tcltest::matchDirectories { {dirlist ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::matchDirectories
- }
- set tcltest::matchDirectories $dirlist
-}
-
-# tcltest::skipDirectories --
-#
-# set or return the list of directories to skip (glob pattern list)
-#
-# Arguments:
-# list of glob patterns matching directories to skip; these directories
-# are subdirectories of tcltest::testsDirectory
-#
-# Results:
-# content of tcltest::skipDirectories
-#
-# Side effects:
-# None.
-
-proc tcltest::skipDirectories { {dirlist ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::skipDirectories
- }
- set tcltest::skipDirectories $dirlist
-}
-
-# tcltest::preserveCore --
-#
-# set or return the core preservation level. This proc does not do any
-# error checking for invalid values.
-#
-# Arguments:
-# core level:
-# '0' = don't do anything with core files (default)
-# '1' = notify the user if core files are created
-# '2' = save any core files produced during testing to
-# tcltest::temporaryDirectory
-#
-# Results:
-# content of tcltest::preserveCore
-#
-# Side effects:
-# None.
-
-proc tcltest::preserveCore { {coreLevel ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::preserveCore
- }
- set tcltest::preserveCore $coreLevel
-}
-
# tcltest::outputChannel --
#
-# set or return the output file descriptor based on the supplied file
-# name (where tcltest puts all of its output)
+# 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
+# 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 $tcltest::outputChannel
+ return $outputChannel
}
- if {($filename == "stderr") || ($filename == "stdout")} {
- set tcltest::outputChannel $filename
- } else {
- set tcltest::outputChannel [open $filename w]
+ switch -exact -- $filename {
+ stderr -
+ stdout {
+ set outputChannel $filename
+ }
+ default {
+ set outputChannel [open $filename w]
+ }
}
- return $tcltest::outputChannel
+ return $outputChannel
}
# tcltest::outputFile --
#
-# set or return the output file name (where tcltest puts all of its
-# output); calls tcltest::outputChannel to set the corresponding file
-# descriptor
+# 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
+# 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
+# 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 $tcltest::outputFile
+ return $outputFile
}
- if {($filename != "stderr") && ($filename != "stdout")} {
- MakeAbsolutePath filename $tcltest::temporaryDirectory
+ switch -exact -- $filename {
+ stderr -
+ stdout {
+ # do nothing
+ }
+ default {
+ MakeAbsolutePath filename [temporaryDirectory]
+ }
}
- tcltest::outputChannel $filename
- set tcltest::outputFile $filename
+ 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)
+# 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
+# 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
+# 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 $tcltest::errorChannel
+ return $errorChannel
}
- if {($filename == "stderr") || ($filename == "stdout")} {
- set tcltest::errorChannel $filename
- } else {
- set tcltest::errorChannel [open $filename w]
+ switch -exact -- $filename {
+ stderr -
+ stdout {
+ set errorChannel $filename
+ }
+ default {
+ set errorChannel [open $filename w]
+ }
}
- return $tcltest::errorChannel
+ return $errorChannel
}
# tcltest::errorFile --
#
-# set or return the error file name; calls tcltest::errorChannel to set
+# set or return the error file name; calls [errorChannel] to set
# the corresponding file descriptor
#
# Arguments:
@@ -737,56 +622,38 @@ proc tcltest::errorChannel { {filename ""} } {
# content of tcltest::errorFile
#
# Side effects:
-# if the file name supplied is relative, it will be made absolute with
-# respect to the predefined temporaryDirectory
+# if the file name supplied is relative, it will be made absolute
+# with respect to the predefined temporaryDirectory
proc tcltest::errorFile { {filename ""} } {
+ variable errorFile
if {[llength [info level 0]] == 1} {
- return $tcltest::errorFile
- }
- if {($filename != "stderr") && ($filename != "stdout")} {
- MakeAbsolutePath filename $tcltest::temporaryDirectory
+ return $errorFile
}
- set tcltest::errorFile $filename
- errorChannel $tcltest::errorFile
- return $tcltest::errorFile
-}
-
-# tcltest::debug --
-#
-# set or return the debug level for tcltest; this proc does not check for
-# invalid values
-#
-# Arguments:
-# debug level:
-# '0' = no debug output (default)
-# '1' = skipped tests
-# '2' = tcltest variables and supplied flags
-# '3' = harness operations
-#
-# Results:
-# content of tcltest::debug
-#
-# Side effects:
-# None.
-
-proc tcltest::debug { {debugLevel ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::debug
+ switch -exact -- $filename {
+ stderr -
+ stdout {
+ # do nothing
+ }
+ default {
+ MakeAbsolutePath filename [temporaryDirectory]
+ }
}
- set tcltest::debug $debugLevel
+ set errorFile $filename
+ errorChannel $errorFile
+ return $errorFile
}
# tcltest::testConstraint --
#
-# sets a test constraint to a value; to do multiple constraints, call
-# this proc multiple times. also returns the value of the named
-# constraint if no value was supplied.
+# sets a test constraint to a value; to do multiple constraints,
+# call this proc multiple times. also returns the value of the
+# named constraint if no value was supplied.
#
# Arguments:
# constraint - name of the constraint
-# value - new value for constraint (should be boolean) - if not supplied,
-# this is a query
+# value - new value for constraint (should be boolean) - if not
+# supplied, this is a query
#
# Results:
# content of tcltest::testConstraints($constraint)
@@ -795,47 +662,14 @@ proc tcltest::debug { {debugLevel ""} } {
# appends the constraint name to tcltest::constraintsSpecified
proc tcltest::testConstraint {constraint {value ""}} {
+ variable testConstraints
+ variable constraintsSpecified
DebugPuts 3 "entering testConstraint $constraint $value"
if {[llength [info level 0]] == 2} {
- return $tcltest::testConstraints($constraint)
- }
- lappend tcltest::constraintsSpecified $constraint
- set tcltest::testConstraints($constraint) $value
-}
-
-# tcltest::constraintsSpecified --
-#
-# returns a list of all the constraint names specified using
-# testConstraint
-#
-# Arguments:
-# None.
-#
-# Results:
-# list of the constraint names in tcltest::constraintsSpecified
-#
-# Side effects:
-# None.
-
-proc tcltest::constraintsSpecified {} {
- return $tcltest::constraintsSpecified
-}
-
-# tcltest::constraintList --
-#
-# returns a list of all the constraint names
-#
-# Arguments:
-# None.
-#
-# Results:
-# list of the constraint names in tcltest::testConstraints
-#
-# Side effects:
-# None.
-
-proc tcltest::constraintList {} {
- return [array names tcltest::testConstraints]
+ return $testConstraints($constraint)
+ }
+ lappend constraintsSpecified $constraint
+ set testConstraints($constraint) $value
}
# tcltest::limitConstraints --
@@ -852,42 +686,25 @@ proc tcltest::constraintList {} {
# None.
proc tcltest::limitConstraints { {constraintList ""} } {
+ variable constraintsSpecified
+ variable testConstraints
+ variable limitConstraints
DebugPuts 3 "entering limitConstraints $constraintList"
if {[llength [info level 0]] == 1} {
- return $tcltest::limitConstraints
- }
- set tcltest::limitConstraints $constraintList
- foreach elt [tcltest::constraintList] {
- if {[lsearch -exact [tcltest::constraintsSpecified] $elt] == -1} {
- tcltest::testConstraint $elt 0
- }
+ return $limitConstraints
}
- return $tcltest::limitConstraints
-}
-
-# tcltest::loadScript --
-#
-# sets the load script
-#
-# Arguments:
-# script to be set
-#
-# Results:
-# contents of tcltest::loadScript
-#
-# Side effects:
-# None.
-
-proc tcltest::loadScript { {script ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::loadScript
+ set limitConstraints $constraintList
+ foreach elt [array names testConstraints] {
+ if {[lsearch -exact $constraintsSpecified $elt] == -1} {
+ testConstraint $elt 0
+ }
}
- set tcltest::loadScript $script
+ return $limitConstraints
}
# tcltest::loadFile --
#
-# set the load file (containing the load script);
+# set the load file (containing the load script);
# put the content of the load file into loadScript
#
# Arguments:
@@ -900,22 +717,22 @@ proc tcltest::loadScript { {script ""} } {
# None.
proc tcltest::loadFile { {scriptFile ""} } {
+ variable loadFile
if {[llength [info level 0]] == 1} {
- return $tcltest::loadFile
+ return $loadFile
}
- MakeAbsolutePath scriptFile $tcltest::temporaryDirectory
+ MakeAbsolutePath scriptFile [temporaryDirectory]
set tmp [open $scriptFile r]
- tcltest::loadScript [read $tmp]
+ loadScript [read $tmp]
close $tmp
- set tcltest::loadFile $scriptFile
+ 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
+# 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
@@ -927,23 +744,24 @@ proc tcltest::loadFile { {scriptFile ""} } {
# None.
proc tcltest::workingDirectory { {dir ""} } {
+ variable workingDirectory
if {[llength [info level 0]] == 1} {
- return $tcltest::workingDirectory
+ return $workingDirectory
}
- set tcltest::workingDirectory $dir
- MakeAbsolutePath tcltest::workingDirectory
- cd $tcltest::workingDirectory
- return $tcltest::workingDirectory
+ set workingDirectory $dir
+ MakeAbsolutePath workingDirectory
+ cd $workingDirectory
+ return $workingDirectory
}
# tcltest::temporaryDirectory --
#
-# Set tcltest::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.
+# 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 tcltest::temporaryDirectory does not already exist, create it.
-# If you cannot create it, then return an error (the file mkdir isn't
+# 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:
@@ -956,30 +774,30 @@ proc tcltest::workingDirectory { {dir ""} } {
# None.
proc tcltest::temporaryDirectory { {dir ""} } {
+ variable temporaryDirectory
if {[llength [info level 0]] == 1} {
- return $tcltest::temporaryDirectory
+ return $temporaryDirectory
}
- set tcltest::temporaryDirectory $dir
-
- MakeAbsolutePath tcltest::temporaryDirectory
- set tmpDirError "bad argument for temporary directory: "
+ set temporaryDirectory $dir
+ MakeAbsolutePath temporaryDirectory
- if {[file exists $tcltest::temporaryDirectory]} {
- tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError
+ if {[file exists $temporaryDirectory]} {
+ CheckDirectory rw $temporaryDirectory \
+ {bad argument for temporary directory: }
} else {
- file mkdir $tcltest::temporaryDirectory
+ file mkdir $temporaryDirectory
}
- normalizePath tcltest::temporaryDirectory
+ normalizePath temporaryDirectory
}
# tcltest::testsDirectory --
#
-# Set tcltest::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.
+# 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 tcltest::testsDirectory does not already exist, return an error.
+# If testsDirectory does not already exist, return an error.
#
# Arguments:
# directory name
@@ -991,45 +809,22 @@ proc tcltest::temporaryDirectory { {dir ""} } {
# None.
proc tcltest::testsDirectory { {dir ""} } {
+ variable testsDirectory
if {[llength [info level 0]] == 1} {
- return $tcltest::testsDirectory
+ return $testsDirectory
}
- set tcltest::testsDirectory $dir
-
- MakeAbsolutePath tcltest::testsDirectory
+ set testsDirectory $dir
+ MakeAbsolutePath testsDirectory
set testDirError "bad argument for tests directory: "
-
- if {[file exists $tcltest::testsDirectory]} {
- tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError
+ if {[file exists $testsDirectory]} {
+ CheckDirectory r $testsDirectory $testDirError
} else {
- set msg "$testDirError \"$tcltest::testsDirectory\" does not exist"
- error $msg
+ return -code error \
+ "$testDirError \"$testsDirectory\" does not exist"
}
-
- normalizePath tcltest::testsDirectory
-}
-
-# tcltest::singleProcess --
-#
-# sets tcltest::singleProcess to the value provided.
-#
-# Arguments:
-# value for singleProcess:
-# 1 = source each test file into the current process
-# 0 = run each test file in its own process
-#
-# Results:
-# content of tcltest::singleProcess
-#
-# Side effects:
-# None.
-proc tcltest::singleProcess { {value ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::singleProcess
- }
- set tcltest::singleProcess $value
+ normalizePath testsDirectory
}
# tcltest::interpreter --
@@ -1050,46 +845,26 @@ proc tcltest::interpreter { {interp ""} } {
if {[llength [info level 0]] == 1} {
return $tcltest
}
- if {$interp == "{}"} {
+ if {[string equal {} $interp]} {
set tcltest {}
} else {
set tcltest $interp
}
}
-# tcltest::mainThread --
-#
-# sets or returns the thread id stored in tcltest::mainThread
-#
-# Arguments:
-# thread id
-#
-# Results:
-# content of tcltest::mainThread
-#
-# Side effects:
-# None.
-
-proc tcltest::mainThread { {threadid ""} } {
- if {[llength [info level 0]] == 1} {
- return $tcltest::mainThread
- }
- set tcltest::mainThread $threadid
-}
-
#####################################################################
# tcltest::AddToSkippedBecause --
#
-# Increments the variable used to track how many tests were skipped
-# because of a particular constraint.
+# Increments the variable used to track how many tests were
+# skipped because of a particular constraint.
#
# Arguments:
# constraint The name of the constraint to be modified
#
# Results:
-# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't
-# previously exist - otherwise, it just increments it.
+# Modifies tcltest::skippedBecause; sets the variable to 1 if
+# didn't previously exist - otherwise, it just increments it.
#
# Side effects:
# None.
@@ -1097,11 +872,12 @@ proc tcltest::mainThread { {threadid ""} } {
proc tcltest::AddToSkippedBecause { constraint {value 1}} {
# add the constraint to the list of constraints that kept tests
# from running
+ variable skippedBecause
- if {[info exists tcltest::skippedBecause($constraint)]} {
- incr tcltest::skippedBecause($constraint) $value
+ if {[info exists skippedBecause($constraint)]} {
+ incr skippedBecause($constraint) $value
} else {
- set tcltest::skippedBecause($constraint) $value
+ set skippedBecause($constraint) $value
}
return
}
@@ -1109,12 +885,12 @@ proc tcltest::AddToSkippedBecause { constraint {value 1}} {
# tcltest::PrintError --
#
# Prints errors to tcltest::errorChannel and then flushes that
-# channel, making sure that all messages are < 80 characters per line.
+# channel, making sure that all messages are < 80 characters per
+# line.
#
# Arguments:
# errorMsg String containing the error to be printed
#
-#
# Results:
# None.
#
@@ -1129,27 +905,30 @@ proc tcltest::PrintError {errorMsg} {
# Keep track of where the end of the string is.
set endingIndex [string length $errorMsg]
- if {$endingIndex < 80} {
+ if {$endingIndex < (80 - $InitialMsgLen)} {
puts [errorChannel] $errorMsg
} else {
# Print up to 80 characters on the first line, including the
- # InitialMessage.
+ # InitialMessage.
set beginningIndex [string last " " [string range $errorMsg 0 \
[expr {80 - $InitialMsgLen}]]]
puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
- while {$beginningIndex != "end"} {
+ while {![string equal end $beginningIndex]} {
puts -nonewline [errorChannel] \
- [string repeat " " $InitialMsgLen]
- if {[expr {$endingIndex - $beginningIndex}] < 72} {
+ [string repeat " " $InitialMsgLen]
+ if {($endingIndex - $beginningIndex)
+ < (80 - $InitialMsgLen)} {
puts [errorChannel] [string trim \
[string range $errorMsg $beginningIndex end]]
- set beginningIndex end
+ break
} else {
- set newEndingIndex [expr [string last " " [string range \
- $errorMsg $beginningIndex \
- [expr {$beginningIndex + 72}]]] + $beginningIndex]
- if {($newEndingIndex <= 0) \
+ set newEndingIndex [expr {[string last " " \
+ [string range $errorMsg $beginningIndex \
+ [expr {$beginningIndex
+ + (80 - $InitialMsgLen)}]
+ ]] + $beginningIndex}]
+ if {($newEndingIndex <= 0)
|| ($newEndingIndex <= $beginningIndex)} {
set newEndingIndex end
}
@@ -1168,181 +947,167 @@ if {[llength [info commands tcltest::initConstraintsHook]] == 0} {
proc tcltest::initConstraintsHook {} {}
}
-# tcltest::safeFetch --
+# tcltest::SafeFetch --
#
-# 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. This is necessary because tests are allowed to use constraint "X"
-# without ensuring that tcltest::testConstraints("X") is defined.
+# The following trace procedure makes it so that we can safely
+# refer to non-existent members of the testConstraints array
+# without causing an error. Instead, reading a non-existent
+# member will return 0. This is necessary because tests are
+# allowed to use constraint "X" without ensuring that
+# testConstraints("X") is defined.
#
# Arguments:
-# n1 - name of the array (tcltest::testConstraints)
+# n1 - name of the array (testConstraints)
# n2 - array key value (constraint name)
-# op - operation performed on tcltest::testConstraints (generally r)
+# op - operation performed on testConstraints (generally r)
#
# Results:
# none
#
# Side effects:
-# sets tcltest::testConstraints($n2) to 0 if it's referenced but never
+# sets testConstraints($n2) to 0 if it's referenced but never
# before used
-proc tcltest::safeFetch {n1 n2 op} {
- DebugPuts 3 "entering safeFetch $n1 $n2 $op"
- if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} {
- tcltest::testConstraint $n2 0
+proc tcltest::SafeFetch {n1 n2 op} {
+ variable testConstraints
+ DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
+ if {[string equal {} $n2]} {return}
+ if {![info exists testConstraints($n2)]} {
+ testConstraint $n2 0
}
}
-# tcltest::initConstraints --
+# tcltest::InitConstraints --
#
-# Check constraint information that will determine which tests
-# to run. To do this, create an array tcltest::testConstraints. Each
-# element has a 0 or 1 value. If the element is "true" then tests
-# with that constraint will be run, otherwise tests with that constraint
-# will be skipped. See the tcltest man page for the list of built-in
-# constraints defined in this procedure.
+# Check constraint information that will determine which tests to run.
+# To do this, create an array testConstraints. Each element has a value
+# of 0 or 1. If the element is "true" then tests with that constraint
+# will be run, otherwise tests with that constraint will be skipped.
+# See the tcltest man page for the list of built-in constraints defined
+# in this procedure.
#
# Arguments:
# none
#
# Results:
-# The tcltest::testConstraints array is reset to have an index for
-# each built-in test constraint.
-#
+# The testConstraints array is reset to have an index for each
+# built-in test constraint.
+#
# Side Effects:
# None.
#
-proc tcltest::initConstraints {} {
+proc tcltest::InitConstraints {} {
global tcl_platform tcl_interactive tk_version
-
- # Safely refer to non-existent members of the tcltest::testConstraints
- # array without causing an error.
- trace variable tcltest::testConstraints r tcltest::safeFetch
-
- tcltest::initConstraintsHook
-
- tcltest::testConstraint singleTestInterp [singleProcess]
-
- # All the 'pc' constraints are here for backward compatibility and are not
- # documented. They have been replaced with equivalent 'win' constraints.
-
- tcltest::testConstraint unixOnly \
- [string equal $tcl_platform(platform) "unix"]
- tcltest::testConstraint macOnly \
- [string equal $tcl_platform(platform) "macintosh"]
- tcltest::testConstraint pcOnly \
- [string equal $tcl_platform(platform) "windows"]
- tcltest::testConstraint winOnly \
- [string equal $tcl_platform(platform) "windows"]
-
- tcltest::testConstraint unix [tcltest::testConstraint unixOnly]
- tcltest::testConstraint mac [tcltest::testConstraint macOnly]
- tcltest::testConstraint pc [tcltest::testConstraint pcOnly]
- tcltest::testConstraint win [tcltest::testConstraint winOnly]
-
- tcltest::testConstraint unixOrPc \
- [expr {[tcltest::testConstraint unix] \
- || [tcltest::testConstraint pc]}]
- tcltest::testConstraint macOrPc \
- [expr {[tcltest::testConstraint mac] \
- || [tcltest::testConstraint pc]}]
- tcltest::testConstraint unixOrWin \
- [expr {[tcltest::testConstraint unix] \
- || [tcltest::testConstraint win]}]
- tcltest::testConstraint macOrWin \
- [expr {[tcltest::testConstraint mac] \
- || [tcltest::testConstraint win]}]
- tcltest::testConstraint macOrUnix \
- [expr {[tcltest::testConstraint mac] \
- || [tcltest::testConstraint unix]}]
-
- tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"]
- tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"]
- tcltest::testConstraint 98 [string equal $tcl_platform(os) "Windows 98"]
-
- # 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.
-
- tcltest::testConstraint tempNotPc \
- [expr {![tcltest::testConstraint pc]}]
- tcltest::testConstraint tempNotWin \
- [expr {![tcltest::testConstraint win]}]
- tcltest::testConstraint tempNotMac \
- [expr {![tcltest::testConstraint mac]}]
- tcltest::testConstraint tempNotUnix \
- [expr {![tcltest::testConstraint unix]}]
-
- # The following Constraints switches are used to mark tests that crash on
- # certain platforms, so that they can be reactivated again when the
- # underlying problem is fixed.
-
- tcltest::testConstraint pcCrash \
- [expr {![tcltest::testConstraint pc]}]
- tcltest::testConstraint winCrash \
- [expr {![tcltest::testConstraint win]}]
- tcltest::testConstraint macCrash \
- [expr {![tcltest::testConstraint mac]}]
- tcltest::testConstraint unixCrash \
- [expr {![tcltest::testConstraint unix]}]
+ variable testConstraints
+
+ # Safely refer to non-existent members of the testConstraints array
+ # without causing an error.
+ trace variable testConstraints r [namespace code SafeFetch]
+
+ initConstraintsHook
+
+ testConstraint singleTestInterp [singleProcess]
+
+ # All the 'pc' constraints are here for backward compatibility and
+ # are not documented. They have been replaced with equivalent 'win'
+ # constraints.
+
+ testConstraint unixOnly [string equal $tcl_platform(platform) unix]
+ testConstraint macOnly \
+ [string equal $tcl_platform(platform) macintosh]
+ testConstraint pcOnly [string equal $tcl_platform(platform) windows]
+ testConstraint winOnly \
+ [string equal $tcl_platform(platform) windows]
+
+ testConstraint unix [testConstraint unixOnly]
+ testConstraint mac [testConstraint macOnly]
+ testConstraint pc [testConstraint pcOnly]
+ testConstraint win [testConstraint winOnly]
+
+ testConstraint unixOrPc \
+ [expr {[testConstraint unix] || [testConstraint pc]}]
+ testConstraint macOrPc \
+ [expr {[testConstraint mac] || [testConstraint pc]}]
+ testConstraint unixOrWin \
+ [expr {[testConstraint unix] || [testConstraint win]}]
+ testConstraint macOrWin \
+ [expr {[testConstraint mac] || [testConstraint win]}]
+ testConstraint macOrUnix \
+ [expr {[testConstraint mac] || [testConstraint unix]}]
+
+ testConstraint nt [string equal $tcl_platform(os) "Windows NT"]
+ testConstraint 95 [string equal $tcl_platform(os) "Windows 95"]
+ testConstraint 98 [string equal $tcl_platform(os) "Windows 98"]
+
+ # 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.
+
+ testConstraint tempNotPc [expr {![testConstraint pc]}]
+ testConstraint tempNotWin [expr {![testConstraint win]}]
+ testConstraint tempNotMac [expr {![testConstraint mac]}]
+ testConstraint tempNotUnix [expr {![testConstraint unix]}]
+
+ # The following Constraints switches are used to mark tests that
+ # crash on certain platforms, so that they can be reactivated again
+ # when the underlying problem is fixed.
+
+ testConstraint pcCrash [expr {![testConstraint pc]}]
+ testConstraint winCrash [expr {![testConstraint win]}]
+ testConstraint macCrash [expr {![testConstraint mac]}]
+ testConstraint unixCrash [expr {![testConstraint unix]}]
# Skip empty tests
- tcltest::testConstraint emptyTest 0
+ testConstraint emptyTest 0
# By default, tests that expose known bugs are skipped.
- tcltest::testConstraint knownBug 0
+ testConstraint knownBug 0
# By default, non-portable tests are skipped.
- tcltest::testConstraint nonPortable 0
+ testConstraint nonPortable 0
# Some tests require user interaction.
- tcltest::testConstraint userInteraction 0
+ testConstraint userInteraction 0
+
+ # Some tests must be skipped if the interpreter is not in
+ # interactive mode
- # Some tests must be skipped if the interpreter is not in interactive mode
-
if {[info exists tcl_interactive]} {
- tcltest::testConstraint interactive $::tcl_interactive
+ testConstraint interactive $tcl_interactive
} else {
- tcltest::testConstraint interactive 0
+ testConstraint interactive 0
}
- # Some tests can only be run if the installation came from a CD image
- # instead of a web image
- # Some tests must be skipped if you are running as root on Unix.
- # Other tests can only be run if you are running as root on Unix.
+ # Some tests can only be run if the installation came from a CD
+ # image instead of a web image. Some tests must be skipped if you
+ # are running as root on Unix. Other tests can only be run if you
+ # are running as root on Unix.
- tcltest::testConstraint root 0
- tcltest::testConstraint notRoot 1
- set user {}
- if {[string equal $tcl_platform(platform) "unix"]} {
- catch {set user [exec whoami]}
- if {[string equal $user ""]} {
- catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
- }
- if {([string equal $user "root"]) || ([string equal $user ""])} {
- tcltest::testConstraint root 1
- tcltest::testConstraint notRoot 0
- }
+ testConstraint root 0
+ testConstraint notRoot 1
+ if {[string equal unix $tcl_platform(platform)]
+ && ([string equal root $tcl_platform(user)]
+ || [string equal "" $tcl_platform(user)])} {
+ testConstraint root 1
+ testConstraint notRoot 0
}
# Set nonBlockFiles constraint: 1 means this platform supports
# setting files into nonblocking mode.
if {[catch {set f [open defs r]}]} {
- tcltest::testConstraint nonBlockFiles 1
+ testConstraint nonBlockFiles 1
} else {
if {[catch {fconfigure $f -blocking off}] == 0} {
- tcltest::testConstraint nonBlockFiles 1
+ testConstraint nonBlockFiles 1
} else {
- tcltest::testConstraint nonBlockFiles 0
+ testConstraint nonBlockFiles 0
}
close $f
}
@@ -1354,36 +1119,36 @@ proc tcltest::initConstraints {} {
# potential problem with select is apparently interfering.
# (Mark Diekhans).
- tcltest::testConstraint asyncPipeClose 1
- if {[string equal $tcl_platform(platform) "unix"] \
- && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0)} {
- tcltest::testConstraint asyncPipeClose 0
+ testConstraint asyncPipeClose 1
+ if {[string equal unix $tcl_platform(platform)] && ([catch {
+ exec uname -X | fgrep {Release = 3.2v}}] == 0)} {
+ testConstraint asyncPipeClose 0
}
# Test to see if we have a broken version of sprintf with respect
# to the "e" format of floating-point numbers.
- tcltest::testConstraint eformat 1
- if {![string equal "[format %g 5e-5]" "5e-05"]} {
- tcltest::testConstraint eformat 0
+ testConstraint eformat 1
+ if {![string equal [format %g 5e-5] 5e-05]} {
+ testConstraint eformat 0
}
- # Test to see if execed commands such as cat, echo, rm and so forth are
- # present on this machine.
+ # Test to see if execed commands such as cat, echo, rm and so forth
+ # are present on this machine.
- tcltest::testConstraint unixExecs 1
- if {[string equal $tcl_platform(platform) "macintosh"]} {
- tcltest::testConstraint unixExecs 0
+ testConstraint unixExecs 1
+ if {[string equal macintosh $tcl_platform(platform)]} {
+ testConstraint unixExecs 0
}
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([string equal $tcl_platform(platform) "windows"])} {
+ if {[testConstraint unixExecs]
+ && [string equal windows $tcl_platform(platform)]} {
set file "_tcl_test_remove_me.txt"
if {[catch {
set fid [open $file w]
puts $fid "hello"
close $fid
}]} {
- tcltest::testConstraint unixExecs 0
+ testConstraint unixExecs 0
} elseif {
[catch {exec cat $file}] ||
[catch {exec echo hello}] ||
@@ -1398,7 +1163,7 @@ proc tcltest::initConstraints {} {
[string equal {} [auto_execok grep]] ||
[string equal {} [auto_execok ps]]
} {
- tcltest::testConstraint unixExecs 0
+ testConstraint unixExecs 0
}
file delete -force $file
}
@@ -1408,7 +1173,7 @@ proc tcltest::initConstraints {} {
interpreter [info nameofexecutable]
}
- tcltest::testConstraint stdio 0
+ testConstraint stdio 0
catch {
catch {file delete -force tmp}
set f [open tmp w]
@@ -1420,33 +1185,32 @@ proc tcltest::initConstraints {} {
set f [open "|[list [interpreter] tmp]" r]
close $f
- tcltest::testConstraint stdio 1
+ testConstraint stdio 1
}
catch {file delete -force tmp}
- # Deliberately call socket with the wrong number of arguments. The error
- # message you get will indicate whether sockets are available on this
- # system.
+ # Deliberately call socket with the wrong number of arguments. The
+ # error message you get will indicate whether sockets are available
+ # on this system.
catch {socket} msg
- tcltest::testConstraint socket \
- [expr {$msg != "sockets are not available on this system"}]
-
+ testConstraint socket [string compare $msg \
+ "sockets are not available on this system"]
+
# Check for internationalization
- if {[info commands testlocale] == ""} {
+ if {[llength [info commands testlocale]] == 0} {
# No testlocale command, no tests...
- tcltest::testConstraint hasIsoLocale 0
+ testConstraint hasIsoLocale 0
} else {
- tcltest::testConstraint hasIsoLocale \
- [string length [tcltest::set_iso8859_1_locale]]
- tcltest::restore_locale
+ testConstraint hasIsoLocale \
+ [string length [SetIso8859_1_Locale]]
+ RestoreLocale
}
-}
-
+}
#####################################################################
-# Handle command line arguments (from argv) and default arg settings
+# Handle command line arguments (from argv) and default arg settings
# (in TCLTEST_OPTIONS).
# tcltest::PrintUsageInfoHook
@@ -1460,8 +1224,8 @@ if {[llength [info commands tcltest::PrintUsageInfoHook]] == 0} {
# tcltest::PrintUsageInfo
#
-# Prints out the usage information for package tcltest. This can be
-# customized with the redefinition of tcltest::PrintUsageInfoHook.
+# Prints out the usage information for package tcltest. This can
+# be customized with the redefinition of [PrintUsageInfoHook].
#
# Arguments:
# none
@@ -1469,83 +1233,88 @@ if {[llength [info commands tcltest::PrintUsageInfoHook]] == 0} {
# Results:
# none
#
-# Side Effects:
+# Side Effects:
# none
-
proc tcltest::PrintUsageInfo {} {
- puts [format "Usage: [file tail [info nameofexecutable]] \
- script ?-help? ?flag value? ... \n\
- Available flags (and valid input values) are: \n\
- -help \t Display this usage information. \n\
- -verbose level \t 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\t Do not skip the listed constraints\n\
- -limitconstraints bool\t Only run tests with the constraints\n\
- \t listed in -constraints.\n\
- -match pattern \t Run all tests within the specified \n\
- \t files that match the glob pattern \n\
- \t given. \n\
- -skip pattern \t 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 \t Run tests in all test files that \n\
- \t match the glob pattern given. \n\
- -notfile pattern\t Skip all test files that match the \n\
- \t glob pattern given. \n\
- -relateddir pattern\t Run tests in directories that match \n\
- \t the glob pattern given. \n\
- -asidefromdir pattern\t Skip tests in directories that match \n\
- \t the glob pattern given.\n\
- -preservecore level \t 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 $tcltest::preserveCore. \n\
- -tmpdir directory\t Save temporary files in the specified\n\
- \t directory. The default value is \n\
- \t $tcltest::temporaryDirectory. \n\
- -testdir directories\t Search tests in the specified\n\
- \t directories. The default value is \n\
- \t $tcltest::testsDirectory. \n\
- -outfile file \t Send output from test runs to the \n\
- \t specified file. The default is \n\
- \t stdout. \n\
- -errfile file \t Send errors from test runs to the \n\
- \t specified file. The default is \n\
- \t stderr. \n\
- -loadfile file \t Read the script to load the tested \n\
- \t commands from the specified file. \n\
- -load script \t Specifies the script to load the tested \n\
- \t commands. \n\
- -debug level \t Internal debug flag."]
- tcltest::PrintUsageInfoHook
+ 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."
+ 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.
+# 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} {
+if {[llength [info commands \
+ tcltest::processCmdLineArgsAddFlagsHook]] == 0} {
proc tcltest::processCmdLineArgsAddFlagsHook {} {}
}
# tcltest::processCmdLineArgsHook --
#
# This hook is used to actually process the flags added by
-# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of
-# ProcessFlags.
+# tcltest::processCmdLineArgsAddFlagsHook. It is called at the
+# end of ProcessFlags.
#
# Arguments:
# flags The flags that have been pulled out of argv
@@ -1557,16 +1326,16 @@ if {[llength [info commands tcltest::processCmdLineArgsHook]] == 0} {
# tcltest::ProcessFlags --
#
-# process command line arguments supplied in the flagArray - this is
-# called by processCmdLineArgs
-# modifies tcltest variables according to the content of the flagArray.
+# process command line arguments supplied in the flagArray - this
+# is called by processCmdLineArgs. Modifies tcltest variables
+# according to the content of the flagArray.
#
# Arguments:
# flagArray - array containing name/value pairs of flags
#
# Results:
# sets tcltest variables according to their values as defined by
-# flagArray
+# flagArray
#
# Side effects:
# None.
@@ -1574,10 +1343,10 @@ if {[llength [info commands tcltest::processCmdLineArgsHook]] == 0} {
proc tcltest::ProcessFlags {flagArray} {
# Process -help first
if {[lsearch -exact $flagArray {-help}] != -1} {
- tcltest::PrintUsageInfo
+ PrintUsageInfo
exit 1
}
-
+
catch {array set flag $flagArray}
# -help is not listed since it has already been processed
@@ -1586,154 +1355,156 @@ proc tcltest::ProcessFlags {flagArray} {
-preservecore -limitconstraints -testdir \
-load -loadfile -asidefromdir \
-relateddir -singleproc
- set defaultFlags [concat $defaultFlags \
- [tcltest::processCmdLineArgsAddFlagsHook ]]
+ set defaultFlags \
+ [concat $defaultFlags [processCmdLineArgsAddFlagsHook]]
- # Set tcltest::verbose to the arg of the -verbose flag, if given
+ # Set verbose to the arg of the -verbose flag, if given
if {[info exists flag(-verbose)]} {
- tcltest::verbose $flag(-verbose)
+ verbose $flag(-verbose)
}
- # Set tcltest::match to the arg of the -match flag, if given.
+ # Set match to the arg of the -match flag, if given.
if {[info exists flag(-match)]} {
- tcltest::match $flag(-match)
- }
+ match $flag(-match)
+ }
- # Set tcltest::skip to the arg of the -skip flag, if given
+ # Set skip to the arg of the -skip flag, if given
if {[info exists flag(-skip)]} {
- tcltest::skip $flag(-skip)
+ skip $flag(-skip)
}
# Handle the -file and -notfile flags
if {[info exists flag(-file)]} {
- tcltest::matchFiles $flag(-file)
+ matchFiles $flag(-file)
}
if {[info exists flag(-notfile)]} {
- tcltest::skipFiles $flag(-notfile)
+ skipFiles $flag(-notfile)
}
# Handle -relateddir and -asidefromdir flags
if {[info exists flag(-relateddir)]} {
- tcltest::matchDirectories $flag(-relateddir)
+ matchDirectories $flag(-relateddir)
}
if {[info exists flag(-asidefromdir)]} {
- tcltest::skipDirectories $flag(-asidefromdir)
+ skipDirectories $flag(-asidefromdir)
}
- # Use the -constraints flag, if given, to turn on constraints that are
- # turned off by default: userInteractive knownBug nonPortable. This
- # code fragment must be run after constraints are initialized.
+ # Use the -constraints flag, if given, to turn on constraints that
+ # are turned off by default: userInteractive knownBug nonPortable.
+ # This code fragment must be run after constraints are initialized.
if {[info exists flag(-constraints)]} {
foreach elt $flag(-constraints) {
- tcltest::testConstraint $elt 1
+ testConstraint $elt 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.
+ # 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)]} {
- set msg "-limitconstraints flag can only be used with -constraints"
- error $msg
+ error "-limitconstraints flag can only\
+ be used with -constraints"
}
- tcltest::limitConstraints $flag(-limitconstraints)
+ limitConstraints $flag(-limitconstraints)
}
- # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if
- # given.
+ # Set the temporaryDirectory to the arg of -tmpdir, if given.
if {[info exists flag(-tmpdir)]} {
- tcltest::temporaryDirectory $flag(-tmpdir)
+ temporaryDirectory $flag(-tmpdir)
}
- # Set the tcltest::testsDirectory to the arg of -testdir, if
- # given.
-
+ # Set the testsDirectory to the arg of -testdir, if given.
+
if {[info exists flag(-testdir)]} {
- tcltest::testsDirectory $flag(-testdir)
+ testsDirectory $flag(-testdir)
}
# If an alternate error or output files are specified, change the
# default channels.
if {[info exists flag(-outfile)]} {
- tcltest::outputFile $flag(-outfile)
- }
+ outputFile $flag(-outfile)
+ }
if {[info exists flag(-errfile)]} {
- tcltest::errorFile $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])} {
- tcltest::loadScript $flag(-load)
+ loadScript $flag(-load)
}
-
+
if {[info exists flag(-loadfile)] && \
([lsearch -exact $flagArray -loadfile] > \
[lsearch -exact $flagArray -load]) } {
- tcltest::loadFile $flag(-loadfile)
+ loadFile $flag(-loadfile)
}
- # If the user specifies debug testing, print out extra information during
- # the run.
+ # If the user specifies debug testing, print out extra information
+ # during the run.
if {[info exists flag(-debug)]} {
- tcltest::debug $flag(-debug)
+ debug $flag(-debug)
}
# Handle -preservecore
if {[info exists flag(-preservecore)]} {
- tcltest::preserveCore $flag(-preservecore)
+ preserveCore $flag(-preservecore)
}
# Handle -singleproc flag
if {[info exists flag(-singleproc)]} {
- tcltest::singleProcess $flag(-singleproc)
+ singleProcess $flag(-singleproc)
}
# Call the hook
- tcltest::processCmdLineArgsHook [array get flag]
+ processCmdLineArgsHook [array get flag]
return
}
-# tcltest::processCmdLineArgs --
+# 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 constraints are initialized,
+# 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.
+# TCLTEST_OPTIONS first, then override with command-line options,
+# if specified.
#
# Arguments:
# none
#
# Results:
# Sets the above-named variables in the tcltest namespace.
-#
+#
# Side Effects:
# None.
#
-proc tcltest::processCmdLineArgs {} {
+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 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)]} {
- tcltest::ProcessFlags $::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)} {
@@ -1741,27 +1512,29 @@ proc tcltest::processCmdLineArgs {} {
} else {
set flagArray $argv
}
-
- tcltest::ProcessFlags $flagArray
- # Spit out everything you know if we're at a debug level 2 or greater
+ ProcessFlags $flagArray
+
+ # Spit out everything you know if we're at a debug level 2 or
+ # greater
DebugPuts 2 "Flags passed into tcltest:"
if {[info exists ::env(TCLTEST_OPTIONS)]} {
- DebugPuts 2 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
+ DebugPuts 2 \
+ " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
}
if {[info exists argv]} {
DebugPuts 2 " argv: $argv"
}
- DebugPuts 2 "tcltest::debug = [tcltest::debug]"
- DebugPuts 2 "tcltest::testsDirectory = [tcltest::testsDirectory]"
- DebugPuts 2 "tcltest::workingDirectory = [tcltest::workingDirectory]"
- DebugPuts 2 "tcltest::temporaryDirectory = [tcltest::temporaryDirectory]"
+ DebugPuts 2 "tcltest::debug = [debug]"
+ DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]"
+ DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]"
+ DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]"
DebugPuts 2 "tcltest::outputChannel = [outputChannel]"
DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
DebugPuts 2 "Original environment (tcltest::originalEnv):"
- DebugPArray 2 tcltest::originalEnv
+ DebugPArray 2 originalEnv
DebugPuts 2 "Constraints:"
- DebugPArray 2 tcltest::testConstraints
+ DebugPArray 2 testConstraints
return
}
@@ -1769,11 +1542,11 @@ proc tcltest::processCmdLineArgs {} {
# Code to run the tests goes here.
-# tcltest::testPuts --
+# tcltest::TestPuts --
#
-# Used to redefine puts in test environment.
-# Stores whatever goes out on stdout in tcltest::outData and stderr in
-# tcltest::errData before sending it on to the regular puts.
+# Used to redefine puts in test environment. Stores whatever goes
+# out on stdout in tcltest::outData and stderr in errData before
+# sending it on to the regular puts.
#
# Arguments:
# same as standard puts
@@ -1782,88 +1555,101 @@ proc tcltest::processCmdLineArgs {} {
# none
#
# Side effects:
-# Intercepts puts; data that would otherwise go to stdout, stderr, or
-# file channels specified in tcltest::outputChannel and errorChannel does
-# not get sent to the normal puts function.
-
-proc tcltest::testPuts {args} {
- set len [llength $args]
- if {$len == 1} {
- # Only the string to be printed is specified
- append tcltest::outData "[lindex $args 0]\n"
- return
-# return [tcltest::normalPuts [lindex $args 0]]
- } elseif {$len == 2} {
- # Either -nonewline or channelId has been specified
- if {[regexp {^-nonewline} [lindex $args 0]]} {
- append tcltest::outData "[lindex $args end]"
+# Intercepts puts; data that would otherwise go to stdout, stderr,
+# or file channels specified in outputChannel and errorChannel
+# does not get sent to the normal puts function.
+namespace eval tcltest::Replace {
+ namespace export puts
+}
+proc tcltest::Replace::puts {args} {
+ variable [namespace parent]::outData
+ variable [namespace parent]::errData
+ switch [llength $args] {
+ 1 {
+ # Only the string to be printed is specified
+ append outData [lindex $args 0]\n
return
-# return [tcltest::normalPuts -nonewline [lindex $args end]]
- } else {
- set channel [lindex $args 0]
+ # return [Puts [lindex $args 0]]
+ }
+ 2 {
+ # Either -nonewline or channelId has been specified
+ if {[string equal -nonewline [lindex $args 0]]} {
+ append outData [lindex $args end]
+ return
+ # return [Puts -nonewline [lindex $args end]]
+ } else {
+ set channel [lindex $args 0]
+ }
}
- } elseif {$len == 3} {
- if {[lindex $args 0] == "-nonewline"} {
- # Both -nonewline and channelId are specified, unless it's an
- # error. -nonewline is supposed to be argv[0].
- set channel [lindex $args 1]
+ 3 {
+ if {[string equal -nonewline [lindex $args 0]]} {
+ # Both -nonewline and channelId are specified, unless
+ # it's an error. -nonewline is supposed to be argv[0].
+ set channel [lindex $args 1]
+ }
}
}
if {[info exists channel]} {
- if {($channel == [outputChannel]) || ($channel == "stdout")} {
- append tcltest::outData "[lindex $args end]\n"
- } elseif {($channel == [errorChannel]) || ($channel == "stderr")} {
- append tcltest::errData "[lindex $args end]\n"
+ if {[string equal $channel [outputChannel]]
+ || [string equal $channel stdout]} {
+ append outData [lindex $args end]\n
+ } elseif {[string equal $channel [errorChannel]]
+ || [string equal $channel stderr]} {
+ append errData [lindex $args end]\n
}
return
- # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]]
+ # return [Puts [lindex $args 0] [lindex $args end]]
}
- # If we haven't returned by now, we don't know how to handle the input.
- # Let puts handle it.
- return [eval tcltest::normalPuts $args]
+ # If we haven't returned by now, we don't know how to handle the
+ # input. Let puts handle it.
+ return [eval Puts $args]
}
-# tcltest::testEval --
+# tcltest::Eval --
#
-# Evaluate the script in the test environment. If ignoreOutput is
-# false, store data sent to stderr and stdout in tcltest::outData and
-# tcltest::errData. Otherwise, ignore this output altogether.
+# Evaluate the script in the test environment. If ignoreOutput is
+# false, store data sent to stderr and stdout in outData and
+# errData. Otherwise, ignore this output altogether.
#
# Arguments:
# script Script to evaluate
-# ?ignoreOutput? Indicates whether or not to ignore output sent to
-# stdout & stderr
+# ?ignoreOutput? Indicates whether or not to ignore output
+# sent to stdout & stderr
#
# Results:
# result from running the script
#
# Side effects:
-# Empties the contents of tcltest::outData and tcltest::errData before
-# running a test if ignoreOutput is set to 0.
+# Empties the contents of outData and errData before running a
+# test if ignoreOutput is set to 0.
-proc tcltest::testEval {script {ignoreOutput 1}} {
- DebugPuts 3 "testEval called"
+proc tcltest::Eval {script {ignoreOutput 1}} {
+ variable outData
+ variable errData
+ DebugPuts 3 "[lindex [info level 0] 0] called"
if {!$ignoreOutput} {
- set tcltest::outData {}
- set tcltest::errData {}
- uplevel rename ::puts tcltest::normalPuts
- uplevel rename tcltest::testPuts ::puts
- }
- set result [uplevel $script]
+ set outData {}
+ set errData {}
+ # If caller has its own [puts], this may disable it.
+ uplevel 1 [list ::rename puts [namespace current]::Puts]
+ uplevel 1 [list ::namespace import \
+ [namespace origin Replace::puts]]
+ }
+ set result [uplevel 1 $script]
if {!$ignoreOutput} {
- uplevel rename ::puts tcltest::testPuts
- uplevel rename tcltest::normalPuts ::puts
+ uplevel 1 ::namespace forget puts
+ uplevel 1 [list ::rename [namespace current]::Puts puts]
}
return $result
}
-# compareStrings --
+# tcltest::CompareStrings --
#
-# compares the expected answer to the actual answer, depending on the
-# mode provided. Mode determines whether a regexp, exact, or glob
-# comparison is done.
+# compares the expected answer to the actual answer, depending on
+# the mode provided. Mode determines whether a regexp, exact, or
+# glob comparison is done.
#
# Arguments:
# actual - string containing the actual result
@@ -1876,7 +1662,7 @@ proc tcltest::testEval {script {ignoreOutput 1}} {
# Side effects:
# None.
-proc tcltest::compareStrings {actual expected mode} {
+proc tcltest::CompareStrings {actual expected mode} {
switch -- $mode {
exact {
set retval [string equal $actual $expected]
@@ -1892,19 +1678,18 @@ proc tcltest::compareStrings {actual expected mode} {
}
-#
-# tcltest::substArguments list
+# tcltest::SubstArguments list
#
# This helper function takes in a list of words, then perform a
-# substitution on the list as though each word in the list is a
-# separate argument to the Tcl function. For example, if this
-# function is invoked as:
+# substitution on the list as though each word in the list is a separate
+# argument to the Tcl function. For example, if this function is
+# invoked as:
#
-# substArguments {$a {$a}}
+# SubstArguments {$a {$a}}
#
# Then it is as though the function is invoked as:
#
-# substArguments $a {$a}
+# SubstArguments $a {$a}
#
# This code is adapted from Paul Duffin's function "SplitIntoWords".
# The original function can be found on:
@@ -1922,16 +1707,15 @@ proc tcltest::compareStrings {actual expected mode} {
# None.
#
-proc tcltest::substArguments {argList} {
+proc tcltest::SubstArguments {argList} {
- # We need to split the argList up into tokens but cannot use
- # list operations as they throw away some significant
- # quoting, and [split] ignores braces as it should.
- # Therefore what we do is gradually build up a string out of
- # whitespace seperated strings. We cannot use [split] to
- # split the argList into whitespace seperated strings as it
- # throws away the whitespace which maybe important so we
- # have to do it all by hand.
+ # We need to split the argList up into tokens but cannot use list
+ # operations as they throw away some significant quoting, and
+ # [split] ignores braces as it should. Therefore what we do is
+ # gradually build up a string out of whitespace seperated strings.
+ # We cannot use [split] to split the argList into whitespace
+ # separated strings as it throws away the whitespace which maybe
+ # important so we have to do it all by hand.
set result {}
set token ""
@@ -1939,11 +1723,11 @@ proc tcltest::substArguments {argList} {
while {[string length $argList]} {
# Look for the next word containing a quote: " { }
if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
- $argList all]} {
- # Get the text leading up to this word, but not
- # including this word, from the argList.
+ $argList all]} {
+ # Get the text leading up to this word, but not including
+ # this word, from the argList.
set text [string range $argList 0 \
- [expr {[lindex $all 0] - 1}]]
+ [expr {[lindex $all 0] - 1}]]
# Get the word with the quote
set word [string range $argList \
[lindex $all 0] [lindex $all 1]]
@@ -1958,7 +1742,7 @@ proc tcltest::substArguments {argList} {
set word {}
set argList {}
}
-
+
if {$token != {}} {
# If we saw a word with quote before, then there is a
# multi-word token starting with that word. In this case,
@@ -1973,7 +1757,7 @@ proc tcltest::substArguments {argList} {
append result $text
set token $word
}
-
+
if { [catch {llength $token} length] == 0 && $length == 1} {
# The token is a valid list so add it to the result.
# lappend result [string trim $token]
@@ -1994,108 +1778,112 @@ proc tcltest::substArguments {argList} {
# tcltest::test --
#
-# This procedure runs a test and prints an error message if the test fails.
-# If tcltest::verbose has been set, it also prints a message even if the
+# This procedure runs a test and prints an error message if the test
+# fails. If verbose has been set, it also prints a message even if the
# test succeeds. The test will be skipped if it doesn't match the
-# tcltest::match variable, if it matches an element in
-# tcltest::skip, or if one of the elements of "constraints" turns
-# out not to be true.
-#
-# If testLevel is 1, then this is a top level test, and we record pass/fail
-# information; otherwise, this information is not logged and is not added to
-# running totals.
-#
+# match variable, if it matches an element in skip, or if one of the
+# elements of "constraints" turns out not to be true.
+#
+# If testLevel is 1, then this is a top level test, and we record
+# pass/fail information; otherwise, this information is not logged and
+# is not added to running totals.
+#
# Attributes:
# Only description is a required attribute. All others are optional.
# Default values are indicated.
-#
-# constraints - A list of one or more keywords, each of
-# which must be the name of an element in
-# the array "tcltest::testConstraints". If any
-# of these elements is zero, the test is
-# skipped. This attribute is optional; default is {}
-# body - Script to run to carry out the test. It must
-# return a result that can be checked for
-# correctness. This attribute is optional;
-# default is {}
-# result - Expected result from script. This attribute is
-# optional; default is {}.
-# output - Expected output sent to stdout. This attribute
-# is optional; default is {}.
-# errorOutput - Expected output sent to stderr. This attribute
-# is optional; default is {}.
-# returnCodes - Expected return codes. This attribute is
-# optional; default is {0 2}.
-# setup - Code to run before $script (above). This
-# attribute is optional; default is {}.
-# cleanup - Code to run after $script (above). This
-# attribute is optional; default is {}.
-# match - specifies type of matching to do on result,
-# output, errorOutput; this must be one of: exact,
-# glob, regexp. default is exact.
+#
+# constraints - A list of one or more keywords, each of which
+# must be the name of an element in the array
+# "testConstraints". If any of these elements is
+# zero, the test is skipped. This attribute is
+# optional; default is {}
+# body - Script to run to carry out the test. It must
+# return a result that can be checked for
+# correctness. This attribute is optional;
+# default is {}
+# result - Expected result from script. This attribute is
+# optional; default is {}.
+# output - Expected output sent to stdout. This attribute
+# is optional; default is {}.
+# errorOutput - Expected output sent to stderr. This attribute
+# is optional; default is {}.
+# returnCodes - Expected return codes. This attribute is
+# optional; default is {0 2}.
+# setup - Code to run before $script (above). This
+# attribute is optional; default is {}.
+# cleanup - Code to run after $script (above). This
+# attribute is optional; default is {}.
+# match - specifies type of matching to do on result,
+# output, errorOutput; this must be one of: exact,
+# glob, regexp. default is exact.
#
# Arguments:
# name - Name of test, in the form foo-1.2.
# description - Short textual description of the test, to
# help humans understand what it does.
-#
+#
# Results:
# 0 if the command ran successfully; 1 otherwise.
#
# Side effects:
# None.
-#
+#
proc tcltest::test {name description args} {
- DebugPuts 3 "Test $name $args"
+ global tcl_platform
+ variable testLevel
+ DebugPuts 3 "test $name $args"
- incr tcltest::testLevel
+ incr testLevel
# Pre-define everything to null except output and errorOutput. We
- # determine whether or not to trap output based on whether or not these
- # variables (output & errorOutput) are defined.
- foreach item {constraints setup cleanup body result returnCodes match} {
+ # determine whether or not to trap output based on whether or not
+ # these variables (output & errorOutput) are defined.
+ foreach item {constraints setup cleanup body result returnCodes
+ match} {
set $item {}
}
# Set the default match mode
set match exact
- # Set the default match values for return codes (0 is the standard expected
- # return value if everything went well; 2 represents 'return' being used in
- # the test script).
+ # Set the default match values for return codes (0 is the standard
+ # expected return value if everything went well; 2 represents
+ # 'return' being used in the test script).
set returnCodes [list 0 2]
- # The old test format can't have a 3rd argument (constraints or script)
- # that starts with '-'.
+ # The old test format can't have a 3rd argument (constraints or
+ # script) that starts with '-'.
if {[llength $args] == 0} {
- puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}"
- incr tcltest::testLevel -1
+ puts [errorChannel] "test $name: {wrong # args:\
+ should be \"test name desc ?options?\"}"
+ incr testLevel -1
return 1
- } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} {
-
+ } elseif {[string match -* [lindex $args 0]]
+ || ([llength $args] == 1)} {
if {[llength $args] == 1} {
- set list [substArguments [lindex $args 0]]
- foreach {element value} $list {
+ set list [SubstArguments [lindex $args 0]]
+ foreach {element value} $list {
set testAttributes($element) $value
}
foreach item {constraints match setup body cleanup \
result returnCodes output errorOutput} {
if {[info exists testAttributes([subst -$item])]} {
- set testAttributes([subst -$item]) \
- [uplevel concat $testAttributes([subst -$item])]
+ set testAttributes([subst -$item]) [uplevel 1 \
+ ::concat $testAttributes([subst -$item])]
}
}
} else {
array set testAttributes $args
}
- set validFlags {-setup -cleanup -body -result -returnCodes -match \
- -output -errorOutput -constraints}
+ set validFlags {-setup -cleanup -body -result -returnCodes \
+ -match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
if {[lsearch -exact $validFlags $flag] == -1} {
- puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test"
+ puts [errorChannel] "test $name:\
+ bad flag $flag supplied to tcltest::test"
incr tcltest::testLevel -1
return 1
}
@@ -2108,7 +1896,8 @@ proc tcltest::test {name description args} {
# Check the values supplied for -match
if {[lsearch {regexp glob exact} $match] == -1} {
- puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}"
+ puts [errorChannel] "test $name: {bad value for -match:\
+ must be one of exact, glob, regexp}"
incr tcltest::testLevel -1
return 1
}
@@ -2118,10 +1907,10 @@ proc tcltest::test {name description args} {
regsub -nocase error $returnCodes 1 returnCodes
regsub -nocase return $returnCodes 2 returnCodes
regsub -nocase break $returnCodes 3 returnCodes
- regsub -nocase continue $returnCodes 4 returnCodes
+ regsub -nocase continue $returnCodes 4 returnCodes
} else {
- # This is parsing for the old test command format; it is here for
- # backward compatibility.
+ # This is parsing for the old test command format; it is here
+ # for backward compatibility.
set result [lindex $args end]
if {[llength $args] == 2} {
set body [lindex $args 0]
@@ -2129,35 +1918,39 @@ proc tcltest::test {name description args} {
set constraints [lindex $args 0]
set body [lindex $args 1]
} else {
- puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}"
+ puts [errorChannel] "test $name: {wrong # args:\
+ should be \"test name desc ?constraints?\
+ script expectedResult\"}"
incr tcltest::testLevel -1
return 1
}
- }
+ }
set setupFailure 0
set cleanupFailure 0
# Run the setup script
- if {[catch {uplevel $setup} setupMsg]} {
+ if {[catch {uplevel 1 $setup} setupMsg]} {
set setupFailure 1
}
# run the test script
- set command [list tcltest::runTest $name $description $body \
- $result $constraints]
+ set command [list [namespace origin RunTest] $name $description \
+ $body $result $constraints]
if {!$setupFailure} {
if {[info exists output] || [info exists errorOutput]} {
- set testResult [uplevel tcltest::testEval [list $command] 0]
+ set testResult [uplevel 1 \
+ [list [namespace origin Eval] $command 0]]
} else {
- set testResult [uplevel tcltest::testEval [list $command] 1]
+ set testResult [uplevel 1 \
+ [list [namespace origin Eval] $command 1]]
}
} else {
set testResult setupFailure
}
# Run the cleanup code
- if {[catch {uplevel $cleanup} cleanupMsg]} {
+ if {[catch {uplevel 1 $cleanup} cleanupMsg]} {
set cleanupFailure 1
}
@@ -2165,31 +1958,34 @@ proc tcltest::test {name description args} {
if {$testResult != {}} {
set coreFailure 0
set coreMsg ""
- # check for a core file first - if one was created by the test, then
- # the test failed
- if {$tcltest::preserveCore} {
+ # check for a core file first - if one was created by the test,
+ # then the test failed
+ if {[preserveCore]} {
set currentTclPlatform [array get tcl_platform]
- if {[file exists [file join [tcltest::workingDirectory] core]]} {
- # There's only a test failure if there is a core file and (1)
- # there previously wasn't one or (2) the new one is different
- # from the old one.
+ if {[file exists [file join [workingDirectory] core]]} {
+ # There's only a test failure if there is a core file
+ # and (1) there previously wasn't one or (2) the new
+ # one is different from the old one.
+ variable coreModTime
if {[info exists coreModTime]} {
if {$coreModTime != [file mtime \
- [file join [tcltest::workingDirectory] core]]} {
+ [file join [workingDirectory] core]]} {
set coreFailure 1
- }
+ }
} else {
set coreFailure 1
}
- if {($tcltest::preserveCore > 1) && ($coreFailure)} {
- append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]"
+ if {([preserveCore] > 1) && ($coreFailure)} {
+ append coreMsg "\nMoving file to:\
+ [file join [temporaryDirectory] core-$name]"
catch {file rename -force \
- [file join [tcltest::workingDirectory] core] \
- [file join $tcltest::temporaryDirectory \
- core-$name]} msg
+ [file join [workingDirectory] core] \
+ [file join [temporaryDirectory] core-$name]
+ } msg
if {[string length $msg] > 0} {
- append coreMsg "\nError: Problem renaming core file: $msg"
+ append coreMsg "\nError:\
+ Problem renaming core file: $msg"
}
}
}
@@ -2203,13 +1999,15 @@ proc tcltest::test {name description args} {
# them. If the comparison fails, then so did the test.
set outputFailure 0
set errorFailure 0
- if {[info exists output]} {
- set outputFailure [expr ![compareStrings $tcltest::outData \
- $output $match]]
- }
+ variable outData
+ if {[info exists output]} {
+ set outputFailure [expr \
+ {![CompareStrings $outData $output $match]}]
+ }
+ variable errData
if {[info exists errorOutput]} {
- set errorFailure [expr ![compareStrings $tcltest::errData \
- $errorOutput $match]]
+ set errorFailure [expr \
+ {![CompareStrings $errData $errorOutput $match]}]
}
set testFailed 1
@@ -2219,20 +2017,21 @@ proc tcltest::test {name description args} {
# check if the return code matched the expected return code
if {[lsearch -exact $returnCodes $code] == -1} {
set codeFailure 1
- }
+ }
# check if the answer matched the expected answer
- if {[compareStrings $actualAnswer $result $match] == 0} {
+ if {[CompareStrings $actualAnswer $result $match] == 0} {
set scriptFailure 1
}
# if we didn't experience any failures, then we passed
- if {!($setupFailure || $cleanupFailure || $coreFailure || \
- $outputFailure || $errorFailure || $codeFailure || \
- $scriptFailure)} {
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Passed)
- if {[tcltest::isVerbose pass]} {
+ variable numTests
+ if {!($setupFailure || $cleanupFailure || $coreFailure
+ || $outputFailure || $errorFailure || $codeFailure
+ || $scriptFailure)} {
+ if {$testLevel == 1} {
+ incr numTests(Passed)
+ if {[IsVerbose pass]} {
puts [outputChannel] "++++ $name PASSED"
}
}
@@ -2240,24 +2039,28 @@ proc tcltest::test {name description args} {
}
if {$testFailed} {
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Failed)
+ if {$testLevel == 1} {
+ incr numTests(Failed)
}
- set tcltest::currentFailure true
- if {![tcltest::isVerbose body]} {
+ variable currentFailure true
+ if {![IsVerbose body]} {
set body ""
}
- puts [outputChannel] "\n==== $name [string trim $description] FAILED"
- if {$body != ""} {
+ puts [outputChannel] "\n==== $name\
+ [string trim $description] FAILED"
+ if {[string length $body]} {
puts [outputChannel] "==== Contents of test case:"
puts [outputChannel] $body
}
if {$setupFailure} {
- puts [outputChannel] "---- Test setup failed:\n$setupMsg"
- }
+ puts [outputChannel] "---- Test setup\
+ failed:\n$setupMsg"
+ }
if {$scriptFailure} {
- puts [outputChannel] "---- Result was:\n$actualAnswer"
- puts [outputChannel] "---- Result should have been ($match matching):\n$result"
+ puts [outputChannel] "---- Result\
+ was:\n$actualAnswer"
+ puts [outputChannel] "---- Result should have been\
+ ($match matching):\n$result"
}
if {$codeFailure} {
switch -- $code {
@@ -2265,130 +2068,146 @@ proc tcltest::test {name description args} {
1 { set msg "Test generated error" }
2 { set msg "Test generated return exception" }
3 { set msg "Test generated break exception" }
- 4 { set msg "Test generated continue exception" }
+ 4 { set msg "Test generated continue exception" }
default { set msg "Test generated exception" }
}
puts [outputChannel] "---- $msg; Return code was: $code"
- puts [outputChannel] "---- Return code should have been one of: $returnCodes"
- if {[tcltest::isVerbose error]} {
+ puts [outputChannel] "---- Return code should have been\
+ one of: $returnCodes"
+ if {[IsVerbose error]} {
if {[info exists ::errorInfo]} {
- puts [outputChannel] "---- errorInfo: $::errorInfo"
- puts [outputChannel] "---- errorCode: $::errorCode"
+ puts [outputChannel] "---- errorInfo:\
+ $::errorInfo"
+ puts [outputChannel] "---- errorCode:\
+ $::errorCode"
}
}
}
if {$outputFailure} {
- puts [outputChannel] "---- Output was:\n$tcltest::outData"
- puts [outputChannel] "---- Output should have been ($match matching):\n$output"
+ puts [outputChannel] "---- Output was:\n$outData"
+ puts [outputChannel] "---- Output should have been\
+ ($match matching):\n$output"
}
if {$errorFailure} {
- puts [outputChannel] "---- Error output was:\n$tcltest::errData"
- puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput"
+ puts [outputChannel] "---- Error output was:\n$errData"
+ puts [outputChannel] "---- Error output should have\
+ been ($match matching):\n$errorOutput"
}
if {$cleanupFailure} {
- puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
+ puts [outputChannel] "---- Test cleanup\
+ failed:\n$cleanupMsg"
}
if {$coreFailure} {
- puts [outputChannel] "---- Core file produced while running test! $coreMsg"
+ puts [outputChannel] "---- Core file produced while\
+ running test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
}
}
-
- incr tcltest::testLevel -1
+
+ incr testLevel -1
return 0
}
-# runTest --
+# RunTest --
#
-# This is the defnition of the version 1.0 test routine for tcltest. It is
-# provided here for backward compatibility. It is also used as the 'backbone'
-# of the test procedure, as in, this is where all the work really gets done.
-#
-# This procedure runs a test and prints an error message if the test fails.
-# If tcltest::verbose has been set, it also prints a message even if the
-# test succeeds. The test will be skipped if it doesn't match the
-# tcltest::match variable, if it matches an element in
-# tcltest::skip, or if one of the elements of "constraints" turns
-# out not to be true.
+# This is the defnition of the version 1.0 test routine for tcltest. It
+# is provided here for backward compatibility. It is also used as the
+# 'backbone' of the test procedure, as in, this is where all the work
+# really gets done. This procedure runs a test and prints an error
+# message if the test fails. If verbose has been set, it also prints a
+# message even if the test succeeds. The test will be skipped if it
+# doesn't match the match variable, if it matches an element in skip, or
+# if one of the elements of "constraints" turns out not to be true.
#
# Arguments:
# name - Name of test, in the form foo-1.2.
-# description - Short textual description of the test, to
-# help humans understand what it does.
-# constraints - A list of one or more keywords, each of
-# which must be the name of an element in
-# the array "tcltest::testConstraints". If any of these
-# elements is zero, the test is skipped.
-# This argument may be omitted.
+# description - Short textual description of the test, to help
+# humans understand what it does.
+# constraints - A list of one or more keywords, each of which
+# must be the name of an element in the array
+# "testConstraints". If any of these elements is
+# zero, the test is skipped. This argument may be
+# omitted.
# script - Script to run to carry out the test. It must
# return a result that can be checked for
# correctness.
# expectedAnswer - Expected result from script.
-#
-# Behavior depends on the value of testLevel; if testLevel is 1 (top level),
-# then events are logged and we track the number of tests run/skipped and why.
-# Otherwise, we don't track this information.
-#
+#
+# Behavior depends on the value of testLevel; if testLevel is 1 (top
+# level), then events are logged and we track the number of tests
+# run/skipped and why. Otherwise, we don't track this information.
+#
# Results:
# empty list if test is skipped; otherwise returns list containing
# actual returned value from the test and the return code.
-#
+#
# Side Effects:
# none.
#
-proc tcltest::runTest {name description script expectedAnswer constraints} {
+proc tcltest::RunTest {
+ name description script expectedAnswer constraints
+} {
+ variable testLevel
+ variable numTests
+ variable skip
+ variable match
+ variable limitConstraints
+ variable testConstraints
+ variable originalTclPlatform
+ variable coreModTime
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Total)
+ if {$testLevel == 1} {
+ incr numTests(Total)
}
-
+
# skip the test if it's name matches an element of skip
- foreach pattern $tcltest::skip {
+ foreach pattern $skip {
if {[string match $pattern $name]} {
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Skipped)
- DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip}
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
}
return
}
}
# skip the test if it's name doesn't match any element of match
- if {[llength $tcltest::match] > 0} {
+ if {[llength $match] > 0} {
set ok 0
- foreach pattern $tcltest::match {
+ foreach pattern $match {
if {[string match $pattern $name]} {
set ok 1
break
}
}
if {!$ok} {
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Skipped)
- DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch}
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
}
return
}
}
- DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints"
+ DebugPuts 3 "Running $name ($description) {$script}\
+ {$expectedAnswer} $constraints"
- if {$constraints == {}} {
- # If we're limited to the listed constraints and there aren't any
- # listed, then we shouldn't run the test.
- if {$tcltest::limitConstraints} {
- tcltest::AddToSkippedBecause userSpecifiedLimitConstraint
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Skipped)
+ if {[string equal {} $constraints]} {
+ # If we're limited to the listed constraints and there aren't
+ # any listed, then we shouldn't run the test.
+ if {$limitConstraints} {
+ AddToSkippedBecause userSpecifiedLimitConstraint
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
}
return
}
} else {
- # "constraints" argument exists;
+ # "constraints" argument exists;
# make sure that the constraints are satisfied.
set doTest 0
@@ -2396,20 +2215,20 @@ proc tcltest::runTest {name description script expectedAnswer constraints} {
# full expression, e.g. {$foo > [info tclversion]}
catch {set doTest [uplevel #0 expr $constraints]}
} elseif {[regexp {[^.a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
- # something like {a || b} should be turned into
- # $tcltest::testConstraints(a) || $tcltest::testConstraints(b).
- regsub -all {[.\w]+} $constraints \
- {$tcltest::testConstraints(&)} c
+ # something like {a || b} should be turned into
+ # $testConstraints(a) || $testConstraints(b).
+ regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
catch {set doTest [eval expr $c]}
} elseif {![catch {llength $constraints}]} {
# just simple constraints such as {unixOnly fonts}.
set doTest 1
foreach constraint $constraints {
- if {(![info exists tcltest::testConstraints($constraint)]) \
- || (!$tcltest::testConstraints($constraint))} {
+ if {(![info exists testConstraints($constraint)]) \
+ || (!$testConstraints($constraint))} {
set doTest 0
- # store the constraint that kept the test from running
+ # store the constraint that kept the test from
+ # running
set constraints $constraint
break
}
@@ -2417,46 +2236,46 @@ proc tcltest::runTest {name description script expectedAnswer constraints} {
}
if {$doTest == 0} {
- if {[tcltest::isVerbose skip]} {
+ if {[IsVerbose skip]} {
puts [outputChannel] "++++ $name SKIPPED: $constraints"
}
-
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Skipped)
- tcltest::AddToSkippedBecause $constraints
+
+ if {$testLevel == 1} {
+ incr numTests(Skipped)
+ AddToSkippedBecause $constraints
}
return
}
}
- # Save information about the core file. You need to restore the original
- # tcl_platform environment because some of the tests mess with
- # tcl_platform.
+ # Save information about the core file. You need to restore the
+ # original tcl_platform environment because some of the tests mess
+ # with tcl_platform.
- if {$tcltest::preserveCore} {
+ if {[preserveCore]} {
set currentTclPlatform [array get tcl_platform]
- array set tcl_platform $tcltest::originalTclPlatform
- if {[file exists [file join [tcltest::workingDirectory] core]]} {
- set coreModTime [file mtime [file join \
- [tcltest::workingDirectory] core]]
+ array set tcl_platform $originalTclPlatform
+ if {[file exists [file join [workingDirectory] core]]} {
+ set coreModTime \
+ [file mtime [file join [workingDirectory] core]]
}
array set tcl_platform $currentTclPlatform
}
# If there is no "memory" command (because memory debugging isn't
# enabled), then don't attempt to use the command.
-
- if {[info commands memory] != {}} {
+
+ if {[llength [info commands memory]] == 1} {
memory tag $name
}
- if {[tcltest::isVerbose start]} {
+ if {[IsVerbose start]} {
puts [outputChannel] "---- $name start"
flush [outputChannel]
}
-
- set code [catch {uplevel $script} actualAnswer]
-
+
+ set code [catch {uplevel 1 $script} actualAnswer]
+
return [list $actualAnswer $code]
}
@@ -2482,66 +2301,78 @@ if {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
#
# Print the number tests (total, passed, failed, and skipped) since the
# tests were invoked.
-#
+#
# Restore original environment (as reported by special variable env).
-#
+#
# Arguments:
-# calledFromAllFile - if 0, behave as if we are running a single test file
-# within an entire suite of tests. if we aren't running a single test
-# file, then don't report status. check for new files created during the
-# test run and report on them. if 1, report collated status from all the
-# test file runs.
-#
-# Results:
+# calledFromAllFile - if 0, behave as if we are running a single
+# test file within an entire suite of tests. if we aren't running
+# a single test file, then don't report status. check for new
+# files created during the test run and report on them. if 1,
+# report collated status from all the test file runs.
+#
+# Results:
# None.
-#
-# Side Effects:
+#
+# Side Effects:
# None
-#
+#
proc tcltest::cleanupTests {{calledFromAllFile 0}} {
+ variable filesMade
+ variable filesExisted
+ variable createdNewFiles
+ variable testSingleFile
+ variable numTests
+ variable numTestFiles
+ variable failFiles
+ variable skippedBecause
+ variable currentFailure
+ variable originalEnv
+ variable originalTclPlatform
+ variable coreModTime
set testFileName [file tail [info script]]
# Call the cleanup hook
- tcltest::cleanupTestsHook
+ cleanupTestsHook
- # Remove files and directories created by the :tcltest::makeFile and
- # tcltest::makeDirectory procedures.
- # Record the names of files in tcltest::workingDirectory that were not
- # pre-existing, and associate them with the test file that created them.
+ # Remove files and directories created by the makeFile and
+ # makeDirectory procedures. Record the names of files in
+ # workingDirectory that were not pre-existing, and associate them
+ # with the test file that created them.
if {!$calledFromAllFile} {
- foreach file $tcltest::filesMade {
+ foreach file $filesMade {
if {[file exists $file]} {
catch {file delete -force $file}
}
}
set currentFiles {}
foreach file [glob -nocomplain \
- [file join $tcltest::temporaryDirectory *]] {
+ -directory [temporaryDirectory] *] {
lappend currentFiles [file tail $file]
}
set newFiles {}
foreach file $currentFiles {
- if {[lsearch -exact $tcltest::filesExisted $file] == -1} {
+ if {[lsearch -exact $filesExisted $file] == -1} {
lappend newFiles $file
}
}
- set tcltest::filesExisted $currentFiles
+ set filesExisted $currentFiles
if {[llength $newFiles] > 0} {
- set tcltest::createdNewFiles($testFileName) $newFiles
+ set createdNewFiles($testFileName) $newFiles
}
}
- if {$calledFromAllFile || $tcltest::testSingleFile} {
+ if {$calledFromAllFile || $testSingleFile} {
# print stats
puts -nonewline [outputChannel] "$testFileName:"
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
puts -nonewline [outputChannel] \
- "\t$index\t$tcltest::numTests($index)"
+ "\t$index\t$numTests($index)"
}
puts [outputChannel] ""
@@ -2550,67 +2381,68 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
if {$calledFromAllFile} {
puts [outputChannel] \
- "Sourced $tcltest::numTestFiles Test Files."
- set tcltest::numTestFiles 0
- if {[llength $tcltest::failFiles] > 0} {
+ "Sourced $numTestFiles Test Files."
+ set numTestFiles 0
+ if {[llength $failFiles] > 0} {
puts [outputChannel] \
- "Files with failing tests: $tcltest::failFiles"
- set tcltest::failFiles {}
+ "Files with failing tests: $failFiles"
+ set failFiles {}
}
}
- # if any tests were skipped, print the constraints that kept them
- # from running.
+ # if any tests were skipped, print the constraints that kept
+ # them from running.
- set constraintList [array names tcltest::skippedBecause]
+ set constraintList [array names skippedBecause]
if {[llength $constraintList] > 0} {
puts [outputChannel] \
"Number of tests skipped for each constraint:"
foreach constraint [lsort $constraintList] {
puts [outputChannel] \
- "\t$tcltest::skippedBecause($constraint)\t$constraint"
- unset tcltest::skippedBecause($constraint)
+ "\t$skippedBecause($constraint)\t$constraint"
+ unset skippedBecause($constraint)
}
}
- # report the names of test files in tcltest::createdNewFiles, and
- # reset the array to be empty.
+ # report the names of test files in createdNewFiles, and reset
+ # the array to be empty.
- set testFilesThatTurded [lsort [array names tcltest::createdNewFiles]]
+ set testFilesThatTurded [lsort [array names createdNewFiles]]
if {[llength $testFilesThatTurded] > 0} {
puts [outputChannel] "Warning: files left behind:"
foreach testFile $testFilesThatTurded {
puts [outputChannel] \
- "\t$testFile:\t$tcltest::createdNewFiles($testFile)"
- unset tcltest::createdNewFiles($testFile)
+ "\t$testFile:\t$createdNewFiles($testFile)"
+ unset createdNewFiles($testFile)
}
}
# reset filesMade, filesExisted, and numTests
- set tcltest::filesMade {}
+ set filesMade {}
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
- set tcltest::numTests($index) 0
+ set numTests($index) 0
}
# exit only if running Tk in non-interactive mode
global tk_version tcl_interactive
- if {[info exists tk_version] && ![info exists tcl_interactive]} {
+ if {![catch {package present Tk}]
+ && ![info exists tcl_interactive]} {
exit
}
} else {
# if we're deferring stat-reporting until all files are sourced,
- # then add current file to failFile list if any tests in this file
- # failed
+ # then add current file to failFile list if any tests in this
+ # file failed
- incr tcltest::numTestFiles
- if {($tcltest::currentFailure) && \
- ([lsearch -exact $tcltest::failFiles $testFileName] == -1)} {
- lappend tcltest::failFiles $testFileName
+ incr numTestFiles
+ if {$currentFailure \
+ && ([lsearch -exact $failFiles $testFileName] == -1)} {
+ lappend failFiles $testFileName
}
- set tcltest::currentFailure false
+ set currentFailure false
# restore the environment to the state it was in before this package
# was loaded
@@ -2619,20 +2451,20 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
set changedEnv {}
set removedEnv {}
foreach index [array names ::env] {
- if {![info exists tcltest::originalEnv($index)]} {
+ if {![info exists originalEnv($index)]} {
lappend newEnv $index
unset ::env($index)
} else {
- if {$::env($index) != $tcltest::originalEnv($index)} {
+ if {$::env($index) != $originalEnv($index)} {
lappend changedEnv $index
- set ::env($index) $tcltest::originalEnv($index)
+ set ::env($index) $originalEnv($index)
}
}
}
- foreach index [array names tcltest::originalEnv] {
+ foreach index [array names originalEnv] {
if {![info exists ::env($index)]} {
lappend removedEnv $index
- set ::env($index) $tcltest::originalEnv($index)
+ set ::env($index) $originalEnv($index)
}
}
if {[llength $newEnv] > 0} {
@@ -2649,45 +2481,44 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
}
set changedTclPlatform {}
- foreach index [array names tcltest::originalTclPlatform] {
- if {$::tcl_platform($index) != \
- $tcltest::originalTclPlatform($index)} {
+ foreach index [array names originalTclPlatform] {
+ if {$::tcl_platform($index) \
+ != $originalTclPlatform($index)} {
lappend changedTclPlatform $index
- set ::tcl_platform($index) \
- $tcltest::originalTclPlatform($index)
+ set ::tcl_platform($index) $originalTclPlatform($index)
}
}
if {[llength $changedTclPlatform] > 0} {
- puts [outputChannel] \
- "tcl_platform array elements changed:\t$changedTclPlatform"
- }
+ puts [outputChannel] "tcl_platform array elements\
+ changed:\t$changedTclPlatform"
+ }
- if {[file exists [file join [tcltest::workingDirectory] core]]} {
- if {$tcltest::preserveCore > 1} {
- puts "rename core file (> 1)"
+ if {[file exists [file join [workingDirectory] core]]} {
+ if {[preserveCore] > 1} {
+ puts "rename core file (> 1)"
puts [outputChannel] "produced core file! \
Moving file to: \
- [file join $tcltest::temporaryDirectory core-$name]"
+ [file join [temporaryDirectory] core-$name]"
catch {file rename -force \
- [file join [tcltest::workingDirectory] core] \
- [file join $tcltest::temporaryDirectory \
- core-$name]} msg
+ [file join [workingDirectory] core] \
+ [file join [temporaryDirectory] core-$name]
+ } msg
if {[string length $msg] > 0} {
- tcltest::PrintError "Problem renaming file: $msg"
+ PrintError "Problem renaming file: $msg"
}
} else {
# Print a message if there is a core file and (1) there
- # previously wasn't one or (2) the new one is different from
- # the old one.
+ # previously wasn't one or (2) the new one is different
+ # from the old one.
- if {[info exists tcltest::coreModificationTime]} {
- if {$tcltest::coreModificationTime != [file mtime \
- [file join [tcltest::workingDirectory] core]]} {
+ if {[info exists coreModTime]} {
+ if {$coreModTime != [file mtime \
+ [file join [workingDirectory] core]]} {
puts [outputChannel] "A core file was created!"
}
} else {
puts [outputChannel] "A core file was created!"
- }
+ }
}
}
}
@@ -2700,45 +2531,48 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# Procs that determine which tests/test files to run
-# tcltest::getMatchingFiles
+# 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.
+# 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.
#
# Arguments:
# directory to search
#
# Results:
-# The constructed list is returned to the user. This will primarily
-# be used in 'all.tcl' files. It is used in runAllTests.
-#
+# The constructed list is returned to the user. This will
+# primarily be used in 'all.tcl' files. It is used in
+# runAllTests.
+#
# Side Effects:
# None
-proc tcltest::getMatchingFiles { {searchDirectory ""} } {
+proc tcltest::GetMatchingFiles { {searchDirectory ""} } {
if {[llength [info level 0]] == 1} {
- set searchDirectory [tcltest::testsDirectory]
+ set searchDirectory [testsDirectory]
}
set matchingFiles {}
- # Find the matching files in the list of directories and then remove the
- # ones that match the skip pattern. Passing a list to foreach is required
- # so that a patch like D:\Foo\Bar does not get munged into D:FooBar.
+ # Find the matching files in the list of directories and then remove
+ # the ones that match the skip pattern. Passing a list to foreach is
+ # required so that a patch like D:\Foo\Bar does not get munged into
+ # D:FooBar.
foreach directory [list $searchDirectory] {
set matchFileList {}
- foreach match $tcltest::matchFiles {
+ foreach match [matchFiles] {
set matchFileList [concat $matchFileList \
[glob -directory $directory -nocomplain -- $match]]
}
if {[string compare {} $tcltest::skipFiles]} {
set skipFileList {}
- foreach skip $tcltest::skipFiles {
+ foreach skip [skipFiles] {
set skipFileList [concat $skipFileList \
- [glob -directory $directory -nocomplain -- $skip]]
+ [glob -directory $directory \
+ -nocomplain -- $skip]]
}
foreach file $matchFileList {
- # Only include files that don't match the skip pattern and
- # aren't SCCS lock files.
+ # Only include files that don't match the skip pattern
+ # and aren't SCCS lock files.
if {([lsearch -exact $skipFileList $file] == -1) && \
(![string match l.*.test [file tail $file]])} {
lappend matchingFiles $file
@@ -2749,51 +2583,51 @@ proc tcltest::getMatchingFiles { {searchDirectory ""} } {
}
}
if {[string equal $matchingFiles {}]} {
- tcltest::PrintError "No test files remain after applying \
- your match and skip patterns!"
+ PrintError "No test files remain after applying your match and\
+ skip patterns!"
}
return $matchingFiles
}
-# tcltest::getMatchingDirectories --
+# tcltest::GetMatchingDirectories --
#
-# Looks at the patterns given to match and skip directories and uses them
-# to put together a list of the test directories that we should attempt
-# to run. (Only subdirectories containing an "all.tcl" file are put into
-# the list.)
+# Looks at the patterns given to match and skip directories and
+# uses them to put together a list of the test directories that we
+# should attempt to run. (Only subdirectories containing an
+# "all.tcl" file are put into the list.)
#
# Arguments:
# root directory from which to search
#
# Results:
-# The constructed list is returned to the user. This is used in the
-# primary all.tcl file. Lower-level all.tcl files should use the
-# tcltest::testAllFiles proc instead.
-#
-# Side Effects:
+# The constructed list is returned to the user. This is used in
+# the primary all.tcl file.
+#
+# Side Effects:
# None.
-proc tcltest::getMatchingDirectories {rootdir} {
+proc tcltest::GetMatchingDirectories {rootdir} {
set matchingDirs {}
set matchDirList {}
- # Find the matching directories in tcltest::testsDirectory and then
- # remove the ones that match the skip pattern
- foreach match $tcltest::matchDirectories {
+ # Find the matching directories in testsDirectory and then remove
+ # the ones that match the skip pattern
+ foreach match [matchDirectories] {
foreach file [glob -directory $rootdir -nocomplain -- $match] {
- if {([file isdirectory $file]) && ($file != $rootdir)} {
+ if {[file isdirectory $file]
+ && [string compare $file $rootdir]} {
set matchDirList [concat $matchDirList \
- [tcltest::getMatchingDirectories $file]]
+ [GetMatchingDirectories $file]]
if {[file exists [file join $file all.tcl]]} {
- set matchDirList [concat $matchDirList $file]
+ lappend matchDirList $file
}
}
}
}
- if {$tcltest::skipDirectories != {}} {
- set skipDirs {}
- foreach skip $tcltest::skipDirectories {
+ if {[llength [skipDirectories]]} {
+ set skipDirs {}
+ foreach skip [skipDirectories] {
set skipDirs [concat $skipDirs \
- [glob -nocomplain -directory $tcltest::testsDirectory $skip]]
+ [glob -nocomplain -directory [testsDirectory] $skip]]
}
foreach dir $matchDirList {
# Only include directories that don't match the skip pattern
@@ -2802,19 +2636,20 @@ proc tcltest::getMatchingDirectories {rootdir} {
}
}
} else {
- set matchingDirs [concat $matchingDirs $matchDirList]
+ set matchingDirs $matchDirList
}
- if {$matchingDirs == {}} {
- DebugPuts 1 "No test directories remain after applying match and skip patterns!"
+ if {[llength $matchingDirs] == 0} {
+ DebugPuts 1 "No test directories remain after applying match\
+ and skip patterns!"
}
return $matchingDirs
}
# tcltest::runAllTests --
#
-# prints output and sources test files according to the match and skip
-# patterns provided. after sourcing test files, it goes on to source
-# all.tcl files in matching test subdirectories.
+# prints output and sources test files according to the match and
+# skip patterns provided. after sourcing test files, it goes on
+# to source all.tcl files in matching test subdirectories.
#
# Arguments:
# shell being tested
@@ -2827,74 +2662,94 @@ proc tcltest::getMatchingDirectories {rootdir} {
proc tcltest::runAllTests { {shell ""} } {
global argv
+ variable testSingleFile
+ variable numTestFiles
+ variable numTests
+ variable failFiles
if {[llength [info level 0]] == 1} {
- set shell [tcltest::interpreter]
+ set shell [interpreter]
}
- set tcltest::testSingleFile false
+ set testSingleFile false
puts [outputChannel] "Tests running in interp: $shell"
- puts [outputChannel] "Tests located in: $tcltest::testsDirectory"
- puts [outputChannel] "Tests running in: [tcltest::workingDirectory]"
- puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory"
-
- if {[package vcompare [package provide Tcl] 8.4] >= 0} {
+ puts [outputChannel] "Tests located in: [testsDirectory]"
+ puts [outputChannel] "Tests running in: [workingDirectory]"
+ puts [outputChannel] "Temporary files stored in\
+ [temporaryDirectory]"
+
+ # [file system] first available in Tcl 8.4
+ if {![catch {file system [testsDirectory]} result]
+ && ![string equal native [lindex $result 0]]} {
# If we aren't running in the native filesystem, then we must
# run the tests in a single process (via 'source'), because
# trying to run then via a pipe will fail since the files don't
# really exist.
- if {[lindex [file system [tcltest::testsDirectory]] 0] != "native"} {
- tcltest::singleProcess 1
- }
+ singleProcess 1
}
- if {[tcltest::singleProcess]} {
- puts [outputChannel] "Test files sourced into current interpreter"
+ if {[singleProcess]} {
+ puts [outputChannel] \
+ "Test files sourced into current interpreter"
} else {
- puts [outputChannel] "Test files run in separate interpreters"
+ puts [outputChannel] \
+ "Test files run in separate interpreters"
}
- if {[llength $tcltest::skip] > 0} {
- puts [outputChannel] "Skipping tests that match: $tcltest::skip"
+ if {[llength [skip]] > 0} {
+ puts [outputChannel] "Skipping tests that match: [skip]"
}
- if {[llength $tcltest::match] > 0} {
- puts [outputChannel] "Only running tests that match: $tcltest::match"
+ if {[llength [match]] > 0} {
+ puts [outputChannel] "Only running tests that match: [match]"
}
- if {[llength $tcltest::skipFiles] > 0} {
- puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles"
+ if {[llength [skipFiles]] > 0} {
+ puts [outputChannel] \
+ "Skipping test files that match: [skipFiles]"
}
- if {[llength $tcltest::matchFiles] > 0} {
- puts [outputChannel] "Only running test files that match: $tcltest::matchFiles"
+ if {[llength [matchFiles]] > 0} {
+ puts [outputChannel] \
+ "Only running test files that match: [matchFiles]"
}
set timeCmd {clock format [clock seconds]}
puts [outputChannel] "Tests began at [eval $timeCmd]"
# Run each of the specified tests
- foreach file [lsort [tcltest::getMatchingFiles]] {
+ foreach file [lsort [GetMatchingFiles]] {
set tail [file tail $file]
puts [outputChannel] $tail
- if {$tcltest::singleProcess} {
- incr tcltest::numTestFiles
- uplevel [list source $file]
+ if {[singleProcess]} {
+ incr numTestFiles
+ uplevel 1 [list ::source $file]
} else {
- set cmd [concat [list | $shell $file] [split $argv]]
+ set cmd [linsert $argv 0 | $shell $file]
if {[catch {
- incr tcltest::numTestFiles
- set pipeFd [open $cmd "r"]
+ incr numTestFiles
+ set pipeFd [open $cmd "r"]
while {[gets $pipeFd line] >= 0} {
- if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} {
- foreach index [list "Total" "Passed" "Skipped" "Failed"] {
- incr tcltest::numTests($index) [set $index]
+ if {[regexp [join {
+ {^([^:]+):\t}
+ {Total\t([0-9]+)\t}
+ {Passed\t([0-9]+)\t}
+ {Skipped\t([0-9]+)\t}
+ {Failed\t([0-9]+)}
+ } ""] $line null testFile \
+ Total Passed Skipped Failed]} {
+ foreach index {Total Passed Skipped Failed} {
+ incr numTests($index) [set $index]
}
if {$Failed > 0} {
- lappend tcltest::failFiles $testFile
+ lappend failFiles $testFile
}
- } elseif {[regexp {^Number of tests skipped for each constraint:|^\t(\d+)\t(.+)$} $line match skipped constraint]} {
- if {$match != "Number of tests skipped for each constraint:"} {
- tcltest::AddToSkippedBecause $constraint $skipped
+ } elseif {[regexp [join {
+ {^Number of tests skipped }
+ {for each constraint:}
+ {|^\t(\d+)\t(.+)$}
+ } ""] $line match skipped constraint]} {
+ if {[string match \t* $match]} {
+ AddToSkippedBecause $constraint $skipped
}
} else {
puts [outputChannel] $line
@@ -2902,17 +2757,17 @@ proc tcltest::runAllTests { {shell ""} } {
}
close $pipeFd
} msg]} {
- # Print results to tcltest::outputChannel.
puts [outputChannel] "Test file error: $msg"
- # append the name of the test to a list to be reported later
- lappend testFileFailures $file
+ # append the name of the test to a list to be reported
+ # later
+ lappend testFileFailures $file
}
}
}
# cleanup
puts [outputChannel] "\nTests ended at [eval $timeCmd]"
- tcltest::cleanupTests 1
+ cleanupTests 1
if {[info exists testFileFailures]} {
puts [outputChannel] "\nTest files exiting with errors: \n"
foreach file $testFileFailures {
@@ -2921,23 +2776,25 @@ proc tcltest::runAllTests { {shell ""} } {
}
# Checking for subdirectories in which to run tests
- foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] {
+ foreach directory [GetMatchingDirectories [testsDirectory]] {
set dir [file tail $directory]
- puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
+ puts [outputChannel] [string repeat ~ 44]
puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
- uplevel "source [file join $directory all.tcl]"
+ uplevel 1 "::source [file join $directory all.tcl]"
set endTime [eval $timeCmd]
puts [outputChannel] "\n$dir test ended at $endTime"
- puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
+ puts [outputChannel] ""
+ puts [outputChannel] [string repeat ~ 44]
}
return
}
#####################################################################
-# Test utility procs - not used in tcltest, but may be useful for testing.
+# Test utility procs - not used in tcltest, but may be useful for
+# testing.
# tcltest::loadTestedCommands --
#
@@ -2950,16 +2807,17 @@ proc tcltest::runAllTests { {shell ""} } {
#
# Results
# none
-#
-# Side Effects:
+#
+# Side Effects:
# none.
proc tcltest::loadTestedCommands {} {
- if {$tcltest::loadScript == {}} {
+ variable l
+ if {[string equal {} [loadScript]]} {
return
}
-
- return [uplevel $tcltest::loadScript]
+
+ return [uplevel 1 [loadScript]]
}
# tcltest::saveState --
@@ -2970,45 +2828,50 @@ proc tcltest::loadTestedCommands {} {
# none
#
# Results:
-# Modifies the variable tcltest::saveState
+# Modifies the variable saveState
#
# Side effects:
# None.
proc tcltest::saveState {} {
- uplevel {set tcltest::saveState [list [info procs] [info vars]]}
- DebugPuts 2 "tcltest::saveState: $tcltest::saveState"
+ variable saveState
+ uplevel 1 [list ::set [namespace which -variable saveState]] \
+ {[::list [::info procs] [::info vars]]}
+ DebugPuts 2 "[lindex [info level 0] 0]: $saveState"
return
}
# tcltest::restoreState --
#
# Remove procs and variables that didn't exist before the call to
-# tcltest::saveState.
+# [saveState].
#
# Arguments:
# none
#
# Results:
-# Removes procs and variables from your environment if they don't exist
-# in the tcltest::saveState variable.
+# Removes procs and variables from your environment if they don't
+# exist in the saveState variable.
#
# Side effects:
# None.
proc tcltest::restoreState {} {
- foreach p [info procs] {
- if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \
- (![string match "*tcltest::$p" [namespace origin $p]])} {
-
- DebugPuts 2 "tcltest::restoreState: Removing proc $p"
- rename $p {}
+ variable saveState
+ foreach p [uplevel 1 {::info procs}] {
+ if {([lsearch [lindex $saveState 0] $p] < 0)
+ && ![string equal [namespace current]::$p \
+ [uplevel 1 [list ::namespace origin $p]]]} {
+
+ DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
+ uplevel 1 [list ::catch [list ::rename $p {}]]
}
}
- foreach p [uplevel {info vars}] {
- if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} {
- DebugPuts 2 "tcltest::restoreState: Removing variable $p"
- uplevel "catch {unset $p}"
+ foreach p [uplevel 1 {::info vars}] {
+ if {[lsearch [lindex $saveState 1] $p] < 0} {
+ DebugPuts 2 "[lindex [info level 0] 0]:\
+ Removing variable $p"
+ uplevel 1 [list ::catch [list ::unset $p]]
}
}
return
@@ -3039,13 +2902,13 @@ proc tcltest::normalizeMsg {msg} {
# Create a new file with the name <name>, and write <contents> to it.
#
# If this file hasn't been created via makeFile since the last time
-# cleanupTests was called, add it to the $filesMade list, so it will
-# be removed by the next call to cleanupTests.
+# cleanupTests was called, add it to the $filesMade list, so it will be
+# removed by the next call to cleanupTests.
#
# Arguments:
# contents content of the new file
# name name of the new file
-# directory directory name for new file
+# directory directory name for new file
#
# Results:
# absolute path to the file created
@@ -3055,14 +2918,16 @@ proc tcltest::normalizeMsg {msg} {
proc tcltest::makeFile {contents name {directory ""}} {
global tcl_platform
+ variable filesMade
if {[llength [info level 0]] == 3} {
- set directory [tcltest::temporaryDirectory]
+ set directory [temporaryDirectory]
}
-
+
set fullName [file join $directory $name]
- DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName"
+ DebugPuts 3 "[lindex [info level 0] 0]:\
+ putting $contents into $fullName"
set fd [open $fullName w]
@@ -3075,8 +2940,8 @@ proc tcltest::makeFile {contents name {directory ""}} {
}
close $fd
- if {[lsearch -exact $tcltest::filesMade $fullName] == -1} {
- lappend tcltest::filesMade $fullName
+ if {[lsearch -exact $filesMade $fullName] == -1} {
+ lappend filesMade $fullName
}
return $fullName
}
@@ -3097,10 +2962,10 @@ proc tcltest::makeFile {contents name {directory ""}} {
proc tcltest::removeFile {name {directory ""}} {
if {[llength [info level 0]] == 2} {
- set directory [tcltest::temporaryDirectory]
+ set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
- DebugPuts 3 "tcltest::removeFile: removing $fullName"
+ DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
return [file delete $fullName]
}
@@ -3109,8 +2974,8 @@ proc tcltest::removeFile {name {directory ""}} {
# Create a new dir with the name <name>.
#
# If this dir hasn't been created via makeDirectory since the last time
-# cleanupTests was called, add it to the $directoriesMade list, so it will
-# be removed by the next call to cleanupTests.
+# cleanupTests was called, add it to the $directoriesMade list, so it
+# will be removed by the next call to cleanupTests.
#
# Arguments:
# name name of the new directory
@@ -3123,14 +2988,15 @@ proc tcltest::removeFile {name {directory ""}} {
# None.
proc tcltest::makeDirectory {name {directory ""}} {
+ variable filesMade
if {[llength [info level 0]] == 2} {
- set directory [tcltest::temporaryDirectory]
+ set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
- DebugPuts 3 "tcltest::makeDirectory: creating $fullName"
+ DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
file mkdir $fullName
- if {[lsearch -exact $tcltest::filesMade $fullName] == -1} {
- lappend tcltest::filesMade $fullName
+ if {[lsearch -exact $filesMade $fullName] == -1} {
+ lappend filesMade $fullName
}
return $fullName
}
@@ -3151,10 +3017,10 @@ proc tcltest::makeDirectory {name {directory ""}} {
proc tcltest::removeDirectory {name {directory ""}} {
if {[llength [info level 0]] == 2} {
- set directory [tcltest::temporaryDirectory]
+ set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
- DebugPuts 3 "tcltest::removeDirectory: deleting $fullName"
+ DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
return [file delete -force $fullName]
}
@@ -3175,11 +3041,11 @@ proc tcltest::removeDirectory {name {directory ""}} {
proc tcltest::viewFile {name {directory ""}} {
global tcl_platform
if {[llength [info level 0]] == 2} {
- set directory [tcltest::temporaryDirectory]
+ set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
- if {([string equal $tcl_platform(platform) "macintosh"]) || \
- ([tcltest::testConstraint unixExecs] == 0)} {
+ if {[string equal $tcl_platform(platform) macintosh]
+ || ![testConstraint unixExecs]} {
set f [open $fullName]
set data [read -nonewline $f]
close $f
@@ -3193,13 +3059,14 @@ proc tcltest::viewFile {name {directory ""}} {
# tcltest::bytestring --
#
# Construct a string that consists of the requested sequence of bytes,
-# as opposed to a string of properly formed UTF-8 characters.
-# This allows the tester to
-# 1. Create denormalized or improperly formed strings to pass to C procedures
-# that are supposed to accept strings with embedded NULL bytes.
-# 2. Confirm that a string result has a certain pattern of bytes, for instance
-# to confirm that "\xe0\0" in a Tcl script is stored internally in
-# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
+# as opposed to a string of properly formed UTF-8 characters.
+# This allows the tester to
+# 1. Create denormalized or improperly formed strings to pass to C
+# procedures that are supposed to accept strings with embedded NULL
+# bytes.
+# 2. Confirm that a string result has a certain pattern of bytes, for
+# instance to confirm that "\xe0\0" in a Tcl script is stored
+# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
#
# Generally, it's a bad idea to examine the bytes in a Tcl string or to
# construct improperly formed strings in this manner, because it involves
@@ -3218,7 +3085,7 @@ proc tcltest::bytestring {string} {
return [encoding convertfrom identity $string]
}
-# tcltest::openfiles --
+# tcltest::OpenFiles --
#
# used in io tests, uses testchannel
#
@@ -3231,14 +3098,14 @@ proc tcltest::bytestring {string} {
# Side effects:
# None.
-proc tcltest::openfiles {} {
+proc tcltest::OpenFiles {} {
if {[catch {testchannel open} result]} {
return {}
}
return $result
}
-# tcltest::leakfiles --
+# tcltest::LeakFiles --
#
# used in io tests, uses testchannel
#
@@ -3251,7 +3118,7 @@ proc tcltest::openfiles {} {
# Side effects:
# None.
-proc tcltest::leakfiles {old} {
+proc tcltest::LeakFiles {old} {
if {[catch {testchannel open} new]} {
return {}
}
@@ -3268,7 +3135,7 @@ proc tcltest::leakfiles {old} {
# Internationalization / ISO support procs -- dl
#
-# tcltest::set_iso8859_1_locale --
+# tcltest::SetIso8859_1_Locale --
#
# used in cmdIL.test, uses testlocale
#
@@ -3281,16 +3148,17 @@ proc tcltest::leakfiles {old} {
# Side effects:
# None.
-proc tcltest::set_iso8859_1_locale {} {
+proc tcltest::SetIso8859_1_Locale {} {
variable previousLocale
+ variable isoLocale
if {[info commands testlocale] != ""} {
set previousLocale [testlocale ctype]
- testlocale ctype $tcltest::isoLocale
+ testlocale ctype $isoLocale
}
return
}
-# tcltest::restore_locale --
+# tcltest::RestoreLocale --
#
# used in cmdIL.test, uses testlocale
#
@@ -3303,7 +3171,7 @@ proc tcltest::set_iso8859_1_locale {} {
# Side effects:
# None.
-proc tcltest::restore_locale {} {
+proc tcltest::RestoreLocale {} {
variable previousLocale
if {[info commands testlocale] != ""} {
testlocale ctype $previousLocale
@@ -3321,8 +3189,8 @@ proc tcltest::restore_locale {} {
#
# Results:
# Returns the number of existing threads.
-#
-# Side Effects:
+#
+# Side Effects:
# none.
#
@@ -3334,8 +3202,10 @@ proc tcltest::threadReap {} {
testthread errorproc ThreadNullError
while {[llength [testthread names]] > 1} {
foreach tid [testthread names] {
- if {$tid != $tcltest::mainThread} {
- catch {testthread send -async $tid {testthread exit}}
+ if {$tid != [mainThread]} {
+ catch {
+ testthread send -async $tid {testthread exit}
+ }
}
}
## Enter a bit a sleep to give the threads enough breathing
@@ -3352,7 +3222,7 @@ proc tcltest::threadReap {} {
thread::errorproc ThreadNullError
while {[llength [thread::names]] > 1} {
foreach tid [thread::names] {
- if {$tid != $tcltest::mainThread} {
+ if {$tid != [mainThread]} {
catch {thread::send -async $tid {thread::exit}}
}
}
@@ -3369,15 +3239,15 @@ proc tcltest::threadReap {} {
return 0
}
-# Initialize the constraints and set up command line arguments
+# Initialize the constraints and set up command line arguments
namespace eval tcltest {
- initConstraints
- processCmdLineArgs
+ InitConstraints
+ ProcessCmdLineArgs
# Save the names of files that already exist in
# the output directory.
variable file {}
- foreach file [glob -nocomplain -directory $temporaryDirectory *] {
+ foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
lappend filesExisted [file tail $file]
}
unset file