summaryrefslogtreecommitdiffstats
path: root/library/tcltest/tcltest.tcl
diff options
context:
space:
mode:
authorjenn <jenn>2000-10-24 22:30:17 (GMT)
committerjenn <jenn>2000-10-24 22:30:17 (GMT)
commit5cbefa50780d8b1b97ad53388a8d92029eb63aff (patch)
tree4911eced7fe962bad5dd1651791fa2b3762b29d9 /library/tcltest/tcltest.tcl
parent517724aedd37225321f8241834d1a907ec201bbd (diff)
downloadtcl-5cbefa50780d8b1b97ad53388a8d92029eb63aff.zip
tcl-5cbefa50780d8b1b97ad53388a8d92029eb63aff.tar.gz
tcl-5cbefa50780d8b1b97ad53388a8d92029eb63aff.tar.bz2
* tests/all.tcl: Removed support for tcltest 1.0.
* tests/tcltest.test: * library/tcltest1.0/tcltest.tcl: * library/tcltest1.0/pkgIndex.tcl: * docs/tcltest.n: Moved tcltest2 code so that it's the standard version of tcltest. Removed all tcltest2 files (tests/tcltest2.test, library/tcltest1.0/tcltest2.tcl, docs/tcltest2.n).
Diffstat (limited to 'library/tcltest/tcltest.tcl')
-rw-r--r--library/tcltest/tcltest.tcl3227
1 files changed, 2406 insertions, 821 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 63639e3..80f80c7 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -1,7 +1,7 @@
# tcltest.tcl --
#
# This file contains support code for the Tcl test suite. It
-# defines the ::tcltest namespace and finds and defines the output
+# 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.
#
@@ -10,11 +10,10 @@
#
# 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.27 2000/09/06 18:50:15 hobbs Exp $
-
-package provide tcltest 1.0
+# RCS: @(#) $Id: tcltest.tcl,v 1.28 2000/10/24 22:30:32 jenn Exp $
# create the "tcltest" namespace for all testing variables and procedures
@@ -23,19 +22,25 @@ namespace eval tcltest {
# Export the public tcltest procs
set procList [list test cleanupTests saveState restoreState \
normalizeMsg makeFile removeFile makeDirectory removeDirectory \
- viewFile bytestring safeFetch threadReap getMatchingFiles \
- loadTestedCommands normalizePath]
+ viewFile bytestring threadReap debug testConstraint \
+ limitConstraints loadTestedCommands normalizePath verbose match \
+ skip matchFiles skipFiles preserveCore loadScript loadFile \
+ mainThread workingDirectory singleProcess interpreter runAllTests \
+ outputChannel outputFile errorChannel \
+ errorFile temporaryDirectory testsDirectory matchDirectories \
+ skipDirectories ]
foreach proc $procList {
namespace export $proc
}
- # ::tcltest::verbose defaults to "b"
+ # tcltest::verbose defaults to {body}
if {![info exists verbose]} {
- variable verbose "b"
+ variable verbose {body}
}
# Match and skip patterns default to the empty list, except for
- # matchFiles, which defaults to all .test files in the testsDirectory
+ # matchFiles, which defaults to all .test files in the testsDirectory and
+ # matchDirectories, which defaults to all directories.
if {![info exists match]} {
variable match {}
@@ -49,6 +54,12 @@ namespace eval tcltest {
if {![info exists skipFiles]} {
variable skipFiles {}
}
+ if {![info exists matchDirectories]} {
+ variable matchDirectories {*}
+ }
+ if {![info exists skipDirectories]} {
+ variable skipDirectories {}
+ }
# By default, don't save core files
if {![info exists preserveCore]} {
@@ -59,11 +70,17 @@ namespace eval tcltest {
if {![info exists outputChannel]} {
variable outputChannel stdout
}
+ if {![info exists outputFile]} {
+ variable outputFile stdout
+ }
# errors go to stderr by default
if {![info exists errorChannel]} {
variable errorChannel stderr
}
+ if {![info exists errorFile]} {
+ variable 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
@@ -81,9 +98,9 @@ namespace eval tcltest {
variable parameters {}
}
- # Count the number of files tested (0 if all.tcl wasn't called).
- # The all.tcl file will set testSingleFile to false, so stats will
- # not be printed until all.tcl calls the cleanupTests proc.
+ # Count the number of files tested (0 if runAllTests wasn't called).
+ # runAllTests will set testSingleFile to false, so stats will
+ # not be printed until runAllTests calls the cleanupTests proc.
# The currentFailure var stores the boolean value of whether the
# current test file has had any failures. The failFiles list
# stores the names of test files that had failures.
@@ -103,9 +120,9 @@ 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.
+ # 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.
if {![info exists filesMade]} {
variable filesMade {}
@@ -114,43 +131,47 @@ namespace eval tcltest {
variable filesExisted {}
}
- # ::tcltest::numTests will store test files as indices and the list
+ # tcltest::numTests will store test files as indices and the list
# of files (that should not have been) left behind by the test files.
if {![info exists createdNewFiles]} {
variable createdNewFiles
- array set ::tcltest::createdNewFiles {}
+ array set tcltest::createdNewFiles {}
}
- # initialize ::tcltest::numTests array to keep track fo the number of
+ # initialize tcltest::numTests array to keep track fo the number of
# tests that pass, fail, and are skipped.
if {![info exists numTests]} {
variable numTests
- array set ::tcltest::numTests \
+ array set tcltest::numTests \
[list Total 0 Passed 0 Skipped 0 Failed 0]
}
- # initialize ::tcltest::skippedBecause array to keep track of
+ # 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
+ # both of these constraints are counted only if tcltest::debug is set to
# true.
if {![info exists skippedBecause]} {
variable skippedBecause
- array set ::tcltest::skippedBecause {}
+ array set tcltest::skippedBecause {}
}
- # initialize the ::tcltest::testConstraints array to keep track of valid
+ # initialize the tcltest::testConstraints array to keep track of valid
# predefined constraints (see the explanation for the
- # ::tcltest::initConstraints proc for more details).
+ # tcltest::initConstraints proc for more details).
if {![info exists testConstraints]} {
variable testConstraints
- array set ::tcltest::testConstraints {}
+ array set tcltest::testConstraints {}
+ }
+
+ if {![info exists constraintsSpecified]} {
+ variable constraintsSpecified {}
}
# Don't run only the constrained tests by default
@@ -166,6 +187,11 @@ namespace eval tcltest {
variable loadScript {}
}
+ # and the filename of the script file, if it exists
+ if {![info exists loadFile]} {
+ variable loadFile {}
+ }
+
# tests that use threads need to know which is the main thread
if {![info exists mainThread]} {
@@ -181,10 +207,10 @@ namespace eval tcltest {
if {![info exists originalEnv]} {
variable originalEnv
- array set ::tcltest::originalEnv [array get ::env]
+ array set tcltest::originalEnv [array get ::env]
}
- # Set ::tcltest::workingDirectory to [pwd]. The default output directory
+ # Set tcltest::workingDirectory to [pwd]. The default output directory
# for Tcl tests is the working directory.
if {![info exists workingDirectory]} {
@@ -196,7 +222,7 @@ namespace eval tcltest {
# Tests should not rely on the current working directory.
# Files that are part of the test suite should be accessed relative to
- # ::tcltest::testsDirectory.
+ # tcltest::testsDirectory.
if {![info exists testsDirectory]} {
set oldpwd [pwd]
@@ -206,30 +232,40 @@ namespace eval tcltest {
unset oldpwd
}
- # the variables and procs that existed when ::tcltest::saveState was
+ # Default is to run each test file in a separate process
+ if {![info exists singleProcess]} {
+ variable singleProcess 0
+ }
+
+ # the variables and procs that existed when tcltest::saveState was
# called are stored in a variable of the same name
if {![info exists saveState]} {
variable saveState {}
}
- # Internationalization support
+ # Internationalization support -- used in tcltest::set_iso8859_1_locale
+ # and tcltest::restore_locale. Those commands are used in cmdIL.test.
+ if {![info exists previousLocale]} {
+ variable previousLocale
+ }
+
if {![info exists isoLocale]} {
variable isoLocale fr
- switch $tcl_platform(platform) {
+ switch -- $tcl_platform(platform) {
"unix" {
# Try some 'known' values for some platforms:
switch -exact -- $tcl_platform(os) {
"FreeBSD" {
- set ::tcltest::isoLocale fr_FR.ISO_8859-1
+ set tcltest::isoLocale fr_FR.ISO_8859-1
}
HP-UX {
- set ::tcltest::isoLocale fr_FR.iso88591
+ set tcltest::isoLocale fr_FR.iso88591
}
Linux -
IRIX {
- set ::tcltest::isoLocale fr
+ set tcltest::isoLocale fr
}
default {
@@ -237,12 +273,12 @@ namespace eval tcltest {
# define it to something else on your system
#if you want to test those.
- set ::tcltest::isoLocale iso_8859_1
+ set tcltest::isoLocale iso_8859_1
}
}
}
"windows" {
- set ::tcltest::isoLocale French
+ set tcltest::isoLocale French
}
}
}
@@ -250,7 +286,7 @@ namespace eval tcltest {
# Set the location of the execuatble
if {![info exists tcltest]} {
variable tcltest [info nameofexecutable]
- }
+ }
# save the platform information so it can be restored later
if {![info exists originalTclPlatform]} {
@@ -259,29 +295,34 @@ namespace eval tcltest {
# If a core file exists, save its modification time.
if {![info exists coreModificationTime]} {
- if {[file exists [file join $::tcltest::workingDirectory core]]} {
+ if {[file exists [file join $tcltest::workingDirectory core]]} {
variable coreModificationTime [file mtime [file join \
- $::tcltest::workingDirectory core]]
+ $tcltest::workingDirectory core]]
}
}
- # Tcl version numbers
- if {![info exists version]} {
- variable version 8.4
+ # stdout and stderr buffers for use when we want to store them
+ if {![info exists outData]} {
+ variable outData {}
}
- if {![info exists patchLevel]} {
- variable patchLevel 8.4a2
+ if {![info exists errData]} {
+ variable errData {}
}
+
+ # keep track of test level for nested test commands
+ variable testLevel 0
}
-# ::tcltest::Debug* --
+#####################################################################
+
+# tcltest::Debug* --
#
# Internal helper procedures to write out debug information
# dependent on the chosen level. A test shell may overide
# them, f.e. to redirect the output into a different
# channel, or even into a GUI.
-# ::tcltest::DebugPuts --
+# tcltest::DebugPuts --
#
# Prints the specified string if the current debug level is
# higher than the provided level argument.
@@ -293,15 +334,19 @@ namespace eval tcltest {
# Results:
# Prints the string. Nothing else is allowed.
#
+# Side Effects:
+# None.
+#
-proc ::tcltest::DebugPuts {level string} {
+proc tcltest::DebugPuts {level string} {
variable debug
if {$debug >= $level} {
puts $string
}
+ return
}
-# ::tcltest::DebugPArray --
+# tcltest::DebugPArray --
#
# Prints the contents of the specified array if the current
# debug level is higher than the provided level argument
@@ -313,17 +358,21 @@ proc ::tcltest::DebugPuts {level string} {
# Results:
# Prints the contents of the array. Nothing else is allowed.
#
+# Side Effects:
+# None.
+#
-proc ::tcltest::DebugPArray {level arrayvar} {
+proc tcltest::DebugPArray {level arrayvar} {
variable debug
if {$debug >= $level} {
catch {upvar $arrayvar $arrayvar}
parray $arrayvar
}
+ return
}
-# ::tcltest::DebugDo --
+# tcltest::DebugDo --
#
# Executes the script if the current debug level is greater than
# the provided level argument
@@ -335,16 +384,779 @@ proc ::tcltest::DebugPArray {level arrayvar} {
# Results:
# Arbitrary side effects, dependent on the executed script.
#
+# Side Effects:
+# None.
+#
-proc ::tcltest::DebugDo {level script} {
+proc tcltest::DebugDo {level script} {
variable debug
if {$debug >= $level} {
uplevel $script
}
+ return
+}
+
+#####################################################################
+
+# tcltest::CheckDirectory --
+#
+# This procedure checks whether the specified path is a readable
+# and/or writable directory. If one of the conditions is not
+# satisfied an error is printed and the application aborted. The
+# procedure assumes that the caller already checked the existence
+# of the path.
+#
+# Arguments
+# rw Information what attributes to check. Allowed values:
+# r, w, rw, wr. If 'r' is part of the value the directory
+# must be readable. 'w' associates to 'writable'.
+# dir The directory to check.
+# errMsg The string to prepend to the actual error message before
+# printing it.
+#
+# Results
+# none
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::CheckDirectory {rw dir errMsg} {
+ # Allowed values for 'rw': r, w, rw, wr
+
+ if {![file isdir $dir]} {
+ set msg "$errMsg \"$dir\" is not a directory"
+ error $msg
+ } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
+ set msg "$errMsg \"$dir\" is not writeable"
+ error $msg
+ } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
+ set msg "$errMsg \"$dir\" is not readable"
+ error $msg
+ }
+ 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.
+#
+# Arguments
+# pathVar contains the name of the variable containing the path to modify.
+# prefix is optional, contains the path to use to make the other an
+# absolute one. The current working directory is used if it was
+# not specified.
+#
+# Results
+# The path is modified in place.
+#
+# Side Effects:
+# None.
+#
+
+proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
+ upvar $pathVar path
+
+ if {![string equal [file pathtype $path] "absolute"]} {
+ if {$prefix == {}} {
+ set prefix [pwd]
+ }
+
+ set path [file join $prefix $path]
+ }
+ return $path
+}
+
+#####################################################################
+
+# tcltest::<variableName>
+#
+# Accessor functions for tcltest variables that can be modified externally.
+# These are vars that could otherwise be modified using command line
+# arguments to tcltest.
+
+# 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.
+#
+# Arguments:
+# A string containing any combination of 'pbste' or a list of keywords
+# (listed in parens)
+# p = print output whenever a test passes (pass)
+# b = print the body of the test when it fails (body)
+# s = print when a test is skipped (skip)
+# t = print when a test starts (start)
+# e = print errorInfo and errorCode when a test encounters an error
+# (error)
+#
+# Results:
+# content of tcltest::verbose - this is always the character combination
+# (pbste) instead of the list form.
+#
+# Side effects:
+# None.
+
+proc tcltest::verbose { {level ""} } {
+ if {[llength [info level 0]] == 1} {
+ return $tcltest::verbose
+ }
+ if {[llength $level] > 1} {
+ set tcltest::verbose $level
+ } else {
+ if {[regexp {pass|body|skip|start|error} $level]} {
+ set tcltest::verbose $level
+ } else {
+ set levelList [split $level {}]
+ set tcltest::verbose [string map {p pass b body s skip t start e
+ error} $levelList]
+ }
+ }
+ return $tcltest::verbose
+}
+
+# tcltest::isVerbose --
+#
+# Returns true if argument is one of the verbosity levels currently being
+# used; returns false otherwise.
+#
+# Arguments:
+# level
+#
+# Results:
+# boolean 1 (true) or 0 (false), depending on whether or not the level
+# provided is one of the ones stored in tcltest::verbose.
+#
+# Side effects:
+# None.
+
+proc tcltest::isVerbose {level} {
+ if {[lsearch -exact [tcltest::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)
+#
+# Arguments:
+# output file descriptor
+#
+# Results:
+# file descriptor corresponding to supplied file name (or currently set
+# file descriptor, if no new filename was supplied) - this is the content
+# of tcltest::outputChannel
+#
+# Side effects:
+# None.
+
+proc tcltest::outputChannel { {filename ""} } {
+ if {[llength [info level 0]] == 1} {
+ return $tcltest::outputChannel
+ }
+ if {($filename == "stderr") || ($filename == "stdout")} {
+ set tcltest::outputChannel $filename
+ } else {
+ set tcltest::outputChannel [open $filename w]
+ }
+ return $tcltest::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
+#
+# Arguments:
+# output file name
+#
+# Results:
+# file name corresponding to supplied file name (or currently set
+# file name, if no new filename was supplied) - this is the content
+# of tcltest::outputFile
+#
+# Side effects:
+# if the file name supplied is relative, it will be made absolute with
+# respect to the predefined temporaryDirectory
+
+proc tcltest::outputFile { {filename ""} } {
+ if {[llength [info level 0]] == 1} {
+ return $tcltest::outputFile
+ }
+ if {($filename != "stderr") && ($filename != "stdout")} {
+ MakeAbsolutePath filename $tcltest::temporaryDirectory
+ }
+ tcltest::outputChannel $filename
+ set tcltest::outputFile $filename
+}
+
+# tcltest::errorChannel --
+#
+# set or return the error file descriptor based on the supplied file name
+# (where tcltest sends all its errors)
+#
+# Arguments:
+# error file name
+#
+# Results:
+# file descriptor corresponding to the supplied file name (or currently
+# set file descriptor, if no new filename was supplied) - this is the
+# content of tcltest::errorChannel
+#
+# Side effects:
+# opens the descriptor in w mode unless the filename is set to stderr or
+# stdout
+
+proc tcltest::errorChannel { {filename ""} } {
+ if {[llength [info level 0]] == 1} {
+ return $tcltest::errorChannel
+ }
+ if {($filename == "stderr") || ($filename == "stdout")} {
+ set tcltest::errorChannel $filename
+ } else {
+ set tcltest::errorChannel [open $filename w]
+ }
+ return $tcltest::errorChannel
+}
+
+# tcltest::errorFile --
+#
+# set or return the error file name; calls tcltest::errorChannel to set
+# the corresponding file descriptor
+#
+# Arguments:
+# error file name
+#
+# Results:
+# content of tcltest::errorFile
+#
+# Side effects:
+# if the file name supplied is relative, it will be made absolute with
+# respect to the predefined temporaryDirectory
+
+proc tcltest::errorFile { {filename ""} } {
+ if {[llength [info level 0]] == 1} {
+ return $tcltest::errorFile
+ }
+ if {($filename != "stderr") && ($filename != "stdout")} {
+ MakeAbsolutePath filename $tcltest::temporaryDirectory
+ }
+ 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
+ }
+ set tcltest::debug $debugLevel
+}
+
+# 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.
+#
+# Arguments:
+# constraint - name of the constraint
+# value - new value for constraint (should be boolean) - if not supplied,
+# this is a query
+#
+# Results:
+# content of tcltest::testConstraints($constraint)
+#
+# Side effects:
+# appends the constraint name to tcltest::constraintsSpecified
+
+proc tcltest::testConstraint {constraint {value ""}} {
+ 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]
+}
+
+# tcltest::limitConstraints --
+#
+# sets the limited constraints to tcltest::limitConstraints
+#
+# Arguments:
+# list of constraint names
+#
+# Results:
+# content of tcltest::limitConstraints
+#
+# Side effects:
+# None.
+
+proc tcltest::limitConstraints { {constraintList ""} } {
+ 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 $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 tcltest::loadScript $script
+}
+
+# tcltest::loadFile --
+#
+# set the load file (containing the load script);
+# put the content of the load file into loadScript
+#
+# Arguments:
+# script's file name
+#
+# Results:
+# content of tcltest::loadFile
+#
+# Side effects:
+# None.
+
+proc tcltest::loadFile { {scriptFile ""} } {
+ if {[llength [info level 0]] == 1} {
+ return $tcltest::loadFile
+ }
+ MakeAbsolutePath scriptFile $tcltest::temporaryDirectory
+ set tmp [open $scriptFile r]
+ tcltest::loadScript [read $tmp]
+ close $tmp
+ set tcltest::loadFile $scriptFile
+}
+
+# tcltest::workingDirectory --
+#
+# set workingDirectory to the given path.
+# If the path is relative, make it absolute.
+# change directory to the stated working directory, if resetting the
+# value
+#
+# Arguments:
+# directory name
+#
+# Results:
+# content of tcltest::workingDirectory
+#
+# Side effects:
+# None.
+
+proc tcltest::workingDirectory { {dir ""} } {
+ if {[llength [info level 0]] == 1} {
+ return $tcltest::workingDirectory
+ }
+ set tcltest::workingDirectory $dir
+ MakeAbsolutePath tcltest::workingDirectory
+ cd $tcltest::workingDirectory
+ return $tcltest::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.
+#
+# If tcltest::temporaryDirectory does not already exist, create it.
+# If you cannot create it, then return an error (the file mkdir isn't
+# caught and will propagate).
+#
+# Arguments:
+# directory name
+#
+# Results:
+# content of tcltest::temporaryDirectory
+#
+# Side effects:
+# None.
+
+proc tcltest::temporaryDirectory { {dir ""} } {
+ if {[llength [info level 0]] == 1} {
+ return $tcltest::temporaryDirectory
+ }
+ set tcltest::temporaryDirectory $dir
+
+ MakeAbsolutePath tcltest::temporaryDirectory
+ set tmpDirError "bad argument for temporary directory: "
+
+ if {[file exists $tcltest::temporaryDirectory]} {
+ tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError
+ } else {
+ file mkdir $tcltest::temporaryDirectory
+ }
+
+ normalizePath tcltest::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.
+#
+# If tcltest::testsDirectory does not already exist, return an error.
+#
+# Arguments:
+# directory name
+#
+# Results:
+# content of tcltest::testsDirectory
+#
+# Side effects:
+# None.
+
+proc tcltest::testsDirectory { {dir ""} } {
+ if {[llength [info level 0]] == 1} {
+ return $tcltest::testsDirectory
+ }
+
+ set tcltest::testsDirectory $dir
+
+ MakeAbsolutePath tcltest::testsDirectory
+ set testDirError "bad argument for tests directory: "
+
+ if {[file exists $tcltest::testsDirectory]} {
+ tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError
+ } else {
+ set msg "$testDirError \"$tcltest::testsDirectory\" does not exist"
+ error $msg
+ }
+
+ 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
+}
+
+# tcltest::interpreter --
+#
+# the interpreter name stored in tcltest::tcltest
+#
+# Arguments:
+# executable name
+#
+# Results:
+# content of tcltest::tcltest
+#
+# Side effects:
+# None.
+
+proc tcltest::interpreter { {interp ""} } {
+ if {[llength [info level 0]] == 1} {
+ return $tcltest::tcltest
+ }
+ set tcltest::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 --
+#####################################################################
+
+# tcltest::AddToSkippedBecause --
#
# Increments the variable used to track how many tests were skipped
# because of a particular constraint.
@@ -353,52 +1165,61 @@ proc ::tcltest::DebugDo {level script} {
# constraint The name of the constraint to be modified
#
# Results:
-# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't
+# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't
# previously exist - otherwise, it just increments it.
+#
+# Side effects:
+# None.
-proc ::tcltest::AddToSkippedBecause { constraint } {
+proc tcltest::AddToSkippedBecause { constraint {value 1}} {
# add the constraint to the list of constraints that kept tests
# from running
- if {[info exists ::tcltest::skippedBecause($constraint)]} {
- incr ::tcltest::skippedBecause($constraint)
+ if {[info exists tcltest::skippedBecause($constraint)]} {
+ incr tcltest::skippedBecause($constraint) $value
} else {
- set ::tcltest::skippedBecause($constraint) 1
+ set tcltest::skippedBecause($constraint) $value
}
return
}
-# ::tcltest::PrintError --
+# tcltest::PrintError --
#
-# Prints errors to ::tcltest::errorChannel and then flushes that
+# Prints errors to tcltest::errorChannel and then flushes that
# channel, making sure that all messages are < 80 characters per line.
#
# Arguments:
# errorMsg String containing the error to be printed
#
+#
+# Results:
+# None.
+#
+# Side effects:
+# None.
-proc ::tcltest::PrintError {errorMsg} {
+proc tcltest::PrintError {errorMsg} {
set InitialMessage "Error: "
set InitialMsgLen [string length $InitialMessage]
- puts -nonewline $::tcltest::errorChannel $InitialMessage
+ puts -nonewline [errorChannel] $InitialMessage
# Keep track of where the end of the string is.
set endingIndex [string length $errorMsg]
if {$endingIndex < 80} {
- puts $::tcltest::errorChannel $errorMsg
+ puts [errorChannel] $errorMsg
} else {
# Print up to 80 characters on the first line, including the
# InitialMessage.
set beginningIndex [string last " " [string range $errorMsg 0 \
[expr {80 - $InitialMsgLen}]]]
- puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]
+ puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
while {$beginningIndex != "end"} {
- puts -nonewline $::tcltest::errorChannel \
+ puts -nonewline [errorChannel] \
[string repeat " " $InitialMsgLen]
if {[expr {$endingIndex - $beginningIndex}] < 72} {
- puts $::tcltest::errorChannel [string trim \
+ puts [errorChannel] [string trim \
[string range $errorMsg $beginningIndex end]]
set beginningIndex end
} else {
@@ -409,25 +1230,52 @@ proc ::tcltest::PrintError {errorMsg} {
|| ($newEndingIndex <= $beginningIndex)} {
set newEndingIndex end
}
- puts $::tcltest::errorChannel [string trim \
+ puts [errorChannel] [string trim \
[string range $errorMsg \
- $beginningIndex $newEndingIndex]]
+ $beginningIndex $newEndingIndex]]
set beginningIndex $newEndingIndex
}
}
}
- flush $::tcltest::errorChannel
+ flush [errorChannel]
return
}
-if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} {
- proc ::tcltest::initConstraintsHook {} {}
+if {[namespace inscope tcltest info procs initConstraintsHook] == {}} {
+ proc tcltest::initConstraintsHook {} {}
+}
+
+# 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.
+#
+# Arguments:
+# n1 - name of the array (tcltest::testConstraints)
+# n2 - array key value (constraint name)
+# op - operation performed on tcltest::testConstraints (generally r)
+#
+# Results:
+# none
+#
+# Side effects:
+# sets tcltest::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
+ }
}
-# ::tcltest::initConstraints --
+# tcltest::initConstraints --
#
-# Check Constraintsuration information that will determine which tests
-# to run. To do this, create an array ::tcltest::testConstraints. Each
+# 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
@@ -437,101 +1285,110 @@ if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} {
# none
#
# Results:
-# The ::tcltest::testConstraints array is reset to have an index for
+# The tcltest::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
- # 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.
+ # Safely refer to non-existent members of the tcltest::testConstraints
+ # array without causing an error.
+ trace variable tcltest::testConstraints r tcltest::safeFetch
- trace variable ::tcltest::testConstraints r ::tcltest::safeFetch
+ tcltest::initConstraintsHook
- proc ::tcltest::safeFetch {n1 n2 op} {
- if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} {
- set ::tcltest::testConstraints($n2) 0
- }
- }
+ tcltest::testConstraint singleTestInterp [singleProcess]
- ::tcltest::initConstraintsHook
+ # All the 'pc' constraints are here for backward compatibility and are not
+ # documented. They have been replaced with equivalent 'win' constraints.
- set ::tcltest::testConstraints(unixOnly) \
+ tcltest::testConstraint unixOnly \
[string equal $tcl_platform(platform) "unix"]
- set ::tcltest::testConstraints(macOnly) \
+ tcltest::testConstraint macOnly \
[string equal $tcl_platform(platform) "macintosh"]
- set ::tcltest::testConstraints(pcOnly) \
+ tcltest::testConstraint pcOnly \
+ [string equal $tcl_platform(platform) "windows"]
+ tcltest::testConstraint winOnly \
[string equal $tcl_platform(platform) "windows"]
- set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly)
- set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly)
- set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly)
-
- set ::tcltest::testConstraints(unixOrPc) \
- [expr {$::tcltest::testConstraints(unix) \
- || $::tcltest::testConstraints(pc)}]
- set ::tcltest::testConstraints(macOrPc) \
- [expr {$::tcltest::testConstraints(mac) \
- || $::tcltest::testConstraints(pc)}]
- set ::tcltest::testConstraints(macOrUnix) \
- [expr {$::tcltest::testConstraints(mac) \
- || $::tcltest::testConstraints(unix)}]
-
- set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \
- "Windows NT"]
- set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \
- "Windows 95"]
- set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \
- "Windows 98"]
+ 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.
- set ::tcltest::testConstraints(tempNotPc) \
- [expr {!$::tcltest::testConstraints(pc)}]
- set ::tcltest::testConstraints(tempNotMac) \
- [expr {!$::tcltest::testConstraints(mac)}]
- set ::tcltest::testConstraints(tempNotUnix) \
- [expr {!$::tcltest::testConstraints(unix)}]
+ 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.
- set ::tcltest::testConstraints(pcCrash) \
- [expr {!$::tcltest::testConstraints(pc)}]
- set ::tcltest::testConstraints(macCrash) \
- [expr {!$::tcltest::testConstraints(mac)}]
- set ::tcltest::testConstraints(unixCrash) \
- [expr {!$::tcltest::testConstraints(unix)}]
+ 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]}]
# Skip empty tests
- set ::tcltest::testConstraints(emptyTest) 0
+ tcltest::testConstraint emptyTest 0
# By default, tests that expose known bugs are skipped.
- set ::tcltest::testConstraints(knownBug) 0
+ tcltest::testConstraint knownBug 0
# By default, non-portable tests are skipped.
- set ::tcltest::testConstraints(nonPortable) 0
+ tcltest::testConstraint nonPortable 0
# Some tests require user interaction.
- set ::tcltest::testConstraints(userInteraction) 0
+ tcltest::testConstraint userInteraction 0
# Some tests must be skipped if the interpreter is not in interactive mode
if {[info exists tcl_interactive]} {
- set ::tcltest::testConstraints(interactive) $::tcl_interactive
+ tcltest::testConstraint interactive $::tcl_interactive
} else {
- set ::tcltest::testConstraints(interactive) 0
+ tcltest::testConstraint interactive 0
}
# Some tests can only be run if the installation came from a CD image
@@ -539,8 +1396,8 @@ proc ::tcltest::initConstraints {} {
# 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.
- set ::tcltest::testConstraints(root) 0
- set ::tcltest::testConstraints(notRoot) 1
+ tcltest::testConstraint root 0
+ tcltest::testConstraint notRoot 1
set user {}
if {[string equal $tcl_platform(platform) "unix"]} {
catch {set user [exec whoami]}
@@ -548,21 +1405,21 @@ proc ::tcltest::initConstraints {} {
catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
}
if {([string equal $user "root"]) || ([string equal $user ""])} {
- set ::tcltest::testConstraints(root) 1
- set ::tcltest::testConstraints(notRoot) 0
+ tcltest::testConstraint root 1
+ tcltest::testConstraint notRoot 0
}
}
# Set nonBlockFiles constraint: 1 means this platform supports
- # setting files into nonblocking mode.
+ # ting files into nonblocking mode.
if {[catch {set f [open defs r]}]} {
- set ::tcltest::testConstraints(nonBlockFiles) 1
+ tcltest::testConstraint nonBlockFiles 1
} else {
if {[catch {fconfigure $f -blocking off}] == 0} {
- set ::tcltest::testConstraints(nonBlockFiles) 1
+ tcltest::testConstraint nonBlockFiles 1
} else {
- set ::tcltest::testConstraints(nonBlockFiles) 0
+ tcltest::testConstraint nonBlockFiles 0
}
close $f
}
@@ -576,75 +1433,75 @@ proc ::tcltest::initConstraints {} {
if {[string equal $tcl_platform(platform) "unix"]} {
if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
- set ::tcltest::testConstraints(asyncPipeClose) 0
+ tcltest::testConstraint asyncPipeClose 0
} else {
- set ::tcltest::testConstraints(asyncPipeClose) 1
+ tcltest::testConstraint asyncPipeClose 1
}
} else {
- set ::tcltest::testConstraints(asyncPipeClose) 1
+ tcltest::testConstraint asyncPipeClose 1
}
# Test to see if we have a broken version of sprintf with respect
# to the "e" format of floating-point numbers.
- set ::tcltest::testConstraints(eformat) 1
+ tcltest::testConstraint eformat 1
if {![string equal "[format %g 5e-5]" "5e-05"]} {
- set ::tcltest::testConstraints(eformat) 0
+ tcltest::testConstraint eformat 0
}
# Test to see if execed commands such as cat, echo, rm and so forth are
# present on this machine.
- set ::tcltest::testConstraints(unixExecs) 1
+ tcltest::testConstraint unixExecs 1
if {[string equal $tcl_platform(platform) "macintosh"]} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
}
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ if {([tcltest::testConstraint unixExecs] == 1) && \
([string equal $tcl_platform(platform) "windows"])} {
if {[catch {exec cat defs}] == 1} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
}
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ if {([tcltest::testConstraint unixExecs] == 1) && \
([catch {exec echo hello}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
}
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ if {([tcltest::testConstraint unixExecs] == 1) && \
([catch {exec sh -c echo hello}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
}
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ if {([tcltest::testConstraint unixExecs] == 1) && \
([catch {exec wc defs}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
}
- if {$::tcltest::testConstraints(unixExecs) == 1} {
+ if {[tcltest::testConstraint unixExecs] == 1} {
exec echo hello > removeMe
if {[catch {exec rm removeMe}] == 1} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
}
}
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ if {([tcltest::testConstraint unixExecs] == 1) && \
([catch {exec sleep 1}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
}
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ if {([tcltest::testConstraint unixExecs] == 1) && \
([catch {exec fgrep unixExecs defs}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
}
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ if {([tcltest::testConstraint unixExecs] == 1) && \
([catch {exec ps}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
}
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ if {([tcltest::testConstraint unixExecs] == 1) && \
([catch {exec echo abc > removeMe}] == 0) && \
([catch {exec chmod 644 removeMe}] == 1) && \
([catch {exec rm removeMe}] == 0)} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
} else {
catch {exec rm -f removeMe}
}
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ if {([tcltest::testConstraint unixExecs] == 1) && \
([catch {exec mkdir removeMe}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
+ tcltest::testConstraint unixExecs 0
} else {
catch {exec rm -r removeMe}
}
@@ -653,14 +1510,14 @@ proc ::tcltest::initConstraints {} {
# Locate tcltest executable
if {![info exists tk_version]} {
- set tcltest [info nameofexecutable]
+ set tcltest::tcltest [info nameofexecutable]
- if {$tcltest == "{}"} {
- set tcltest {}
+ if {$tcltest::tcltest == "{}"} {
+ set tcltest::tcltest {}
}
}
- set ::tcltest::testConstraints(stdio) 0
+ tcltest::testConstraint stdio 0
catch {
catch {file delete -force tmp}
set f [open tmp w]
@@ -672,7 +1529,7 @@ proc ::tcltest::initConstraints {} {
set f [open "|[list $tcltest tmp]" r]
close $f
- set ::tcltest::testConstraints(stdio) 1
+ tcltest::testConstraint stdio 1
}
catch {file delete -force tmp}
@@ -681,50 +1538,62 @@ proc ::tcltest::initConstraints {} {
# system.
catch {socket} msg
- set ::tcltest::testConstraints(socket) \
+ tcltest::testConstraint socket \
[expr {$msg != "sockets are not available on this system"}]
# Check for internationalization
if {[info commands testlocale] == ""} {
# No testlocale command, no tests...
- set ::tcltest::testConstraints(hasIsoLocale) 0
+ tcltest::testConstraint hasIsoLocale 0
} else {
- set ::tcltest::testConstraints(hasIsoLocale) \
- [string length [::tcltest::set_iso8859_1_locale]]
- ::tcltest::restore_locale
+ tcltest::testConstraint hasIsoLocale \
+ [string length [tcltest::set_iso8859_1_locale]]
+ tcltest::restore_locale
}
}
-# ::tcltest::PrintUsageInfoHook
+#####################################################################
+
+# Handle command line arguments (from argv) and default arg settings
+# (in TCLTEST_OPTIONS).
+
+# tcltest::PrintUsageInfoHook
#
# Hook used for customization of display of usage information.
#
-if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} {
- proc ::tcltest::PrintUsageInfoHook {} {}
+if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} {
+ proc tcltest::PrintUsageInfoHook {} {}
}
-# ::tcltest::PrintUsageInfo
+# tcltest::PrintUsageInfo
#
# Prints out the usage information for package tcltest. This can be
-# customized with the redefinition of ::tcltest::PrintUsageInfoHook.
+# customized with the redefinition of tcltest::PrintUsageInfoHook.
#
# Arguments:
# none
#
+# Results:
+# none
+#
+# Side Effects:
+# none
-proc ::tcltest::PrintUsageInfo {} {
+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' and 'b'. Test suite will \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, and the bodies of \n\
- \t failed tests if 'b' is specified. \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\
@@ -740,17 +1609,21 @@ proc ::tcltest::PrintUsageInfo {} {
\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\
+ \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\
+ \t $tcltest::temporaryDirectory. \n\
-testdir directories\t Search tests in the specified\n\
\t directories. The default value is \n\
- \t $::tcltest::testsDirectory. \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\
@@ -762,207 +1635,98 @@ proc ::tcltest::PrintUsageInfo {} {
-load script \t Specifies the script to load the tested \n\
\t commands. \n\
-debug level \t Internal debug flag."]
- ::tcltest::PrintUsageInfoHook
+ tcltest::PrintUsageInfoHook
return
}
-# ::tcltest::CheckDirectory --
-#
-# This procedure checks whether the specified path is a readable
-# and/or writable directory. If one of the conditions is not
-# satisfied an error is printed and the application aborted. The
-# procedure assumes that the caller already checked the existence
-# of the path.
-#
-# Arguments
-# rw Information what attributes to check. Allowed values:
-# r, w, rw, wr. If 'r' is part of the value the directory
-# must be readable. 'w' associates to 'writable'.
-# dir The directory to check.
-# errMsg The string to prepend to the actual error message before
-# printing it.
-#
-# Results
-# none
-#
-
-proc ::tcltest::CheckDirectory {rw dir errMsg} {
- # Allowed values for 'rw': r, w, rw, wr
-
- if {![file isdir $dir]} {
- ::tcltest::PrintError "$errMsg \"$dir\" is not a directory"
- exit 1
- } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
- ::tcltest::PrintError "$errMsg \"$dir\" is not writeable"
- exit 1
- } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
- ::tcltest::PrintError "$errMsg \"$dir\" is not readable"
- exit 1
- }
-}
-
-# ::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.
-#
-
-proc ::tcltest::normalizePath {pathVar} {
- upvar $pathVar path
-
- set oldpwd [pwd]
- catch {cd $path}
- set path [pwd]
- cd $oldpwd
-}
-
-# ::tcltest::MakeAbsolutePath --
-#
-# This procedure checks whether the incoming path is absolute or not.
-# Makes it absolute if it was not.
-#
-# Arguments
-# pathVar contains the name of the variable containing the path to modify.
-# prefix is optional, contains the path to use to make the other an
-# absolute one. The current working directory is used if it was
-# not specified.
-#
-# Results
-# The path is modified in place.
-#
-
-proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
- upvar $pathVar path
-
- if {![string equal [file pathtype $path] "absolute"]} {
- if {$prefix == {}} {
- set prefix [pwd]
- }
-
- set path [file join $prefix $path]
- }
-}
-
-# ::tcltest::processCmdLineArgsFlagsHook --
+# tcltest::processCmdLineArgsFlagsHook --
#
# This hook is used to add to the list of command line arguments that are
-# processed by ::tcltest::processCmdLineArgs.
+# processed by tcltest::ProcessFlags. It is called at the beginning of
+# ProcessFlags.
#
-if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
- proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
+if {[namespace inscope tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
+ proc tcltest::processCmdLineArgsAddFlagsHook {} {}
}
-# ::tcltest::processCmdLineArgsHook --
+# tcltest::processCmdLineArgsHook --
#
# This hook is used to actually process the flags added by
-# ::tcltest::processCmdLineArgsAddFlagsHook.
+# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of
+# ProcessFlags.
#
# Arguments:
# flags The flags that have been pulled out of argv
#
-if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} {
- proc ::tcltest::processCmdLineArgsHook {flag} {}
+if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} {
+ proc tcltest::processCmdLineArgsHook {flag} {}
}
-# ::tcltest::processCmdLineArgs --
+# tcltest::ProcessFlags --
#
-# Use command line args to set the verbose, skip, and
-# match, outputChannel, errorChannel, debug, and temporaryDirectory
-# variables.
-#
-# This procedure must be run after constraints are initialized, because
-# some constraints can be overridden.
+# process command line arguments supplied in the flagArray - this is
+# called by processCmdLineArgs
+# modifies tcltest variables according to the content of the flagArray.
#
# Arguments:
-# none
+# flagArray - array containing name/value pairs of flags
#
# Results:
-# Sets the above-named variables in the tcltest namespace.
-
-proc ::tcltest::processCmdLineArgs {} {
- global argv
-
- # The "argv" var doesn't exist in some cases, so use {}.
-
- if {(![info exists argv]) || ([llength $argv] < 1)} {
- set flagArray {}
- } else {
- set flagArray $argv
- }
-
- # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
- # Note that -verbose cannot be abbreviated to -v in wish because it
- # conflicts with the wish option -visual.
+# sets tcltest variables according to their values as defined by
+# flagArray
+#
+# Side effects:
+# None.
+proc tcltest::ProcessFlags {flagArray} {
# Process -help first
- if {([lsearch -exact $flagArray {-help}] != -1) || \
- ([lsearch -exact $flagArray {-h}] != -1)} {
- ::tcltest::PrintUsageInfo
- exit 1
- }
-
- if {[catch {array set flag $flagArray}]} {
- ::tcltest::PrintError "odd number of arguments specified on command line: \
- $argv"
- ::tcltest::PrintUsageInfo
+ if {[lsearch -exact $flagArray {-help}] != -1} {
+ tcltest::PrintUsageInfo
exit 1
}
+
+ catch {array set flag $flagArray}
# -help is not listed since it has already been processed
lappend defaultFlags -verbose -match -skip -constraints \
-outfile -errfile -debug -tmpdir -file -notfile \
- -preservecore -limitconstraints -args -testdir \
- -load -loadfile
+ -preservecore -limitconstraints -testdir \
+ -load -loadfile -asidefromdir \
+ -relateddir -singleproc
set defaultFlags [concat $defaultFlags \
- [ ::tcltest::processCmdLineArgsAddFlagsHook ]]
-
- foreach arg $defaultFlags {
- set abbrev [string range $arg 0 1]
- if {([info exists flag($abbrev)]) && \
- ([lsearch -exact $flagArray $arg] < [lsearch -exact \
- $flagArray $abbrev])} {
- set flag($arg) $flag($abbrev)
- }
- }
-
- # Set ::tcltest::parameters to the arg of the -args flag, if given
- if {[info exists flag(-args)]} {
- set ::tcltest::parameters $flag(-args)
- }
-
- # Set ::tcltest::verbose to the arg of the -verbose flag, if given
+ [tcltest::processCmdLineArgsAddFlagsHook ]]
+ # Set tcltest::verbose to the arg of the -verbose flag, if given
if {[info exists flag(-verbose)]} {
- set ::tcltest::verbose $flag(-verbose)
+ tcltest::verbose $flag(-verbose)
}
- # Set ::tcltest::match to the arg of the -match flag, if given.
-
+ # Set tcltest::match to the arg of the -match flag, if given.
if {[info exists flag(-match)]} {
- set ::tcltest::match $flag(-match)
+ tcltest::match $flag(-match)
}
- # Set ::tcltest::skip to the arg of the -skip flag, if given
-
+ # Set tcltest::skip to the arg of the -skip flag, if given
if {[info exists flag(-skip)]} {
- set ::tcltest::skip $flag(-skip)
+ tcltest::skip $flag(-skip)
}
# Handle the -file and -notfile flags
if {[info exists flag(-file)]} {
- set ::tcltest::matchFiles $flag(-file)
+ tcltest::matchFiles $flag(-file)
}
if {[info exists flag(-notfile)]} {
- set ::tcltest::skipFiles $flag(-notfile)
+ tcltest::skipFiles $flag(-notfile)
+ }
+
+ # Handle -relateddir and -asidefromdir flags
+ if {[info exists flag(-relateddir)]} {
+ tcltest::matchDirectories $flag(-relateddir)
+ }
+ if {[info exists flag(-asidefromdir)]} {
+ tcltest::skipDirectories $flag(-asidefromdir)
}
# Use the -constraints flag, if given, to turn on constraints that are
@@ -971,7 +1735,7 @@ proc ::tcltest::processCmdLineArgs {} {
if {[info exists flag(-constraints)]} {
foreach elt $flag(-constraints) {
- set ::tcltest::testConstraints($elt) 1
+ tcltest::testConstraint $elt 1
}
}
@@ -980,87 +1744,35 @@ proc ::tcltest::processCmdLineArgs {} {
# the -constraints flag was not specified, print out an error and exit.
if {[info exists flag(-limitconstraints)]} {
if {![info exists flag(-constraints)]} {
- puts "You can only use the -limitconstraints flag with \
- -constraints"
- exit 1
- }
- set ::tcltest::limitConstraints $flag(-limitconstraints)
- foreach elt [array names ::tcltest::testConstraints] {
- if {[lsearch -exact $flag(-constraints) $elt] == -1} {
- set ::tcltest::testConstraints($elt) 0
- }
+ set msg "-limitconstraints flag can only be used with -constraints"
+ error $msg
}
+ tcltest::limitConstraints $flag(-limitconstraints)
}
- # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if
+ # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if
# given.
- #
- # 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.
- set tmpDirError ""
if {[info exists flag(-tmpdir)]} {
- set ::tcltest::temporaryDirectory $flag(-tmpdir)
-
- MakeAbsolutePath ::tcltest::temporaryDirectory
- set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
- }
- if {[file exists $::tcltest::temporaryDirectory]} {
- ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError
- } else {
- file mkdir $::tcltest::temporaryDirectory
+ tcltest::temporaryDirectory $flag(-tmpdir)
}
- normalizePath ::tcltest::temporaryDirectory
-
- # Set the ::tcltest::testsDirectory to the arg of -testdir, if
+ # Set the tcltest::testsDirectory to the arg of -testdir, if
# given.
- #
- # 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 return an error.
- set testDirError ""
if {[info exists flag(-testdir)]} {
- set ::tcltest::testsDirectory $flag(-testdir)
-
- MakeAbsolutePath ::tcltest::testsDirectory
- set testDirError "bad argument \"$flag(-testdir)\" to -testdir: "
- }
- if {[file exists $::tcltest::testsDirectory]} {
- ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError
- } else {
- ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \
- does not exist"
- exit 1
- }
-
- normalizePath ::tcltest::testsDirectory
-
- # Save the names of files that already exist in
- # the output directory.
- foreach file [glob -nocomplain \
- [file join $::tcltest::temporaryDirectory *]] {
- lappend ::tcltest::filesExisted [file tail $file]
+ tcltest::testsDirectory $flag(-testdir)
}
# If an alternate error or output files are specified, change the
# default channels.
if {[info exists flag(-outfile)]} {
- set tmp $flag(-outfile)
- MakeAbsolutePath tmp $::tcltest::temporaryDirectory
- set ::tcltest::outputChannel [open $tmp w]
+ tcltest::outputFile $flag(-outfile)
}
if {[info exists flag(-errfile)]} {
- set tmp $flag(-errfile)
- MakeAbsolutePath tmp $::tcltest::temporaryDirectory
- set ::tcltest::errorChannel [open $tmp w]
+ tcltest::errorFile $flag(-errfile)
}
# If a load script was specified, either directly or through
@@ -1068,294 +1780,647 @@ proc ::tcltest::processCmdLineArgs {} {
if {[info exists flag(-load)] && \
([lsearch -exact $flagArray -load] > \
- [lsearch -exact $flagArray -loadfile])} {
- set ::tcltest::loadScript $flag(-load)
+ [lsearch -exact $flagArray -loadfile])} {
+ tcltest::loadScript $flag(-load)
}
if {[info exists flag(-loadfile)] && \
([lsearch -exact $flagArray -loadfile] > \
- [lsearch -exact $flagArray -load]) } {
- set tmp $flag(-loadfile)
- MakeAbsolutePath tmp $::tcltest::temporaryDirectory
- set tmp [open $tmp r]
- set ::tcltest::loadScript [read $tmp]
- close $tmp
+ [lsearch -exact $flagArray -load]) } {
+ tcltest::loadFile $flag(-loadfile)
}
# If the user specifies debug testing, print out extra information during
# the run.
if {[info exists flag(-debug)]} {
- set ::tcltest::debug $flag(-debug)
+ tcltest::debug $flag(-debug)
}
# Handle -preservecore
if {[info exists flag(-preservecore)]} {
- set ::tcltest::preserveCore $flag(-preservecore)
+ tcltest::preserveCore $flag(-preservecore)
+ }
+
+ # Handle -singleproc flag
+ if {[info exists flag(-singleproc)]} {
+ tcltest::singleProcess $flag(-singleproc)
}
# Call the hook
- ::tcltest::processCmdLineArgsHook [array get flag]
+ tcltest::processCmdLineArgsHook [array get flag]
+ return
+}
- # Spit out everything you know if we're at a debug level 2 or greater
+# 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.
+#
+# Set variables based on the contents of the environment variable
+# 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 {} {
+ global argv
+
+ # 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)
+ }
+
+ # The "argv" var doesn't exist in some cases, so use {}.
+ if {(![info exists argv]) || ([llength $argv] < 1)} {
+ set flagArray {}
+ } else {
+ set flagArray $argv
+ }
+
+ tcltest::ProcessFlags $flagArray
- DebugPuts 2 "Flags passed into tcltest:"
- DebugPArray 2 flag
- 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::outputChannel = $::tcltest::outputChannel"
- DebugPuts 2 "::tcltest::errorChannel = $::tcltest::errorChannel"
- DebugPuts 2 "Original environment (::tcltest::originalEnv):"
- DebugPArray 2 ::tcltest::originalEnv
+ # 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)"
+ }
+ 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::outputChannel = [outputChannel]"
+ DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
+ DebugPuts 2 "Original environment (tcltest::originalEnv):"
+ DebugPArray 2 tcltest::originalEnv
DebugPuts 2 "Constraints:"
- DebugPArray 2 ::tcltest::testConstraints
+ DebugPArray 2 tcltest::testConstraints
+ return
}
-# ::tcltest::loadTestedCommands --
+#####################################################################
+
+# Code to run the tests goes here.
+
+# tcltest::testPuts --
#
-# Uses the specified script to load the commands to test. Allowed to
-# be empty, as the tested commands could have been compiled into the
-# interpreter.
+# 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.
#
-# Arguments
-# none
+# Arguments:
+# same as standard puts
#
-# Results
-# none
+# Results:
+# 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]"
+ return
+# return [tcltest::normalPuts -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]
+ }
+ }
-proc ::tcltest::loadTestedCommands {} {
- if {$::tcltest::loadScript == {}} {
+ 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"
+ }
return
+ # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]]
}
-
- uplevel #0 $::tcltest::loadScript
+
+ # 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]
}
-# ::tcltest::cleanupTests --
+# tcltest::testEval --
#
-# Remove files and dirs created using the makeFile and makeDirectory
-# commands since the last time this proc was invoked.
+# 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.
#
-# Print the names of the files created without the makeFile command
-# since the tests were invoked.
+# Arguments:
+# script Script to evaluate
+# ?ignoreOutput? Indicates whether or not to ignore output sent to
+# stdout & stderr
#
-# Print the number tests (total, passed, failed, and skipped) since the
-# tests were invoked.
-#
-# Restore original environment (as reported by special variable env).
-
-proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
-
- set testFileName [file tail [info script]]
+# 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.
- # Call the cleanup hook
- ::tcltest::cleanupTestsHook
+proc tcltest::testEval {script {ignoreOutput 1}} {
+ DebugPuts 3 "testEval called"
+ if {!$ignoreOutput} {
+ set tcltest::outData {}
+ set tcltest::errData {}
+ uplevel rename ::puts tcltest::normalPuts
+ uplevel rename tcltest::testPuts ::puts
+ }
+ set result [uplevel $script]
+ if {!$ignoreOutput} {
+ uplevel rename ::puts tcltest::testPuts
+ uplevel rename tcltest::normalPuts ::puts
+ }
+ return $result
+}
- # 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.
+# 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.
+#
+# Arguments:
+# actual - string containing the actual result
+# expected - pattern to be matched against
+# mode - type of comparison to be done
+#
+# Results:
+# result of the match
+#
+# Side effects:
+# None.
- if {!$calledFromAllFile} {
- foreach file $::tcltest::filesMade {
- if {[file exists $file]} {
- catch {file delete -force $file}
- }
+proc tcltest::compareStrings {actual expected mode} {
+ switch -- $mode {
+ exact {
+ set retval [string equal $actual $expected]
}
- set currentFiles {}
- foreach file [glob -nocomplain \
- [file join $::tcltest::temporaryDirectory *]] {
- lappend currentFiles [file tail $file]
+ glob {
+ set retval [string match $expected $actual]
}
- set newFiles {}
- foreach file $currentFiles {
- if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
- lappend newFiles $file
- }
- }
- set ::tcltest::filesExisted $currentFiles
- if {[llength $newFiles] > 0} {
- set ::tcltest::createdNewFiles($testFileName) $newFiles
+ regexp {
+ set retval [regexp -- $expected $actual]
}
}
+ return $retval
+}
- if {$calledFromAllFile || $::tcltest::testSingleFile} {
- # print stats
+#
+# 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:
+#
+# substArguments {$a {$a}}
+#
+# Then it is as though the function is invoked as:
+#
+# substArguments $a {$a}
+#
+# This code is adapted from Paul Duffin's function "SplitIntoWords".
+# The original function can be found on:
+#
+# http://purl.org/thecliff/tcl/wiki/858.html
+#
+# Results:
+# a list containing the result of the substitution
+#
+# Exceptions:
+# An error may occur if the list containing unbalanced quote or
+# unknown variable.
+#
+# Side Effects:
+# None.
+#
+
+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.
+
+ set result {}
+ set token ""
+
+ 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.
+ set text [string range $argList 0 \
+ [expr {[lindex $all 0] - 1}]]
+ # Get the word with the quote
+ set word [string range $argList \
+ [lindex $all 0] [lindex $all 1]]
+
+ # Remove all text up to and including the word from the
+ # argList.
+ set argList [string range $argList \
+ [expr {[lindex $all 1] + 1}] end]
+ } else {
+ # Take everything up to the end of the argList.
+ set text $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,
+ # add the text and the current word to this token.
+ append token $text $word
+ } else {
+ # Add the text to the result. There is no need to parse
+ # the text because it couldn't be a part of any multi-word
+ # token. Then start a new multi-word token with the word
+ # because we need to pass this token to the Tcl parser to
+ # check for balancing quotes
+ 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]
+ append result \{$token\}
+ set token {}
+ }
+ }
- puts -nonewline $::tcltest::outputChannel "$testFileName:"
- foreach index [list "Total" "Passed" "Skipped" "Failed"] {
- puts -nonewline $::tcltest::outputChannel \
- "\t$index\t$::tcltest::numTests($index)"
- }
- puts $::tcltest::outputChannel ""
+ # If the last token has not been added to the list then there
+ # is a problem.
+ if { [string length $token] } {
+ error "incomplete token \"$token\""
+ }
- # print number test files sourced
- # print names of files that ran tests which failed
+ return $result
+}
- if {$calledFromAllFile} {
- puts $::tcltest::outputChannel \
- "Sourced $::tcltest::numTestFiles Test Files."
- set ::tcltest::numTestFiles 0
- if {[llength $::tcltest::failFiles] > 0} {
- puts $::tcltest::outputChannel \
- "Files with failing tests: $::tcltest::failFiles"
- set ::tcltest::failFiles {}
- }
- }
- # if any tests were skipped, print the constraints that kept them
- # from running.
+# 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
+# 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.
+#
+# 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.
+#
+# 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.
+#
- set constraintList [array names ::tcltest::skippedBecause]
- if {[llength $constraintList] > 0} {
- puts $::tcltest::outputChannel \
- "Number of tests skipped for each constraint:"
- foreach constraint [lsort $constraintList] {
- puts $::tcltest::outputChannel \
- "\t$::tcltest::skippedBecause($constraint)\t$constraint"
- unset ::tcltest::skippedBecause($constraint)
- }
- }
+proc tcltest::test {name description args} {
+ DebugPuts 3 "Test $name $args"
- # report the names of test files in ::tcltest::createdNewFiles, and
- # reset the array to be empty.
+ incr tcltest::testLevel
- set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
- if {[llength $testFilesThatTurded] > 0} {
- puts $::tcltest::outputChannel "Warning: files left behind:"
- foreach testFile $testFilesThatTurded {
- puts $::tcltest::outputChannel \
- "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
- unset ::tcltest::createdNewFiles($testFile)
+ # 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} {
+ 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 returnCodes [list 0 2]
+
+ # 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
+ return 1
+ } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} {
+
+ if {[llength $args] == 1} {
+ 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])]
+ }
}
+ } else {
+ array set testAttributes $args
}
- # reset filesMade, filesExisted, and numTests
+ set validFlags {-setup -cleanup -body -result -returnCodes -match \
+ -output -errorOutput -constraints}
- set ::tcltest::filesMade {}
- foreach index [list "Total" "Passed" "Skipped" "Failed"] {
- set ::tcltest::numTests($index) 0
+ foreach flag [array names testAttributes] {
+ if {[lsearch -exact $validFlags $flag] == -1} {
+ puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test"
+ incr tcltest::testLevel -1
+ return 1
+ }
}
- # exit only if running Tk in non-interactive mode
-
- global tk_version tcl_interactive
- if {[info exists tk_version] && ![info exists tcl_interactive]} {
- exit
+ # store whatever the user gave us
+ foreach item [array names testAttributes] {
+ set [string trimleft $item "-"] $testAttributes($item)
}
- } 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
+ # 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}"
+ incr tcltest::testLevel -1
+ return 1
+ }
- incr ::tcltest::numTestFiles
- if {($::tcltest::currentFailure) && \
- ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} {
- lappend ::tcltest::failFiles $testFileName
+ # Replace symbolic valies supplied for -returnCodes
+ regsub -nocase normal $returnCodes 0 returnCodes
+ regsub -nocase error $returnCodes 1 returnCodes
+ regsub -nocase return $returnCodes 2 returnCodes
+ regsub -nocase break $returnCodes 3 returnCodes
+ regsub -nocase continue $returnCodes 4 returnCodes
+ } else {
+ # 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]
+ } elseif {[llength $args] == 3} {
+ 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\"}"
+ incr tcltest::testLevel -1
+ return 1
}
- set ::tcltest::currentFailure false
+ }
- # restore the environment to the state it was in before this package
- # was loaded
+ set setupFailure 0
+ set cleanupFailure 0
- set newEnv {}
- set changedEnv {}
- set removedEnv {}
- foreach index [array names ::env] {
- if {![info exists ::tcltest::originalEnv($index)]} {
- lappend newEnv $index
- unset ::env($index)
- } else {
- if {$::env($index) != $::tcltest::originalEnv($index)} {
- lappend changedEnv $index
- set ::env($index) $::tcltest::originalEnv($index)
- }
- }
+ # Run the setup script
+ if {[catch {uplevel $setup} setupMsg]} {
+ set setupFailure 1
+ }
+
+ # run the test script
+ set command [list tcltest::runTest $name $description $body \
+ $result $constraints]
+ if {!$setupFailure} {
+ if {[info exists output] || [info exists errorOutput]} {
+ set testResult [uplevel tcltest::testEval [list $command] 0]
+ } else {
+ set testResult [uplevel tcltest::testEval [list $command] 1]
}
- foreach index [array names ::tcltest::originalEnv] {
- if {![info exists ::env($index)]} {
- lappend removedEnv $index
- set ::env($index) $::tcltest::originalEnv($index)
+ } else {
+ set testResult setupFailure
+ }
+
+ # Run the cleanup code
+ if {[catch {uplevel $cleanup} cleanupMsg]} {
+ set cleanupFailure 1
+ }
+
+ # If testResult is an empty list, then the test was skipped
+ 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} {
+ 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 {[info exists coreModTime]} {
+ if {$coreModTime != [file mtime \
+ [file join [tcltest::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]"
+ catch {file rename -force \
+ [file join [tcltest::workingDirectory] core] \
+ [file join $tcltest::temporaryDirectory \
+ core-$name]} msg
+ if {[string length $msg] > 0} {
+ append coreMsg "\nError: Problem renaming core file: $msg"
+ }
+ }
}
+ array set tcl_platform $currentTclPlatform
}
- if {[llength $newEnv] > 0} {
- puts $::tcltest::outputChannel \
- "env array elements created:\t$newEnv"
- }
- if {[llength $changedEnv] > 0} {
- puts $::tcltest::outputChannel \
- "env array elements changed:\t$changedEnv"
+
+ set actualAnswer [lindex $testResult 0]
+ set code [lindex $testResult end]
+
+ # If expected output/error strings exist, we have to compare
+ # 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]]
+ }
+ if {[info exists errorOutput]} {
+ set errorFailure [expr ![compareStrings $tcltest::errData \
+ $errorOutput $match]]
}
- if {[llength $removedEnv] > 0} {
- puts $::tcltest::outputChannel \
- "env array elements removed:\t$removedEnv"
+
+ set testFailed 1
+ set codeFailure 0
+ set scriptFailure 0
+
+ # 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} {
+ set scriptFailure 1
}
- set changedTclPlatform {}
- foreach index [array names ::tcltest::originalTclPlatform] {
- if {$::tcl_platform($index) != \
- $::tcltest::originalTclPlatform($index)} {
- lappend changedTclPlatform $index
- set ::tcl_platform($index) \
- $::tcltest::originalTclPlatform($index)
+ # 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]} {
+ puts [outputChannel] "++++ $name PASSED"
+ }
}
+ set testFailed 0
}
- if {[llength $changedTclPlatform] > 0} {
- puts $::tcltest::outputChannel \
- "tcl_platform array elements changed:\t$changedTclPlatform"
- }
- if {[file exists [file join $::tcltest::workingDirectory core]]} {
- if {$::tcltest::preserveCore > 1} {
- puts $::tcltest::outputChannel "produced core file! \
- Moving file to: \
- [file join $::tcltest::temporaryDirectory core-$name]"
- flush $::tcltest::outputChannel
- catch {file rename -force \
- [file join $::tcltest::workingDirectory core] \
- [file join $::tcltest::temporaryDirectory \
- core-$name]} msg
- if {[string length $msg] > 0} {
- ::tcltest::PrintError "Problem renaming file: $msg"
+ if {$testFailed} {
+ if {$tcltest::testLevel == 1} {
+ incr tcltest::numTests(Failed)
+ }
+ set tcltest::currentFailure true
+ if {![tcltest::isVerbose body]} {
+ set body ""
+ }
+ puts [outputChannel] "\n==== $name [string trim $description] FAILED"
+ if {$body != ""} {
+ puts [outputChannel] "==== Contents of test case:"
+ puts [outputChannel] $body
+ }
+ if {$setupFailure} {
+ 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"
+ }
+ if {$codeFailure} {
+ switch -- $code {
+ 0 { set msg "Test completed normally" }
+ 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" }
+ default { set msg "Test generated exception" }
}
- } 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.
-
- if {[info exists ::tcltest::coreModificationTime]} {
- if {$::tcltest::coreModificationTime != [file mtime \
- [file join $::tcltest::workingDirectory core]]} {
- puts $::tcltest::outputChannel "A core file was created!"
+ puts [outputChannel] "---- $msg; Return code was: $code"
+ puts [outputChannel] "---- Return code should have been one of: $returnCodes"
+ if {[tcltest::isVerbose error]} {
+ if {[info exists ::errorInfo]} {
+ puts [outputChannel] "---- errorInfo: $::errorInfo"
+ puts [outputChannel] "---- errorCode: $::errorCode"
}
- } else {
- puts $::tcltest::outputChannel "A core file was created!"
- }
+ }
+ }
+ if {$outputFailure} {
+ puts [outputChannel] "---- Output was:\n$tcltest::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"
+ }
+ if {$cleanupFailure} {
+ puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
}
+ if {$coreFailure} {
+ puts [outputChannel] "---- Core file produced while running test! $coreMsg"
+ }
+ puts [outputChannel] "==== $name FAILED\n"
+
}
}
+
+ incr tcltest::testLevel -1
+ return 0
}
-# ::tcltest::cleanupTestsHook --
-#
-# This hook allows a harness that builds upon tcltest to specify
-# additional things that should be done at cleanup.
-#
-
-if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
- proc ::tcltest::cleanupTestsHook {} {}
-}
-# test --
+# 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
+# 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
+# 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.
#
# Arguments:
@@ -1364,81 +2429,93 @@ if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
# 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
+# the array "tcltest::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.
+#
+# 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::test {name description script expectedAnswer args} {
-
- DebugPuts 3 "Running $name ($description)"
-
- incr ::tcltest::numTests(Total)
+proc tcltest::runTest {name description script expectedAnswer constraints} {
+ if {$tcltest::testLevel == 1} {
+ incr tcltest::numTests(Total)
+ }
+
# skip the test if it's name matches an element of skip
-
- foreach pattern $::tcltest::skip {
+ foreach pattern $tcltest::skip {
if {[string match $pattern $name]} {
- incr ::tcltest::numTests(Skipped)
- DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip}
+ if {$tcltest::testLevel == 1} {
+ incr tcltest::numTests(Skipped)
+ DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip}
+ }
return
}
}
# skip the test if it's name doesn't match any element of match
-
- if {[llength $::tcltest::match] > 0} {
+ if {[llength $tcltest::match] > 0} {
set ok 0
- foreach pattern $::tcltest::match {
+ foreach pattern $tcltest::match {
if {[string match $pattern $name]} {
set ok 1
break
}
}
if {!$ok} {
- incr ::tcltest::numTests(Skipped)
- DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
+ if {$tcltest::testLevel == 1} {
+ incr tcltest::numTests(Skipped)
+ DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch}
+ }
return
}
}
- set i [llength $args]
- if {$i == 0} {
- set 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
- incr ::tcltest::numTests(Skipped)
+ if {$tcltest::limitConstraints} {
+ tcltest::AddToSkippedBecause userSpecifiedLimitConstraint
+ if {$tcltest::testLevel == 1} {
+ incr tcltest::numTests(Skipped)
+ }
return
}
- } elseif {$i == 1} {
-
- # "constraints" argument exists; shuffle arguments down, then
+ } else {
+ # "constraints" argument exists;
# make sure that the constraints are satisfied.
- set constraints $script
- set script $expectedAnswer
- set expectedAnswer [lindex $args 0]
set doTest 0
if {[string match {*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
catch {set doTest [uplevel #0 expr $constraints]}
} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
# something like {a || b} should be turned into
- # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b).
- regsub -all {[.\w]+} $constraints \
- {$::tcltest::testConstraints(&)} c
+ # $tcltest::testConstraints(a) || $tcltest::testConstraints(b).
+ regsub -all {[.\w]+} $constraints \
+ {$tcltest::testConstraints(&)} c
catch {set doTest [eval expr $c]}
} else {
# 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 tcltest::testConstraints($constraint)]) \
+ || (!$tcltest::testConstraints($constraint))} {
set doTest 0
# store the constraint that kept the test from running
@@ -1447,28 +2524,30 @@ proc ::tcltest::test {name description script expectedAnswer args} {
}
}
}
+
if {$doTest == 0} {
- if {[string first s $::tcltest::verbose] != -1} {
- puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
+ if {[tcltest::isVerbose skip]} {
+ puts [outputChannel] "++++ $name SKIPPED: $constraints"
+ }
+
+ if {$tcltest::testLevel == 1} {
+ incr tcltest::numTests(Skipped)
+ tcltest::AddToSkippedBecause $constraints
}
-
- incr ::tcltest::numTests(Skipped)
- ::tcltest::AddToSkippedBecause $constraints
return
}
- } else {
- error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
- }
+ }
# Save information about the core file. You need to restore the original
- # tcl_platform environment because some of the tests mess with tcl_platform.
+ # tcl_platform environment because some of the tests mess with
+ # tcl_platform.
- if {$::tcltest::preserveCore} {
+ if {$tcltest::preserveCore} {
set currentTclPlatform [array get tcl_platform]
- array set tcl_platform $::tcltest::originalTclPlatform
- if {[file exists [file join $::tcltest::workingDirectory core]]} {
+ array set tcl_platform $tcltest::originalTclPlatform
+ if {[file exists [file join [tcltest::workingDirectory] core]]} {
set coreModTime [file mtime [file join \
- $::tcltest::workingDirectory core]]
+ [tcltest::workingDirectory] core]]
}
array set tcl_platform $currentTclPlatform
}
@@ -1480,107 +2559,288 @@ proc ::tcltest::test {name description script expectedAnswer args} {
memory tag $name
}
+ if {[tcltest::isVerbose start]} {
+ puts [outputChannel] "---- $name start"
+ flush [outputChannel]
+ }
+
set code [catch {uplevel $script} actualAnswer]
- if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} {
- incr ::tcltest::numTests(Passed)
- if {[string first p $::tcltest::verbose] != -1} {
- puts $::tcltest::outputChannel "++++ $name PASSED"
+
+ return [list $actualAnswer $code]
+}
+
+#####################################################################
+
+# tcltest::cleanupTestsHook --
+#
+# This hook allows a harness that builds upon tcltest to specify
+# additional things that should be done at cleanup.
+#
+
+if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} {
+ proc tcltest::cleanupTestsHook {} {}
+}
+
+# tcltest::cleanupTests --
+#
+# Remove files and dirs created using the makeFile and makeDirectory
+# commands since the last time this proc was invoked.
+#
+# Print the names of the files created without the makeFile command
+# since the tests were invoked.
+#
+# 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:
+# None.
+#
+# Side Effects:
+# None
+#
+
+proc tcltest::cleanupTests {{calledFromAllFile 0}} {
+
+ set testFileName [file tail [info script]]
+
+ # Call the cleanup hook
+ tcltest::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.
+
+ if {!$calledFromAllFile} {
+ foreach file $tcltest::filesMade {
+ if {[file exists $file]} {
+ catch {file delete -force $file}
+ }
+ }
+ set currentFiles {}
+ foreach file [glob -nocomplain \
+ [file join $tcltest::temporaryDirectory *]] {
+ lappend currentFiles [file tail $file]
+ }
+ set newFiles {}
+ foreach file $currentFiles {
+ if {[lsearch -exact $tcltest::filesExisted $file] == -1} {
+ lappend newFiles $file
+ }
+ }
+ set tcltest::filesExisted $currentFiles
+ if {[llength $newFiles] > 0} {
+ set tcltest::createdNewFiles($testFileName) $newFiles
+ }
+ }
+
+ if {$calledFromAllFile || $tcltest::testSingleFile} {
+
+ # print stats
+
+ puts -nonewline [outputChannel] "$testFileName:"
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ puts -nonewline [outputChannel] \
+ "\t$index\t$tcltest::numTests($index)"
+ }
+ puts [outputChannel] ""
+
+ # print number test files sourced
+ # print names of files that ran tests which failed
+
+ if {$calledFromAllFile} {
+ puts [outputChannel] \
+ "Sourced $tcltest::numTestFiles Test Files."
+ set tcltest::numTestFiles 0
+ if {[llength $tcltest::failFiles] > 0} {
+ puts [outputChannel] \
+ "Files with failing tests: $tcltest::failFiles"
+ set tcltest::failFiles {}
+ }
+ }
+
+ # if any tests were skipped, print the constraints that kept them
+ # from running.
+
+ set constraintList [array names tcltest::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)
+ }
+ }
+
+ # report the names of test files in tcltest::createdNewFiles, and
+ # reset the array to be empty.
+
+ set testFilesThatTurded [lsort [array names tcltest::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)
+ }
+ }
+
+ # reset filesMade, filesExisted, and numTests
+
+ set tcltest::filesMade {}
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ set tcltest::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]} {
+ exit
}
} else {
- incr ::tcltest::numTests(Failed)
- set ::tcltest::currentFailure true
- if {[string first b $::tcltest::verbose] == -1} {
- set script ""
- }
- puts $::tcltest::outputChannel "\n==== $name $description FAILED"
- if {$script != ""} {
- puts $::tcltest::outputChannel "==== Contents of test case:"
- puts $::tcltest::outputChannel $script
- }
- if {$code != 0} {
- if {$code == 1} {
- puts $::tcltest::outputChannel "==== Test generated error:"
- puts $::tcltest::outputChannel $actualAnswer
- } elseif {$code == 2} {
- puts $::tcltest::outputChannel "==== Test generated return exception; result was:"
- puts $::tcltest::outputChannel $actualAnswer
- } elseif {$code == 3} {
- puts $::tcltest::outputChannel "==== Test generated break exception"
- } elseif {$code == 4} {
- puts $::tcltest::outputChannel "==== Test generated continue exception"
+
+ # 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
+
+ incr tcltest::numTestFiles
+ if {($tcltest::currentFailure) && \
+ ([lsearch -exact $tcltest::failFiles $testFileName] == -1)} {
+ lappend tcltest::failFiles $testFileName
+ }
+ set tcltest::currentFailure false
+
+ # restore the environment to the state it was in before this package
+ # was loaded
+
+ set newEnv {}
+ set changedEnv {}
+ set removedEnv {}
+ foreach index [array names ::env] {
+ if {![info exists tcltest::originalEnv($index)]} {
+ lappend newEnv $index
+ unset ::env($index)
} else {
- puts $::tcltest::outputChannel "==== Test generated exception $code; message was:"
- puts $::tcltest::outputChannel $actualAnswer
+ if {$::env($index) != $tcltest::originalEnv($index)} {
+ lappend changedEnv $index
+ set ::env($index) $tcltest::originalEnv($index)
+ }
}
- } else {
- puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
}
- puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
- puts $::tcltest::outputChannel "==== $name FAILED\n"
- }
- if {$::tcltest::preserveCore} {
- set currentTclPlatform [array get tcl_platform]
- if {[file exists [file join $::tcltest::workingDirectory core]]} {
- if {$::tcltest::preserveCore > 1} {
- puts $::tcltest::outputChannel "==== $name produced core file! \
+ foreach index [array names tcltest::originalEnv] {
+ if {![info exists ::env($index)]} {
+ lappend removedEnv $index
+ set ::env($index) $tcltest::originalEnv($index)
+ }
+ }
+ if {[llength $newEnv] > 0} {
+ puts [outputChannel] \
+ "env array elements created:\t$newEnv"
+ }
+ if {[llength $changedEnv] > 0} {
+ puts [outputChannel] \
+ "env array elements changed:\t$changedEnv"
+ }
+ if {[llength $removedEnv] > 0} {
+ puts [outputChannel] \
+ "env array elements removed:\t$removedEnv"
+ }
+
+ set changedTclPlatform {}
+ foreach index [array names tcltest::originalTclPlatform] {
+ if {$::tcl_platform($index) != \
+ $tcltest::originalTclPlatform($index)} {
+ lappend changedTclPlatform $index
+ set ::tcl_platform($index) \
+ $tcltest::originalTclPlatform($index)
+ }
+ }
+ if {[llength $changedTclPlatform] > 0} {
+ 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)"
+ puts [outputChannel] "produced core file! \
Moving file to: \
- [file join $::tcltest::temporaryDirectory core-$name]"
+ [file join $tcltest::temporaryDirectory core-$name]"
catch {file rename -force \
- [file join $::tcltest::workingDirectory core] \
- [file join $::tcltest::temporaryDirectory \
- core-$name]} msg
+ [file join [tcltest::workingDirectory] core] \
+ [file join $tcltest::temporaryDirectory \
+ core-$name]} msg
if {[string length $msg] > 0} {
- ::tcltest::PrintError "Problem renaming file: $msg"
+ tcltest::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.
- if {[info exists coreModTime]} {
- if {$coreModTime != [file mtime \
- [file join $::tcltest::workingDirectory core]]} {
- puts $::tcltest::outputChannel "==== $name produced core file!"
+ if {[info exists tcltest::coreModificationTime]} {
+ if {$tcltest::coreModificationTime != [file mtime \
+ [file join [tcltest::workingDirectory] core]]} {
+ puts [outputChannel] "A core file was created!"
}
} else {
- puts $::tcltest::outputChannel "==== $name produced core file!"
+ puts [outputChannel] "A core file was created!"
}
}
}
- array set tcl_platform $currentTclPlatform
}
+ flush [outputChannel]
+ flush [errorChannel]
+ return
}
-# ::tcltest::getMatchingFiles
+#####################################################################
+
+# Procs that determine which tests/test files to run
+
+# 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.
#
# Arguments:
-# none
+# directory to search
#
# Results:
# The constructed list is returned to the user. This will primarily
-# be used in 'all.tcl' files.
+# be used in 'all.tcl' files. It is used in runAllTests.
+#
+# Side Effects:
+# None
-proc ::tcltest::getMatchingFiles {args} {
- set matchingFiles {}
- if {[llength $args]} {
- set searchDirectory $args
- } else {
- set searchDirectory [list $::tcltest::testsDirectory]
+proc tcltest::getMatchingFiles { {searchDirectory ""} } {
+ if {[llength [info level 0]] == 1} {
+ set searchDirectory [tcltest::testsDirectory]
}
+ set matchingFiles {}
+
# Find the matching files in the list of directories and then remove the
# ones that match the skip pattern
foreach directory $searchDirectory {
set matchFileList {}
- foreach match $::tcltest::matchFiles {
+ foreach match $tcltest::matchFiles {
set matchFileList [concat $matchFileList \
[glob -nocomplain [file join $directory $match]]]
}
- if {[string compare {} $::tcltest::skipFiles]} {
+ if {[string compare {} $tcltest::skipFiles]} {
set skipFileList {}
- foreach skip $::tcltest::skipFiles {
+ foreach skip $tcltest::skipFiles {
set skipFileList [concat $skipFileList \
[glob -nocomplain [file join $directory $skip]]]
}
@@ -1597,35 +2857,213 @@ proc ::tcltest::getMatchingFiles {args} {
}
}
if {[string equal $matchingFiles {}]} {
- ::tcltest::PrintError "No test files remain after applying \
+ tcltest::PrintError "No test files remain after applying \
your match and skip patterns!"
}
return $matchingFiles
}
-# The following two procs are used in the io tests.
-
-proc ::tcltest::openfiles {} {
- if {[catch {testchannel open} result]} {
- return {}
+# 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.)
+#
+# 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:
+# None.
+
+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 {
+ foreach file [glob -nocomplain [file join $rootdir $match]] {
+ if {([file isdirectory $file]) && ($file != $rootdir)} {
+ set matchDirList [concat $matchDirList \
+ [tcltest::getMatchingDirectories $file]]
+ if {[file exists [file join $file all.tcl]]} {
+ set matchDirList [concat $matchDirList $file]
+ }
+ }
+ }
}
- return $result
+ if {$tcltest::skipDirectories != {}} {
+ set skipDirs {}
+ foreach skip $tcltest::skipDirectories {
+ set skipDirs [concat $skipDirs \
+ [glob -nocomplain [file join $tcltest::testsDirectory \
+ $skip]]]
+ }
+ foreach dir $matchDirList {
+ # Only include directories that don't match the skip pattern
+ if {[lsearch -exact $skipDirs $dir] == -1} {
+ lappend matchingDirs $dir
+ }
+ }
+ } else {
+ set matchingDirs [concat $matchingDirs $matchDirList]
+ }
+ if {$matchingDirs == {}} {
+ DebugPuts 1 "No test directories remain after applying match and skip patterns!"
+ }
+ return $matchingDirs
}
-proc ::tcltest::leakfiles {old} {
- if {[catch {testchannel open} new]} {
- return {}
+# 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.
+#
+# Arguments:
+# shell being tested
+#
+# Results:
+# None.
+#
+# Side effects:
+# None.
+
+proc tcltest::runAllTests { {shell ""} } {
+ global argv
+
+ if {[llength [info level 0]] == 1} {
+ set shell [tcltest::interpreter]
}
- set leak {}
- foreach p $new {
- if {[lsearch $old $p] < 0} {
- lappend leak $p
+
+ set tcltest::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 {[tcltest::singleProcess]} {
+ puts [outputChannel] "Test files sourced into current interpreter"
+ } else {
+ puts [outputChannel] "Test files run in separate interpreters"
+ }
+ if {[llength $tcltest::skip] > 0} {
+ puts [outputChannel] "Skipping tests that match: $tcltest::skip"
+ }
+ if {[llength $tcltest::match] > 0} {
+ puts [outputChannel] "Only running tests that match: $tcltest::match"
+ }
+
+ if {[llength $tcltest::skipFiles] > 0} {
+ puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles"
+ }
+ if {[llength $tcltest::matchFiles] > 0} {
+ puts [outputChannel] "Only running test files that match: $tcltest::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]] {
+ set tail [file tail $file]
+ puts [outputChannel] $tail
+
+ if {$tcltest::singleProcess} {
+ incr tcltest::numTestFiles
+ uplevel [list source $file]
+ } else {
+ # Change to the tests directory so the value of the following
+ # variable is set correctly when we spawn the child test processes
+ cd $tcltest::testsDirectory
+ set cmd [concat [list | $shell $file] [split $argv]]
+ if {[catch {
+ incr tcltest::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 {$Failed > 0} {
+ lappend tcltest::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
+ }
+ } else {
+ puts [outputChannel] $line
+ }
+ }
+ 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
+ }
}
}
- return $leak
+
+ # cleanup
+ puts [outputChannel] "\nTests ended at [eval $timeCmd]"
+ tcltest::cleanupTests 1
+ if {[info exists testFileFailures]} {
+ puts [outputChannel] "\nTest files exiting with errors: \n"
+ foreach file $testFileFailures {
+ puts " [file tail $file]\n"
+ }
+ }
+
+ # Checking for subdirectories in which to run tests
+ foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] {
+ set dir [file tail $directory]
+ puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
+ puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
+
+ uplevel "source [file join $directory all.tcl]"
+
+ set endTime [eval $timeCmd]
+ puts [outputChannel] "\n$dir test ended at $endTime"
+ puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
+ }
+ return
+}
+
+#####################################################################
+
+# Test utility procs - not used in tcltest, but may be useful for testing.
+
+# tcltest::loadTestedCommands --
+#
+# Uses the specified script to load the commands to test. Allowed to
+# be empty, as the tested commands could have been compiled into the
+# interpreter.
+#
+# Arguments
+# none
+#
+# Results
+# none
+#
+# Side Effects:
+# none.
+
+proc tcltest::loadTestedCommands {} {
+ if {$tcltest::loadScript == {}} {
+ return
+ }
+
+ return [uplevel $tcltest::loadScript]
}
-# ::tcltest::saveState --
+# tcltest::saveState --
#
# Save information regarding what procs and variables exist.
#
@@ -1633,58 +3071,71 @@ proc ::tcltest::leakfiles {old} {
# none
#
# Results:
-# Modifies the variable ::tcltest::saveState
+# Modifies the variable tcltest::saveState
+#
+# Side effects:
+# None.
-proc ::tcltest::saveState {} {
- uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
- DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState"
+proc tcltest::saveState {} {
+ uplevel {set tcltest::saveState [list [info procs] [info vars]]}
+ DebugPuts 2 "tcltest::saveState: $tcltest::saveState"
+ return
}
-# ::tcltest::restoreState --
+# tcltest::restoreState --
#
# Remove procs and variables that didn't exist before the call to
-# ::tcltest::saveState.
+# tcltest::saveState.
#
# Arguments:
# none
#
# Results:
# Removes procs and variables from your environment if they don't exist
-# in the ::tcltest::saveState variable.
+# in the tcltest::saveState variable.
+#
+# Side effects:
+# None.
-proc ::tcltest::restoreState {} {
+proc tcltest::restoreState {} {
foreach p [info procs] {
- if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
- (![string equal ::tcltest::$p [namespace origin $p]])} {
+ if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \
+ (![string match "*tcltest::$p" [namespace origin $p]])} {
- DebugPuts 2 "::tcltest::restoreState: Removing proc $p"
+ DebugPuts 2 "tcltest::restoreState: Removing proc $p"
rename $p {}
}
}
- foreach p [uplevel #0 {info vars}] {
- if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
- DebugPuts 2 "::tcltest::restoreState: Removing variable $p"
- uplevel #0 "catch {unset $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}"
}
}
+ return
}
-# ::tcltest::normalizeMsg --
+# tcltest::normalizeMsg --
#
# Removes "extra" newlines from a string.
#
# Arguments:
# msg String to be modified
#
+# Results:
+# string with extra newlines removed
+#
+# Side effects:
+# None.
-proc ::tcltest::normalizeMsg {msg} {
+proc tcltest::normalizeMsg {msg} {
regsub "\n$" [string tolower $msg] "" msg
regsub -all "\n\n" $msg "\n" msg
regsub -all "\n\}" $msg "\}" msg
return $msg
}
-# makeFile --
+# tcltest::makeFile --
#
# Create a new file with the name <name>, and write <contents> to it.
#
@@ -1692,12 +3143,28 @@ proc ::tcltest::normalizeMsg {msg} {
# cleanupTests was called, add it to the $filesMade list, so it will
# be removed by the next call to cleanupTests.
#
-proc ::tcltest::makeFile {contents name} {
+# Arguments:
+# contents content of the new file
+# name name of the new file
+# directory directory name for new file
+#
+# Results:
+# absolute path to the file created
+#
+# Side effects:
+# None.
+
+proc tcltest::makeFile {contents name {directory ""}} {
global tcl_platform
+
+ if {[llength [info level 0]] == 3} {
+ set directory [tcltest::temporaryDirectory]
+ }
- DebugPuts 3 "::tcltest::makeFile: putting $contents into $name"
+ set fullName [file join $directory $name]
+
+ DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName"
- set fullName [file join $::tcltest::temporaryDirectory $name]
set fd [open $fullName w]
fconfigure $fd -translation lf
@@ -1709,26 +3176,36 @@ proc ::tcltest::makeFile {contents name} {
}
close $fd
- if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
- lappend ::tcltest::filesMade $fullName
+ if {[lsearch -exact $tcltest::filesMade $fullName] == -1} {
+ lappend tcltest::filesMade $fullName
}
return $fullName
}
-# ::tcltest::removeFile --
+# tcltest::removeFile --
#
# Removes the named file from the filesystem
#
# Arguments:
-# name file to be removed
+# name file to be removed
+# directory directory from which to remove file
#
+# Results:
+# return value from [file delete]
+#
+# Side effects:
+# None.
-proc ::tcltest::removeFile {name} {
- DebugPuts 3 "::tcltest::removeFile: removing $name"
- file delete [file join $::tcltest::temporaryDirectory $name]
+proc tcltest::removeFile {name {directory ""}} {
+ if {[llength [info level 0]] == 2} {
+ set directory [tcltest::temporaryDirectory]
+ }
+ set fullName [file join $directory $name]
+ DebugPuts 3 "tcltest::removeFile: removing $fullName"
+ return [file delete $fullName]
}
-# makeDirectory --
+# tcltest::makeDirectory --
#
# Create a new dir with the name <name>.
#
@@ -1736,75 +3213,85 @@ proc ::tcltest::removeFile {name} {
# cleanupTests was called, add it to the $directoriesMade list, so it will
# be removed by the next call to cleanupTests.
#
-proc ::tcltest::makeDirectory {name} {
- file mkdir $name
+# Arguments:
+# name name of the new directory
+# directory directory in which to create new dir
+#
+# Results:
+# absolute path to the directory created
+#
+# Side effects:
+# None.
- set fullName [file join [pwd] $name]
- if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
- lappend ::tcltest::filesMade $fullName
+proc tcltest::makeDirectory {name {directory ""}} {
+ if {[llength [info level 0]] == 2} {
+ set directory [tcltest::temporaryDirectory]
}
+ set fullName [file join $directory $name]
+ DebugPuts 3 "tcltest::makeDirectory: creating $fullName"
+ file mkdir $fullName
+ if {[lsearch -exact $tcltest::filesMade $fullName] == -1} {
+ lappend tcltest::filesMade $fullName
+ }
+ return $fullName
}
-# ::tcltest::removeDirectory --
+# tcltest::removeDirectory --
#
# Removes a named directory from the file system.
#
# Arguments:
-# name Name of the directory to remove
+# name Name of the directory to remove
+# directory Directory from which to remove
#
+# Results:
+# return value from [file delete]
+#
+# Side effects:
+# None
-proc ::tcltest::removeDirectory {name} {
- file delete -force $name
-}
-
-proc ::tcltest::viewFile {name} {
- global tcl_platform
- if {([string equal $tcl_platform(platform) "macintosh"]) || \
- ($::tcltest::testConstraints(unixExecs) == 0)} {
- set f [open [file join $::tcltest::temporaryDirectory $name]]
- set data [read -nonewline $f]
- close $f
- return $data
- } else {
- exec cat [file join $::tcltest::temporaryDirectory $name]
+proc tcltest::removeDirectory {name {directory ""}} {
+ if {[llength [info level 0]] == 2} {
+ set directory [tcltest::temporaryDirectory]
}
+ set fullName [file join $directory $name]
+ DebugPuts 3 "tcltest::removeDirectory: deleting $fullName"
+ return [file delete -force $fullName]
}
-# grep --
+# tcltest::viewFile --
#
-# Evaluate a given expression against each element of a list and return all
-# elements for which the expression evaluates to true. For the purposes of
-# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the
-# value of the current element within the expression. This is equivalent to
-# the perl grep command where CURRENT_ELEMENT would be the name for the special
-# variable $_.
+# reads the content of a file and returns it
#
-# Examples of usage would be:
-# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers]
-# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings]
+# Arguments:
+# name of the file to read
+# directory in which file is located
#
-# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is
-# assumed to be the final argument to the expression provided.
-#
-# Example:
-# grep {regexp a} $someList
+# Results:
+# content of the named file
#
-proc ::tcltest::grep { expression searchList } {
- foreach element $searchList {
- if {[regsub -all CURRENT_ELEMENT $expression $element \
- newExpression] == 0} {
- set newExpression "$expression {$element}"
- }
- if {[eval $newExpression] == 1} {
- lappend returnList $element
- }
+# Side effects:
+# None.
+
+proc tcltest::viewFile {name {directory ""}} {
+ global tcl_platform
+ if {[llength [info level 0]] == 2} {
+ set directory [tcltest::temporaryDirectory]
}
- if {[info exists returnList]} {
- return $returnList
+ set fullName [file join $directory $name]
+ if {([string equal $tcl_platform(platform) "macintosh"]) || \
+ ([tcltest::testConstraint unixExecs] == 0)} {
+ set f [open $fullName]
+ set data [read -nonewline $f]
+ close $f
+ return $data
+ } else {
+ return [exec cat $fullName]
}
return
}
+# tcltest::bytestring --
#
# Construct a string that consists of the requested sequence of bytes,
# as opposed to a string of properly formed UTF-8 characters.
@@ -1818,30 +3305,112 @@ proc ::tcltest::grep { expression searchList } {
# 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
# exposing that Tcl uses UTF-8 internally.
+#
+# Arguments:
+# string being converted
+#
+# Results:
+# result fom encoding
+#
+# Side effects:
+# None
+
+proc tcltest::bytestring {string} {
+ return [encoding convertfrom identity $string]
+}
+
+# tcltest::openfiles --
+#
+# used in io tests, uses testchannel
+#
+# Arguments:
+# None.
+#
+# Results:
+# ???
+#
+# Side effects:
+# None.
-proc ::tcltest::bytestring {string} {
- encoding convertfrom identity $string
+proc tcltest::openfiles {} {
+ if {[catch {testchannel open} result]} {
+ return {}
+ }
+ return $result
+}
+
+# tcltest::leakfiles --
+#
+# used in io tests, uses testchannel
+#
+# Arguments:
+# None.
+#
+# Results:
+# ???
+#
+# Side effects:
+# None.
+
+proc tcltest::leakfiles {old} {
+ if {[catch {testchannel open} new]} {
+ return {}
+ }
+ set leak {}
+ foreach p $new {
+ if {[lsearch $old $p] < 0} {
+ lappend leak $p
+ }
+ }
+ return $leak
}
#
# Internationalization / ISO support procs -- dl
#
-proc ::tcltest::set_iso8859_1_locale {} {
+
+# tcltest::set_iso8859_1_locale --
+#
+# used in cmdIL.test, uses testlocale
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+#
+# Side effects:
+# None.
+
+proc tcltest::set_iso8859_1_locale {} {
if {[info commands testlocale] != ""} {
- set ::tcltest::previousLocale [testlocale ctype]
- testlocale ctype $::tcltest::isoLocale
+ set tcltest::previousLocale [testlocale ctype]
+ testlocale ctype $tcltest::isoLocale
}
return
}
-proc ::tcltest::restore_locale {} {
+# tcltest::restore_locale --
+#
+# used in cmdIL.test, uses testlocale
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+#
+# Side effects:
+# None.
+
+proc tcltest::restore_locale {} {
if {[info commands testlocale] != ""} {
- testlocale ctype $::tcltest::previousLocale
+ testlocale ctype $tcltest::previousLocale
}
return
}
-# threadReap --
+# tcltest::threadReap --
#
# Kill all threads except for the main thread.
# Do nothing if testthread is not defined.
@@ -1851,7 +3420,12 @@ proc ::tcltest::restore_locale {} {
#
# Results:
# Returns the number of existing threads.
-proc ::tcltest::threadReap {} {
+#
+# Side Effects:
+# none.
+#
+
+proc tcltest::threadReap {} {
if {[info commands testthread] != {}} {
# testthread built into tcltest
@@ -1859,7 +3433,7 @@ proc ::tcltest::threadReap {} {
testthread errorproc ThreadNullError
while {[llength [testthread names]] > 1} {
foreach tid [testthread names] {
- if {$tid != $::tcltest::mainThread} {
+ if {$tid != $tcltest::mainThread} {
catch {testthread send -async $tid {testthread exit}}
}
}
@@ -1877,7 +3451,7 @@ proc ::tcltest::threadReap {} {
thread::errorproc ThreadNullError
while {[llength [thread::names]] > 1} {
foreach tid [thread::names] {
- if {$tid != $::tcltest::mainThread} {
+ if {$tid != $tcltest::mainThread} {
catch {thread::send -async $tid {thread::exit}}
}
}
@@ -1891,6 +3465,7 @@ proc ::tcltest::threadReap {} {
} else {
return 1
}
+ return 0
}
# Initialize the constraints and set up command line arguments
@@ -1898,8 +3473,18 @@ namespace eval tcltest {
# Ensure that we have a minimal auto_path so we don't pick up extra junk.
set ::auto_path [list [info library]]
- ::tcltest::initConstraints
- if {[namespace children ::tcltest] == {}} {
- ::tcltest::processCmdLineArgs
+ tcltest::initConstraints
+ if {[namespace children [namespace current]] == {}} {
+ tcltest::processCmdLineArgs
+ }
+
+ # Save the names of files that already exist in
+ # the output directory.
+ foreach file [glob -nocomplain \
+ [file join $tcltest::temporaryDirectory *]] {
+ lappend tcltest::filesExisted [file tail $file]
}
}
+
+package provide tcltest 2.0
+