summaryrefslogtreecommitdiffstats
path: root/library/tcltest1.0
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/tcltest1.0
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/tcltest1.0')
-rw-r--r--library/tcltest1.0/pkgIndex.tcl3
-rw-r--r--library/tcltest1.0/tcltest.tcl3227
-rwxr-xr-xlibrary/tcltest1.0/tcltest2.tcl3490
3 files changed, 2407 insertions, 4313 deletions
diff --git a/library/tcltest1.0/pkgIndex.tcl b/library/tcltest1.0/pkgIndex.tcl
index e3746e2..da93644 100644
--- a/library/tcltest1.0/pkgIndex.tcl
+++ b/library/tcltest1.0/pkgIndex.tcl
@@ -8,5 +8,4 @@
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-package ifneeded tcltest 1.0 [list source [file join $dir tcltest.tcl]]
-package ifneeded tcltest 2.0 [list source [file join $dir tcltest2.tcl]]
+package ifneeded tcltest 2.0 [list source [file join $dir tcltest.tcl]]
diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl
index 63639e3..80f80c7 100644
--- a/library/tcltest1.0/tcltest.tcl
+++ b/library/tcltest1.0/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
+
diff --git a/library/tcltest1.0/tcltest2.tcl b/library/tcltest1.0/tcltest2.tcl
deleted file mode 100755
index c05732d..0000000
--- a/library/tcltest1.0/tcltest2.tcl
+++ /dev/null
@@ -1,3490 +0,0 @@
-# tcltest.tcl --
-#
-# This file contains support code for the Tcl test suite. It
-# defines the tcltest namespace and finds and defines the output
-# directory, constraints available, output and error channels, etc. used
-# by Tcl tests. See the tcltest man page for more details.
-#
-# This design was based on the Tcl testing approach designed and
-# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
-#
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# Copyright (c) 2000 by Ajuba Solutions
-# All rights reserved.
-#
-# RCS: @(#) $Id: tcltest2.tcl,v 1.4 2000/10/19 18:00:58 jenn Exp $
-
-# create the "tcltest" namespace for all testing variables and procedures
-
-namespace eval tcltest {
-
- # Export the public tcltest procs
- set procList [list test cleanupTests saveState restoreState \
- normalizeMsg makeFile removeFile makeDirectory removeDirectory \
- 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 {body}
- if {![info exists verbose]} {
- variable verbose {body}
- }
-
- # Match and skip patterns default to the empty list, except for
- # matchFiles, which defaults to all .test files in the testsDirectory and
- # matchDirectories, which defaults to all directories.
-
- if {![info exists match]} {
- variable match {}
- }
- if {![info exists skip]} {
- variable skip {}
- }
- if {![info exists matchFiles]} {
- variable matchFiles {*.test}
- }
- 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]} {
- variable preserveCore 0
- }
-
- # output goes to stdout by default
- 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
- # specifically skipped. A debug level of 2 would spit up the tcltest
- # variables and flags provided; a debug level of 3 causes some additional
- # output regarding operations of the test harness. The tcltest package
- # currently implements only up to debug level 3.
- if {![info exists debug]} {
- variable debug 0
- }
-
- # Save any arguments that we might want to pass through to other programs.
- # This is used by the -args flag.
- if {![info exists parameters]} {
- variable parameters {}
- }
-
- # 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.
-
- if {![info exists numTestFiles]} {
- variable numTestFiles 0
- }
- if {![info exists testSingleFile]} {
- variable testSingleFile true
- }
- if {![info exists currentFailure]} {
- variable currentFailure false
- }
- if {![info exists failFiles]} {
- variable failFiles {}
- }
-
- # 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.
-
- if {![info exists filesMade]} {
- variable filesMade {}
- }
- if {![info exists filesExisted]} {
- variable filesExisted {}
- }
-
- # tcltest::numTests will store test files as indices and the list
- # of files (that should not have been) left behind by the test files.
-
- if {![info exists createdNewFiles]} {
- variable createdNewFiles
- array set tcltest::createdNewFiles {}
- }
-
- # 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 \
- [list Total 0 Passed 0 Skipped 0 Failed 0]
- }
-
- # initialize tcltest::skippedBecause array to keep track of
- # constraints that kept tests from running; a constraint name of
- # "userSpecifiedSkip" means that the test appeared on the list of tests
- # that matched the -skip value given to the flag; "userSpecifiedNonMatch"
- # means that the test didn't match the argument given to the -match flag;
- # both of these constraints are counted only if tcltest::debug is set to
- # true.
-
- if {![info exists skippedBecause]} {
- variable skippedBecause
- array set tcltest::skippedBecause {}
- }
-
- # initialize the tcltest::testConstraints array to keep track of valid
- # predefined constraints (see the explanation for the
- # tcltest::initConstraints proc for more details).
-
- if {![info exists testConstraints]} {
- variable testConstraints
- array set tcltest::testConstraints {}
- }
-
- if {![info exists constraintsSpecified]} {
- variable constraintsSpecified {}
- }
-
- # Don't run only the constrained tests by default
-
- if {![info exists limitConstraints]} {
- variable limitConstraints false
- }
-
- # A test application has to know how to load the tested commands into
- # the interpreter.
-
- if {![info exists loadScript]} {
- 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]} {
- variable mainThread 1
- if {[info commands thread::id] != {}} {
- set mainThread [thread::id]
- } elseif {[info commands testthread] != {}} {
- set mainThread [testthread id]
- }
- }
-
- # save the original environment so that it can be restored later
-
- if {![info exists originalEnv]} {
- variable originalEnv
- array set tcltest::originalEnv [array get ::env]
- }
-
- # Set tcltest::workingDirectory to [pwd]. The default output directory
- # for Tcl tests is the working directory.
-
- if {![info exists workingDirectory]} {
- variable workingDirectory [pwd]
- }
- if {![info exists temporaryDirectory]} {
- variable temporaryDirectory $workingDirectory
- }
-
- # Tests should not rely on the current working directory.
- # Files that are part of the test suite should be accessed relative to
- # tcltest::testsDirectory.
-
- if {![info exists testsDirectory]} {
- set oldpwd [pwd]
- catch {cd [file join [file dirname [info script]] .. .. tests]}
- variable testsDirectory [pwd]
- cd $oldpwd
- unset oldpwd
- }
-
- # 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 -- 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) {
- "unix" {
-
- # Try some 'known' values for some platforms:
-
- switch -exact -- $tcl_platform(os) {
- "FreeBSD" {
- set tcltest::isoLocale fr_FR.ISO_8859-1
- }
- HP-UX {
- set tcltest::isoLocale fr_FR.iso88591
- }
- Linux -
- IRIX {
- set tcltest::isoLocale fr
- }
- default {
-
- # Works on SunOS 4 and Solaris, and maybe others...
- # define it to something else on your system
- #if you want to test those.
-
- set tcltest::isoLocale iso_8859_1
- }
- }
- }
- "windows" {
- set tcltest::isoLocale French
- }
- }
- }
-
- # 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]} {
- variable originalTclPlatform [array get tcl_platform]
- }
-
- # If a core file exists, save its modification time.
- if {![info exists coreModificationTime]} {
- if {[file exists [file join $tcltest::workingDirectory core]]} {
- variable coreModificationTime [file mtime [file join \
- $tcltest::workingDirectory core]]
- }
- }
-
- # stdout and stderr buffers for use when we want to store them
- if {![info exists outData]} {
- variable outData {}
- }
- if {![info exists errData]} {
- variable errData {}
- }
-
- # keep track of test level for nested test commands
- variable testLevel 0
-}
-
-#####################################################################
-
-# 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 --
-#
-# Prints the specified string if the current debug level is
-# higher than the provided level argument.
-#
-# Arguments:
-# level The lowest debug level triggering the output
-# string The string to print out.
-#
-# Results:
-# Prints the string. Nothing else is allowed.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::DebugPuts {level string} {
- variable debug
- if {$debug >= $level} {
- puts $string
- }
- return
-}
-
-# tcltest::DebugPArray --
-#
-# Prints the contents of the specified array if the current
-# debug level is higher than the provided level argument
-#
-# Arguments:
-# level The lowest debug level triggering the output
-# arrayvar The name of the array to print out.
-#
-# Results:
-# Prints the contents of the array. Nothing else is allowed.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::DebugPArray {level arrayvar} {
- variable debug
-
- if {$debug >= $level} {
- catch {upvar $arrayvar $arrayvar}
- parray $arrayvar
- }
- return
-}
-
-# tcltest::DebugDo --
-#
-# Executes the script if the current debug level is greater than
-# the provided level argument
-#
-# Arguments:
-# level The lowest debug level triggering the execution.
-# script The tcl script executed upon a debug level high enough.
-#
-# Results:
-# Arbitrary side effects, dependent on the executed script.
-#
-# Side Effects:
-# None.
-#
-
-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 --
-#
-# Increments the variable used to track how many tests were skipped
-# because of a particular constraint.
-#
-# Arguments:
-# constraint The name of the constraint to be modified
-#
-# Results:
-# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't
-# previously exist - otherwise, it just increments it.
-#
-# Side effects:
-# None.
-
-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) $value
- } else {
- set tcltest::skippedBecause($constraint) $value
- }
- return
-}
-
-# tcltest::PrintError --
-#
-# 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} {
- set InitialMessage "Error: "
- set InitialMsgLen [string length $InitialMessage]
- puts -nonewline [errorChannel] $InitialMessage
-
- # Keep track of where the end of the string is.
- set endingIndex [string length $errorMsg]
-
- if {$endingIndex < 80} {
- 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 [errorChannel] [string range $errorMsg 0 $beginningIndex]
-
- while {$beginningIndex != "end"} {
- puts -nonewline [errorChannel] \
- [string repeat " " $InitialMsgLen]
- if {[expr {$endingIndex - $beginningIndex}] < 72} {
- puts [errorChannel] [string trim \
- [string range $errorMsg $beginningIndex end]]
- set beginningIndex end
- } else {
- set newEndingIndex [expr [string last " " [string range \
- $errorMsg $beginningIndex \
- [expr {$beginningIndex + 72}]]] + $beginningIndex]
- if {($newEndingIndex <= 0) \
- || ($newEndingIndex <= $beginningIndex)} {
- set newEndingIndex end
- }
- puts [errorChannel] [string trim \
- [string range $errorMsg \
- $beginningIndex $newEndingIndex]]
- set beginningIndex $newEndingIndex
- }
- }
- }
- flush [errorChannel]
- return
-}
-
-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 --
-#
-# Check constraint information that will determine which tests
-# to run. To do this, create an array tcltest::testConstraints. Each
-# element has a 0 or 1 value. If the element is "true" then tests
-# with that constraint will be run, otherwise tests with that constraint
-# will be skipped. See the tcltest man page for the list of built-in
-# constraints defined in this procedure.
-#
-# Arguments:
-# none
-#
-# Results:
-# The tcltest::testConstraints array is reset to have an index for
-# each built-in test constraint.
-#
-# Side Effects:
-# None.
-#
-
-proc tcltest::initConstraints {} {
- global tcl_platform tcl_interactive tk_version
-
- # Safely refer to non-existent members of the tcltest::testConstraints
- # array without causing an error.
- trace variable tcltest::testConstraints r tcltest::safeFetch
-
- tcltest::initConstraintsHook
-
- tcltest::testConstraint singleTestInterp [singleProcess]
-
- # All the 'pc' constraints are here for backward compatibility and are not
- # documented. They have been replaced with equivalent 'win' constraints.
-
- tcltest::testConstraint unixOnly \
- [string equal $tcl_platform(platform) "unix"]
- tcltest::testConstraint macOnly \
- [string equal $tcl_platform(platform) "macintosh"]
- tcltest::testConstraint pcOnly \
- [string equal $tcl_platform(platform) "windows"]
- tcltest::testConstraint winOnly \
- [string equal $tcl_platform(platform) "windows"]
-
- tcltest::testConstraint unix [tcltest::testConstraint unixOnly]
- tcltest::testConstraint mac [tcltest::testConstraint macOnly]
- tcltest::testConstraint pc [tcltest::testConstraint pcOnly]
- tcltest::testConstraint win [tcltest::testConstraint winOnly]
-
- tcltest::testConstraint unixOrPc \
- [expr {[tcltest::testConstraint unix] \
- || [tcltest::testConstraint pc]}]
- tcltest::testConstraint macOrPc \
- [expr {[tcltest::testConstraint mac] \
- || [tcltest::testConstraint pc]}]
- tcltest::testConstraint unixOrWin \
- [expr {[tcltest::testConstraint unix] \
- || [tcltest::testConstraint win]}]
- tcltest::testConstraint macOrWin \
- [expr {[tcltest::testConstraint mac] \
- || [tcltest::testConstraint win]}]
- tcltest::testConstraint macOrUnix \
- [expr {[tcltest::testConstraint mac] \
- || [tcltest::testConstraint unix]}]
-
- tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"]
- tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"]
- tcltest::testConstraint 98 [string equal $tcl_platform(os) "Windows 98"]
-
- # The following Constraints switches are used to mark tests that should
- # work, but have been temporarily disabled on certain platforms because
- # they don't and we haven't gotten around to fixing the underlying
- # problem.
-
- tcltest::testConstraint tempNotPc \
- [expr {![tcltest::testConstraint pc]}]
- tcltest::testConstraint tempNotWin \
- [expr {![tcltest::testConstraint win]}]
- tcltest::testConstraint tempNotMac \
- [expr {![tcltest::testConstraint mac]}]
- tcltest::testConstraint tempNotUnix \
- [expr {![tcltest::testConstraint unix]}]
-
- # The following Constraints switches are used to mark tests that crash on
- # certain platforms, so that they can be reactivated again when the
- # underlying problem is fixed.
-
- tcltest::testConstraint pcCrash \
- [expr {![tcltest::testConstraint pc]}]
- tcltest::testConstraint winCrash \
- [expr {![tcltest::testConstraint win]}]
- tcltest::testConstraint macCrash \
- [expr {![tcltest::testConstraint mac]}]
- tcltest::testConstraint unixCrash \
- [expr {![tcltest::testConstraint unix]}]
-
- # Skip empty tests
-
- tcltest::testConstraint emptyTest 0
-
- # By default, tests that expose known bugs are skipped.
-
- tcltest::testConstraint knownBug 0
-
- # By default, non-portable tests are skipped.
-
- tcltest::testConstraint nonPortable 0
-
- # Some tests require user interaction.
-
- tcltest::testConstraint userInteraction 0
-
- # Some tests must be skipped if the interpreter is not in interactive mode
-
- if {[info exists tcl_interactive]} {
- tcltest::testConstraint interactive $::tcl_interactive
- } else {
- tcltest::testConstraint interactive 0
- }
-
- # Some tests can only be run if the installation came from a CD image
- # instead of a web image
- # Some tests must be skipped if you are running as root on Unix.
- # Other tests can only be run if you are running as root on Unix.
-
- tcltest::testConstraint root 0
- tcltest::testConstraint notRoot 1
- set user {}
- if {[string equal $tcl_platform(platform) "unix"]} {
- catch {set user [exec whoami]}
- if {[string equal $user ""]} {
- catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
- }
- if {([string equal $user "root"]) || ([string equal $user ""])} {
- tcltest::testConstraint root 1
- tcltest::testConstraint notRoot 0
- }
- }
-
- # Set nonBlockFiles constraint: 1 means this platform supports
- # ting files into nonblocking mode.
-
- if {[catch {set f [open defs r]}]} {
- tcltest::testConstraint nonBlockFiles 1
- } else {
- if {[catch {fconfigure $f -blocking off}] == 0} {
- tcltest::testConstraint nonBlockFiles 1
- } else {
- tcltest::testConstraint nonBlockFiles 0
- }
- close $f
- }
-
- # Set asyncPipeClose constraint: 1 means this platform supports
- # async flush and async close on a pipe.
- #
- # Test for SCO Unix - cannot run async flushing tests because a
- # potential problem with select is apparently interfering.
- # (Mark Diekhans).
-
- if {[string equal $tcl_platform(platform) "unix"]} {
- if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
- tcltest::testConstraint asyncPipeClose 0
- } else {
- tcltest::testConstraint asyncPipeClose 1
- }
- } else {
- 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.
-
- tcltest::testConstraint eformat 1
- if {![string equal "[format %g 5e-5]" "5e-05"]} {
- tcltest::testConstraint eformat 0
- }
-
- # Test to see if execed commands such as cat, echo, rm and so forth are
- # present on this machine.
-
- tcltest::testConstraint unixExecs 1
- if {[string equal $tcl_platform(platform) "macintosh"]} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([string equal $tcl_platform(platform) "windows"])} {
- if {[catch {exec cat defs}] == 1} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec echo hello}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec sh -c echo hello}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec wc defs}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {[tcltest::testConstraint unixExecs] == 1} {
- exec echo hello > removeMe
- if {[catch {exec rm removeMe}] == 1} {
- tcltest::testConstraint unixExecs 0
- }
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec sleep 1}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec fgrep unixExecs defs}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec ps}] == 1)} {
- tcltest::testConstraint unixExecs 0
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec echo abc > removeMe}] == 0) && \
- ([catch {exec chmod 644 removeMe}] == 1) && \
- ([catch {exec rm removeMe}] == 0)} {
- tcltest::testConstraint unixExecs 0
- } else {
- catch {exec rm -f removeMe}
- }
- if {([tcltest::testConstraint unixExecs] == 1) && \
- ([catch {exec mkdir removeMe}] == 1)} {
- tcltest::testConstraint unixExecs 0
- } else {
- catch {exec rm -r removeMe}
- }
- }
-
- # Locate tcltest executable
-
- if {![info exists tk_version]} {
- set tcltest::tcltest [info nameofexecutable]
-
- if {$tcltest::tcltest == "{}"} {
- set tcltest::tcltest {}
- }
- }
-
- tcltest::testConstraint stdio 0
- catch {
- catch {file delete -force tmp}
- set f [open tmp w]
- puts $f {
- exit
- }
- close $f
-
- set f [open "|[list $tcltest tmp]" r]
- close $f
-
- tcltest::testConstraint stdio 1
- }
- catch {file delete -force tmp}
-
- # Deliberately call socket with the wrong number of arguments. The error
- # message you get will indicate whether sockets are available on this
- # system.
-
- catch {socket} msg
- tcltest::testConstraint socket \
- [expr {$msg != "sockets are not available on this system"}]
-
- # Check for internationalization
-
- if {[info commands testlocale] == ""} {
- # No testlocale command, no tests...
- tcltest::testConstraint hasIsoLocale 0
- } else {
- tcltest::testConstraint hasIsoLocale \
- [string length [tcltest::set_iso8859_1_locale]]
- tcltest::restore_locale
- }
-}
-
-#####################################################################
-
-# 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 {} {}
-}
-
-# tcltest::PrintUsageInfo
-#
-# Prints out the usage information for package tcltest. This can be
-# customized with the redefinition of tcltest::PrintUsageInfoHook.
-#
-# Arguments:
-# none
-#
-# Results:
-# none
-#
-# Side Effects:
-# none
-
-proc tcltest::PrintUsageInfo {} {
- puts [format "Usage: [file tail [info nameofexecutable]] \
- script ?-help? ?flag value? ... \n\
- Available flags (and valid input values) are: \n\
- -help \t Display this usage information. \n\
- -verbose level \t Takes any combination of the values \n\
- \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\
- \t display all passed tests if 'p' is \n\
- \t specified, all skipped tests if 's' \n\
- \t is specified, the bodies of \n\
- \t failed tests if 'b' is specified, \n\
- \t and when tests start if 't' is specified. \n\
- \t ErrorInfo is displayed if 'e' is specified. \n\
- \t The default value is 'b'. \n\
- -constraints list\t Do not skip the listed constraints\n\
- -limitconstraints bool\t Only run tests with the constraints\n\
- \t listed in -constraints.\n\
- -match pattern \t Run all tests within the specified \n\
- \t files that match the glob pattern \n\
- \t given. \n\
- -skip pattern \t Skip all tests within the set of \n\
- \t specified tests (via -match) and \n\
- \t files that match the glob pattern \n\
- \t given. \n\
- -file pattern \t Run tests in all test files that \n\
- \t match the glob pattern given. \n\
- -notfile pattern\t Skip all test files that match the \n\
- \t glob pattern given. \n\
- -relateddir pattern\t Run tests in directories that match \n\
- \t the glob pattern given. \n\
- -asidefromdir pattern\t Skip tests in directories that match \n\
- \t the glob pattern given.\n\
- -preservecore level \t If 2, save any core files produced \n\
- \t during testing in the directory \n\
- \t specified by -tmpdir. If 1, notify the\n\
- \t user if core files are created. The default \n\
- \t is $tcltest::preserveCore. \n\
- -tmpdir directory\t Save temporary files in the specified\n\
- \t directory. The default value is \n\
- \t $tcltest::temporaryDirectory. \n\
- -testdir directories\t Search tests in the specified\n\
- \t directories. The default value is \n\
- \t $tcltest::testsDirectory. \n\
- -outfile file \t Send output from test runs to the \n\
- \t specified file. The default is \n\
- \t stdout. \n\
- -errfile file \t Send errors from test runs to the \n\
- \t specified file. The default is \n\
- \t stderr. \n\
- -loadfile file \t Read the script to load the tested \n\
- \t commands from the specified file. \n\
- -load script \t Specifies the script to load the tested \n\
- \t commands. \n\
- -debug level \t Internal debug flag."]
- tcltest::PrintUsageInfoHook
- return
-}
-
-# tcltest::processCmdLineArgsFlagsHook --
-#
-# This hook is used to add to the list of command line arguments that are
-# processed by tcltest::ProcessFlags. It is called at the beginning of
-# ProcessFlags.
-#
-
-if {[namespace inscope tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
- proc tcltest::processCmdLineArgsAddFlagsHook {} {}
-}
-
-# tcltest::processCmdLineArgsHook --
-#
-# This hook is used to actually process the flags added by
-# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of
-# ProcessFlags.
-#
-# Arguments:
-# flags The flags that have been pulled out of argv
-#
-
-if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} {
- proc tcltest::processCmdLineArgsHook {flag} {}
-}
-
-# tcltest::ProcessFlags --
-#
-# process command line arguments supplied in the flagArray - this is
-# called by processCmdLineArgs
-# modifies tcltest variables according to the content of the flagArray.
-#
-# Arguments:
-# flagArray - array containing name/value pairs of flags
-#
-# Results:
-# 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} {
- 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 -testdir \
- -load -loadfile -asidefromdir \
- -relateddir -singleproc
- set defaultFlags [concat $defaultFlags \
- [tcltest::processCmdLineArgsAddFlagsHook ]]
-
- # Set tcltest::verbose to the arg of the -verbose flag, if given
- if {[info exists flag(-verbose)]} {
- tcltest::verbose $flag(-verbose)
- }
-
- # Set tcltest::match to the arg of the -match flag, if given.
- if {[info exists flag(-match)]} {
- tcltest::match $flag(-match)
- }
-
- # Set tcltest::skip to the arg of the -skip flag, if given
- if {[info exists flag(-skip)]} {
- tcltest::skip $flag(-skip)
- }
-
- # Handle the -file and -notfile flags
- if {[info exists flag(-file)]} {
- tcltest::matchFiles $flag(-file)
- }
- if {[info exists 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
- # turned off by default: userInteractive knownBug nonPortable. This
- # code fragment must be run after constraints are initialized.
-
- if {[info exists flag(-constraints)]} {
- foreach elt $flag(-constraints) {
- tcltest::testConstraint $elt 1
- }
- }
-
- # Use the -limitconstraints flag, if given, to tell the harness to limit
- # tests run to those that were specified using the -constraints flag. If
- # the -constraints flag was not specified, print out an error and exit.
- if {[info exists flag(-limitconstraints)]} {
- if {![info exists flag(-constraints)]} {
- set msg "-limitconstraints flag can only be used with -constraints"
- error $msg
- }
- tcltest::limitConstraints $flag(-limitconstraints)
- }
-
- # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if
- # given.
-
- if {[info exists flag(-tmpdir)]} {
- tcltest::temporaryDirectory $flag(-tmpdir)
- }
-
- # Set the tcltest::testsDirectory to the arg of -testdir, if
- # given.
-
- if {[info exists flag(-testdir)]} {
- tcltest::testsDirectory $flag(-testdir)
- }
-
- # If an alternate error or output files are specified, change the
- # default channels.
-
- if {[info exists flag(-outfile)]} {
- tcltest::outputFile $flag(-outfile)
- }
-
- if {[info exists flag(-errfile)]} {
- tcltest::errorFile $flag(-errfile)
- }
-
- # If a load script was specified, either directly or through
- # a file, remember it for later usage.
-
- if {[info exists flag(-load)] && \
- ([lsearch -exact $flagArray -load] > \
- [lsearch -exact $flagArray -loadfile])} {
- tcltest::loadScript $flag(-load)
- }
-
- if {[info exists flag(-loadfile)] && \
- ([lsearch -exact $flagArray -loadfile] > \
- [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)]} {
- tcltest::debug $flag(-debug)
- }
-
- # Handle -preservecore
- if {[info exists 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]
- return
-}
-
-# 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
-
- # 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
- return
-}
-
-#####################################################################
-
-# Code to run the tests goes here.
-
-# tcltest::testPuts --
-#
-# Used to redefine puts in test environment.
-# Stores whatever goes out on stdout in tcltest::outData and stderr in
-# tcltest::errData before sending it on to the regular puts.
-#
-# Arguments:
-# same as standard puts
-#
-# 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]
- }
- }
-
- 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]]
- }
-
- # 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::testEval --
-#
-# 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.
-#
-# Arguments:
-# script Script to evaluate
-# ?ignoreOutput? Indicates whether or not to ignore output sent to
-# stdout & stderr
-#
-# Results:
-# result from running the script
-#
-# Side effects:
-# Empties the contents of tcltest::outData and tcltest::errData before
-# running a test if ignoreOutput is set to 0.
-
-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
-}
-
-# 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.
-
-proc tcltest::compareStrings {actual expected mode} {
- switch -- $mode {
- exact {
- set retval [string equal $actual $expected]
- }
- glob {
- set retval [string match $expected $actual]
- }
- regexp {
- set retval [regexp -- $expected $actual]
- }
- }
- return $retval
-}
-
-
-#
-# 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 {}
- }
- }
-
- # If the last token has not been added to the list then there
- # is a problem.
- if { [string length $token] } {
- error "incomplete token \"$token\""
- }
-
- return $result
-}
-
-
-# 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.
-#
-
-proc tcltest::test {name description args} {
- DebugPuts 3 "Test $name $args"
-
- incr tcltest::testLevel
-
- # Pre-define everything to null except output and errorOutput. We
- # determine whether or not to trap output based on whether or not these
- # variables (output & errorOutput) are defined.
- foreach item {constraints setup cleanup body result returnCodes match} {
- 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
- }
-
- set validFlags {-setup -cleanup -body -result -returnCodes -match \
- -output -errorOutput -constraints}
-
- foreach flag [array names testAttributes] {
- if {[lsearch -exact $validFlags $flag] == -1} {
- puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test"
- incr tcltest::testLevel -1
- return 1
- }
- }
-
- # store whatever the user gave us
- foreach item [array names testAttributes] {
- set [string trimleft $item "-"] $testAttributes($item)
- }
-
- # 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
- }
-
- # 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 setupFailure 0
- set cleanupFailure 0
-
- # 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]
- }
- } 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
- }
-
- 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]]
- }
-
- 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
- }
-
- # 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 {$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" }
- }
- 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"
- }
- }
- }
- 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
-}
-
-
-# runTest --
-#
-# This is the defnition of the version 1.0 test routine for tcltest. It is
-# provided here for backward compatibility. It is also used as the 'backbone'
-# of the test procedure, as in, this is where all the work really gets done.
-#
-# This procedure runs a test and prints an error message if the test fails.
-# If tcltest::verbose has been set, it also prints a message even if the
-# test succeeds. The test will be skipped if it doesn't match the
-# tcltest::match variable, if it matches an element in
-# tcltest::skip, or if one of the elements of "constraints" turns
-# out not to be true.
-#
-# Arguments:
-# name - Name of test, in the form foo-1.2.
-# description - Short textual description of the test, to
-# help humans understand what it does.
-# constraints - A list of one or more keywords, each of
-# which must be the name of an element in
-# the array "tcltest::testConstraints". If any of these
-# elements is zero, the test is skipped.
-# This argument may be omitted.
-# 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::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 {
- if {[string match $pattern $name]} {
- 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} {
- set ok 0
- foreach pattern $tcltest::match {
- if {[string match $pattern $name]} {
- set ok 1
- break
- }
- }
- if {!$ok} {
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Skipped)
- DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch}
- }
- return
- }
- }
-
- DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints"
-
- if {$constraints == {}} {
- # If we're limited to the listed constraints and there aren't any
- # listed, then we shouldn't run the test.
- if {$tcltest::limitConstraints} {
- tcltest::AddToSkippedBecause userSpecifiedLimitConstraint
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Skipped)
- }
- return
- }
- } else {
- # "constraints" argument exists;
- # make sure that the constraints are satisfied.
-
- 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
- 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))} {
- set doTest 0
-
- # store the constraint that kept the test from running
- set constraints $constraint
- break
- }
- }
- }
-
- if {$doTest == 0} {
- if {[tcltest::isVerbose skip]} {
- puts [outputChannel] "++++ $name SKIPPED: $constraints"
- }
-
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Skipped)
- tcltest::AddToSkippedBecause $constraints
- }
- return
- }
- }
-
- # Save information about the core file. You need to restore the original
- # tcl_platform environment because some of the tests mess with
- # tcl_platform.
-
- if {$tcltest::preserveCore} {
- set currentTclPlatform [array get tcl_platform]
- array set tcl_platform $tcltest::originalTclPlatform
- if {[file exists [file join [tcltest::workingDirectory] core]]} {
- set coreModTime [file mtime [file join \
- [tcltest::workingDirectory] core]]
- }
- array set tcl_platform $currentTclPlatform
- }
-
- # If there is no "memory" command (because memory debugging isn't
- # enabled), then don't attempt to use the command.
-
- if {[info commands memory] != {}} {
- memory tag $name
- }
-
- if {[tcltest::isVerbose start]} {
- puts [outputChannel] "---- $name start"
- flush [outputChannel]
- }
-
- set code [catch {uplevel $script} actualAnswer]
-
- 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 {
-
- # 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 {
- if {$::env($index) != $tcltest::originalEnv($index)} {
- lappend changedEnv $index
- set ::env($index) $tcltest::originalEnv($index)
- }
- }
- }
- 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]"
- 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"
- }
- } 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 [outputChannel] "A core file was created!"
- }
- } else {
- puts [outputChannel] "A core file was created!"
- }
- }
- }
- }
- flush [outputChannel]
- flush [errorChannel]
- return
-}
-
-#####################################################################
-
-# 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:
-# directory to search
-#
-# Results:
-# The constructed list is returned to the user. This will primarily
-# be used in 'all.tcl' files. It is used in runAllTests.
-#
-# Side Effects:
-# None
-
-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 {
- set matchFileList [concat $matchFileList \
- [glob -nocomplain [file join $directory $match]]]
- }
- if {[string compare {} $tcltest::skipFiles]} {
- set skipFileList {}
- foreach skip $tcltest::skipFiles {
- set skipFileList [concat $skipFileList \
- [glob -nocomplain [file join $directory $skip]]]
- }
- foreach file $matchFileList {
- # Only include files that don't match the skip pattern and
- # aren't SCCS lock files.
- if {([lsearch -exact $skipFileList $file] == -1) && \
- (![string match l.*.test [file tail $file]])} {
- lappend matchingFiles $file
- }
- }
- } else {
- set matchingFiles [concat $matchingFiles $matchFileList]
- }
- }
- if {[string equal $matchingFiles {}]} {
- tcltest::PrintError "No test files remain after applying \
- your match and skip patterns!"
- }
- return $matchingFiles
-}
-
-# 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]
- }
- }
- }
- }
- 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
-}
-
-# 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 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
- }
- }
- }
-
- # 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 --
-#
-# Save information regarding what procs and variables exist.
-#
-# Arguments:
-# none
-#
-# Results:
-# Modifies the variable tcltest::saveState
-#
-# Side effects:
-# None.
-
-proc tcltest::saveState {} {
- uplevel {set tcltest::saveState [list [info procs] [info vars]]}
- DebugPuts 2 "tcltest::saveState: $tcltest::saveState"
- return
-}
-
-# tcltest::restoreState --
-#
-# Remove procs and variables that didn't exist before the call to
-# tcltest::saveState.
-#
-# Arguments:
-# none
-#
-# Results:
-# Removes procs and variables from your environment if they don't exist
-# in the tcltest::saveState variable.
-#
-# Side effects:
-# None.
-
-proc tcltest::restoreState {} {
- foreach p [info procs] {
- if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \
- (![string match "*tcltest::$p" [namespace origin $p]])} {
-
- DebugPuts 2 "tcltest::restoreState: Removing proc $p"
- rename $p {}
- }
- }
- 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 --
-#
-# 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} {
- regsub "\n$" [string tolower $msg] "" msg
- regsub -all "\n\n" $msg "\n" msg
- regsub -all "\n\}" $msg "\}" msg
- return $msg
-}
-
-# tcltest::makeFile --
-#
-# Create a new file with the name <name>, and write <contents> to it.
-#
-# If this file hasn't been created via makeFile since the last time
-# cleanupTests was called, add it to the $filesMade list, so it will
-# be removed by the next call to cleanupTests.
-#
-# 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]
- }
-
- set fullName [file join $directory $name]
-
- DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName"
-
- set fd [open $fullName w]
-
- fconfigure $fd -translation lf
-
- if {[string equal [string index $contents end] "\n"]} {
- puts -nonewline $fd $contents
- } else {
- puts $fd $contents
- }
- close $fd
-
- if {[lsearch -exact $tcltest::filesMade $fullName] == -1} {
- lappend tcltest::filesMade $fullName
- }
- return $fullName
-}
-
-# tcltest::removeFile --
-#
-# Removes the named file from the filesystem
-#
-# Arguments:
-# 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 {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]
-}
-
-# tcltest::makeDirectory --
-#
-# Create a new dir with the name <name>.
-#
-# If this dir hasn't been created via makeDirectory since the last time
-# cleanupTests was called, add it to the $directoriesMade list, so it will
-# be removed by the next call to cleanupTests.
-#
-# 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.
-
-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 --
-#
-# Removes a named directory from the file system.
-#
-# Arguments:
-# 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 {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]
-}
-
-# tcltest::viewFile --
-#
-# reads the content of a file and returns it
-#
-# Arguments:
-# name of the file to read
-# directory in which file is located
-#
-# Results:
-# content of the named file
-#
-# Side effects:
-# None.
-
-proc tcltest::viewFile {name {directory ""}} {
- global tcl_platform
- if {[llength [info level 0]] == 2} {
- set directory [tcltest::temporaryDirectory]
- }
- 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.
-# This allows the tester to
-# 1. Create denormalized or improperly formed strings to pass to C procedures
-# that are supposed to accept strings with embedded NULL bytes.
-# 2. Confirm that a string result has a certain pattern of bytes, for instance
-# to confirm that "\xe0\0" in a Tcl script is stored internally in
-# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
-#
-# Generally, it's a bad idea to examine the bytes in a Tcl string or to
-# construct improperly formed strings in this manner, because it involves
-# 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::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
-#
-
-# 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
- }
- return
-}
-
-# 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
- }
- return
-}
-
-# tcltest::threadReap --
-#
-# Kill all threads except for the main thread.
-# Do nothing if testthread is not defined.
-#
-# Arguments:
-# none.
-#
-# Results:
-# Returns the number of existing threads.
-#
-# Side Effects:
-# none.
-#
-
-proc tcltest::threadReap {} {
- if {[info commands testthread] != {}} {
-
- # testthread built into tcltest
-
- testthread errorproc ThreadNullError
- while {[llength [testthread names]] > 1} {
- foreach tid [testthread names] {
- if {$tid != $tcltest::mainThread} {
- catch {testthread send -async $tid {testthread exit}}
- }
- }
- ## Enter a bit a sleep to give the threads enough breathing
- ## room to kill themselves off, otherwise the end up with a
- ## massive queue of repeated events
- after 1
- }
- testthread errorproc ThreadError
- return [llength [testthread names]]
- } elseif {[info commands thread::id] != {}} {
-
- # Thread extension
-
- thread::errorproc ThreadNullError
- while {[llength [thread::names]] > 1} {
- foreach tid [thread::names] {
- if {$tid != $tcltest::mainThread} {
- catch {thread::send -async $tid {thread::exit}}
- }
- }
- ## Enter a bit a sleep to give the threads enough breathing
- ## room to kill themselves off, otherwise the end up with a
- ## massive queue of repeated events
- after 1
- }
- thread::errorproc ThreadError
- return [llength [thread::names]]
- } else {
- return 1
- }
- return 0
-}
-
-# Initialize the constraints and set up command line arguments
-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 [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
-
generated by cgit v0.12 at 2024-11-14 06:05:46 (GMT)