summaryrefslogtreecommitdiffstats
path: root/library/tcltest1.0
diff options
context:
space:
mode:
authorjenn <jenn>1999-06-29 20:14:10 (GMT)
committerjenn <jenn>1999-06-29 20:14:10 (GMT)
commitc99437b6b643f14bb0cad6e38ecf813f45a41e71 (patch)
treedb7048bf1d37678abffa3e906a7ea4ce4463b05c /library/tcltest1.0
parent3c38d311e45c88777c457a79bf487bed17e43ab4 (diff)
downloadtcl-c99437b6b643f14bb0cad6e38ecf813f45a41e71.zip
tcl-c99437b6b643f14bb0cad6e38ecf813f45a41e71.tar.gz
tcl-c99437b6b643f14bb0cad6e38ecf813f45a41e71.tar.bz2
Added flags -limitconstraints, -preservecore, -help, -file, -notfile, -relateddir,
and -asidefromdir to tcltest.tcl. Also added exported proc ::tcltest::getMatchingTestFiles to tcltest.tcl. Modified documentation to match and all.tcl to use the new functionality instead of implementing -file itself. Changed some test names in winPipe.test to remove duplicates.
Diffstat (limited to 'library/tcltest1.0')
-rw-r--r--library/tcltest1.0/pkgIndex.tcl9
-rw-r--r--library/tcltest1.0/tcltest.tcl427
2 files changed, 368 insertions, 68 deletions
diff --git a/library/tcltest1.0/pkgIndex.tcl b/library/tcltest1.0/pkgIndex.tcl
index f9e2d30..96b38cc 100644
--- a/library/tcltest1.0/pkgIndex.tcl
+++ b/library/tcltest1.0/pkgIndex.tcl
@@ -8,4 +8,11 @@
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
-package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg ::tcltest::removeDirectory ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory tcltest:grep}}}]
+package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 \
+ {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests \
+ ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile \
+ ::tcltest::normalizeMsg ::tcltest::removeDirectory \
+ ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState \
+ ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory \
+ ::tcltest:grep ::tcltest::getMatchingTestFiles }}}]
+
diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl
index 3375718..d3d8a8b 100644
--- a/library/tcltest1.0/tcltest.tcl
+++ b/library/tcltest1.0/tcltest.tcl
@@ -1,6 +1,6 @@
# tcltest.tcl --
#
-# This file contains support code for the Tcl test suite. It defines the
+# 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 README file for more details.
@@ -12,7 +12,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.1 1999/06/26 03:53:45 jenn Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.2 1999/06/29 20:14:15 jenn Exp $
package provide tcltest 1.0
@@ -27,7 +27,7 @@ namespace eval tcltest {
set procList [list test cleanupTests dotests saveState restoreState \
normalizeMsg makeFile removeFile makeDirectory removeDirectory \
viewFile grep bytestring set_iso8859_1_locale restore_locale \
- safeFetch threadReap]
+ safeFetch threadReap getMatchingTestFiles]
foreach proc $procList {
namespace export $proc
}
@@ -36,13 +36,20 @@ namespace eval tcltest {
variable verbose "b"
- # match defaults to the empty list
+ # Match and skip patterns default to the empty list, except for
+ # matchFiles, which defaults to all .test files in the testsDirectory
variable match {}
+ variable skip {}
- # skip defaults to the empty list
+ variable matchFiles {*.test}
+ variable skipFiles {}
- variable skip {}
+ variable matchDirectories {}
+ variable skipDirectories {}
+
+ # By default, don't save core files
+ variable preserveCore false
# output goes to stdout by default
@@ -104,11 +111,14 @@ namespace eval tcltest {
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).
+ # predefined constraints (see the explanation for the
+ # ::tcltest::initConstraints proc for more details).
array set ::tcltest::testConstraints {}
+ # Don't run only the constrained tests by default
+ variable limitConstraints false
+
# tests that use thread need to know which is the main thread
variable mainThread 1
@@ -120,9 +130,6 @@ namespace eval tcltest {
array set ::tcltest::originalEnv [array get ::env]
- # TclPro has other variables that need to be set, including the locations
- # of various directories.
-
# Set ::tcltest::workingDirectory to [pwd]. The default output directory
# for Tcl tests is the working directory.
@@ -135,6 +142,8 @@ namespace eval tcltest {
variable testsDirectory [pwd]
+ # the variables and procs that existed when ::tcltest::saveState was
+ # called are stored in a variable of the same name
variable saveState {}
# Internationalization support
@@ -174,17 +183,19 @@ namespace eval tcltest {
# Set the location of the execuatble
variable tcltest [info nameofexecutable]
-
- # If there is no "memory" command (because memory debugging isn't
- # enabled), generate a dummy command that does nothing.
-
- if {[info commands memory] == {}} {
- namespace eval :: {
- proc memory args {}
- }
- }
}
+# ::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.
proc ::tcltest::AddToSkippedBecause { constraint } {
# add the constraint to the list of constraints the kept tests
@@ -250,10 +261,10 @@ proc ::tcltest::initConstraints {} {
catch {unset ::tcltest::testConstraints}
# 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.
+ # 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.
trace variable ::tcltest::testConstraints r ::tcltest::safeFetch
@@ -283,9 +294,14 @@ proc ::tcltest::initConstraints {} {
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(win32s) [string equal $tcl_platform(os) "Win32s"]
+ 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"]
+ set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) \
+ "Win32s"]
# The following Constraints switches are used to mark tests that should work,
# but have been temporarily disabled on certain platforms because they don't
@@ -467,7 +483,8 @@ proc ::tcltest::initConstraints {} {
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.
+ # message you get will indicate whether sockets are available on this
+ # system.
catch {socket} msg
set ::tcltest::testConstraints(socket) \
@@ -485,8 +502,87 @@ proc ::tcltest::initConstraints {} {
}
}
+# ::tcltest::PrintUsageInfoHook
+#
+# Hook used for customization of display of usage information.
+#
+
+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
+#
+
+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 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 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 bool \t If true, save any core files produced \n\
+ \t during testing in the directory \n\
+ \t specified by -tmpdir. 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\
+ -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\
+ -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::processCmdLineArgs.
+#
+
proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
+# ::tcltest::processCmdLineArgsHook --
+#
+# This hook is used to actually process the flags added by
+# ::tcltest::processCmdLineArgsAddFlagsHook.
+#
+# Arguments:
+# flags The flags that have been pulled out of argv
+#
+
proc ::tcltest::processCmdLineArgsHook {flag} {}
# ::tcltest::processCmdLineArgs --
@@ -509,7 +605,7 @@ proc ::tcltest::processCmdLineArgs {} {
# The "argv" var doesn't exist in some cases, so use {}.
- if {(![info exists argv]) || ([llength $argv] < 2)} {
+ if {(![info exists argv]) || ([llength $argv] < 1)} {
set flagArray {}
} else {
set flagArray $argv
@@ -519,14 +615,24 @@ proc ::tcltest::processCmdLineArgs {} {
# Note that -verbose cannot be abbreviated to -v in wish because it
# conflicts with the wish option -visual.
+ # Process -help first
+ if {([lsearch -exact $flagArray {-help}] != -1) || \
+ ([lsearch -exact $flagArray {-h}] != -1)} {
+ ::tcltest::PrintUsageInfo
+ exit
+ }
+
if {[catch {array set flag $flagArray}]} {
::tcltest::PrintError "odd number of arguments specified on command line: \
$argv"
+ ::tcltest::PrintUsageInfo
exit
}
-
+
+ # -help is not listed since it has already been processed
lappend defaultFlags {-verbose -match -skip -constraints \
- -outfile -errfile -debug -tmpdir}
+ -outfile -errfile -debug -tmpdir -file -notfile -relateddir \
+ -asidefromdir -preservecore -limitconstraints}
lappend defaultFlags [ ::tcltest::processCmdLineArgsAddFlagsHook ]
foreach arg $defaultFlags {
@@ -556,6 +662,22 @@ proc ::tcltest::processCmdLineArgs {} {
set ::tcltest::skip $flag(-skip)
}
+ # Handle the -file and -notfile flags
+ if {[info exists flag(-file)]} {
+ set ::tcltest::matchFiles $flag(-file)
+ }
+ if {[info exists flag(-notfile)]} {
+ set ::tcltest::skipFiles $flag(-notfile)
+ }
+
+ # Handle -relateddir and -asidefromdir flags
+ if {[info exists flag(-relateddir)]} {
+ set ::tcltest::matchDirectories $flag(-relateddir)
+ }
+ if {[info exists flag(-asidefromdir)]} {
+ set ::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.
@@ -566,6 +688,23 @@ proc ::tcltest::processCmdLineArgs {} {
}
}
+ # 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)]} {
+ puts "You can only use the -limitconstraints flag with \
+ -constraints"
+ exit
+ }
+ set ::tcltest::limitConstraints $flag(-limitconstraints)
+ foreach elt [array names ::tcltest::testConstraints] {
+ if {[lsearch -exact $flag(-constraints) $elt] == -1} {
+ set ::tcltest::testConstraints($elt) 0
+ }
+ }
+ }
+
# If an alternate error or output files are specified, change the
# default channels.
@@ -640,6 +779,35 @@ proc ::tcltest::processCmdLineArgs {} {
lappend ::tcltest::filesExisted [file tail $file]
}
+ # Handle -preservecore
+ if {[info exists flag(-preservecore)]} {
+ set ::tcltest::preserveCore $flag(-preserveCore)
+ }
+
+ # Find the matching directories and then remove the ones that are
+ # specified in the skip pattern; if no match pattern is specified, use
+ # the default value specified for ::tcltest::testsDirectory - ignore the
+ # value of ::tcltest::skipDirectories if the default value is being used.
+ if {$::tcltest::matchDirectories != {}} {
+ set matchDir {}
+ set skipDir {}
+ if {$::tcltest::skipDirectories != {}} {
+ set skipDir [glob -nocomplain $::tcltest::skipDirectories]
+ }
+ foreach dir [glob -nocomplain $::tcltest::matchDirectories] {
+ if {[lsearch -exact $skipDir $dir] == -1} {
+ lappend matchDir $dir
+ }
+ }
+
+ # Only reset ::tcltest::testsDirectory if anything actually matched
+ # after removing the skip patterns.
+ if {[llength $matchDir] > 0} {
+ set ::tcltest::testsDirectory $matchDir
+ }
+ }
+
+ # Call the hook
::tcltest::processCmdLineArgsHook [array get flag]
# Spit out everything you know if ::tcltest::debug is set.
@@ -655,6 +823,8 @@ proc ::tcltest::processCmdLineArgs {} {
puts "::tcltest::errorChannel = $::tcltest::errorChannel"
puts "Original environment (::tcltest::originalEnv):"
parray ::tcltest::originalEnv
+ puts "Constraints:"
+ parray ::tcltest::testConstraints
}
}
@@ -764,63 +934,70 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
set ::tcltest::numTests($index) 0
}
+ # exit only if running Tk in non-interactive mode
+
+ global tk_version tcl_interactive
+ if {[info exists tk_version] && !$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] {
+ foreach index [array names ::env] {
if {![info exists ::tcltest::originalEnv($index)]} {
lappend newEnv $index
- unset env($index)
+ unset ::env($index)
} else {
- if {$env($index) != $::tcltest::originalEnv($index)} {
+ if {$::env($index) != $::tcltest::originalEnv($index)} {
lappend changedEnv $index
- set env($index) $::tcltest::originalEnv($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)
+ set ::env($index) $::tcltest::originalEnv($index)
}
}
if {[llength $newEnv] > 0} {
puts $::tcltest::outputChannel \
- "\t\tenv array elements created:\t$newEnv"
+ "env array elements created:\t$newEnv"
}
if {[llength $changedEnv] > 0} {
puts $::tcltest::outputChannel \
- "\t\tenv array elements changed:\t$changedEnv"
+ "env array elements changed:\t$changedEnv"
}
if {[llength $removedEnv] > 0} {
puts $::tcltest::outputChannel \
- "\t\tenv array elements removed:\t$removedEnv"
- }
-
- # exit only if running Tk in non-interactive mode
-
- global tk_version tcl_interactive
- if {[info exists tk_version] && !$tcl_interactive} {
- exit
+ "env array elements removed:\t$removedEnv"
}
- } 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
}
}
+# ::tcltest::cleanupTestsHook --
+#
+# This hook allows a harness that builds upon tcltest to specify
+# additional things that should be done at cleanup.
+#
+
proc ::tcltest::cleanupTestsHook {} {}
# test --
@@ -882,6 +1059,13 @@ proc ::tcltest::test {name description script expectedAnswer args} {
set i [llength $args]
if {$i == 0} {
set 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)
+ return
+ }
} elseif {$i == 1} {
# "constraints" argument exists; shuffle arguments down, then
@@ -892,49 +1076,50 @@ proc ::tcltest::test {name description script expectedAnswer args} {
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 {[.a-zA-Z0-9]+} $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
-
set constraints $constraint
break
}
}
}
if {$doTest == 0} {
- incr ::tcltest::numTests(Skipped)
if {[string first s $::tcltest::verbose] != -1} {
puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
}
+ incr ::tcltest::numTests(Skipped)
::tcltest::AddToSkippedBecause $constraints
return
}
} else {
error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
}
- memory tag $name
+
+ # 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
+ }
+
set code [catch {uplevel $script} actualAnswer]
if {([string compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} {
incr ::tcltest::numTests(Passed)
@@ -973,6 +1158,65 @@ proc ::tcltest::test {name description script expectedAnswer args} {
puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
puts $::tcltest::outputChannel "==== $name FAILED\n"
}
+ if {[file exists [file join $::tcltest::workingDirectory core]]} {
+ if {$::tcltest::preserveCore} {
+ file rename -force [file join $::tcltest::workingDirectory core] \
+ [file join $::tcltest::temporaryDirectory core-$name]
+
+ puts $::tcltest::outputChannel "==== $name produced core file! \
+ Moved file to: \
+ [file join $::tcltest::temporaryDirectory core-$name]"
+ } else {
+ puts $::tcltest::outputChannel "==== $name produced core file!"
+ }
+ }
+}
+
+# ::tcltest::getMatchingTestFiles
+#
+# Looks at the patterns given to match and skip directories and files
+# and uses them to put together a list of the tests that will be run.
+#
+# Arguments:
+# none
+#
+# Results:
+# The constructed list is returned to the user. This will primarily
+# be used in 'all.tcl' files.
+
+proc ::tcltest::getMatchingFiles {} {
+ set matchingFiles {}
+ # Find the matching files in the list of directories and then remove the
+ # ones that match the skip pattern
+ foreach directory $::tcltest::testsDirectory {
+ set matchFileList {}
+ foreach match $::tcltest::matchFiles {
+ set matchFileList [concat $matchFileList \
+ [glob -nocomplain [file join $directory $match]]]
+ }
+ if {$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 {$matchingFiles == {}} {
+ ::tcltest::PrintError "No test files remain after applying \
+ your match and skip patterns!"
+ }
+ return $matchingFiles
}
# ::tcltest::dotests --
@@ -997,6 +1241,9 @@ proc ::tcltest::dotests {file args} {
set ::tcltest::match $savedTests
}
+
+# The following two procs are used in the io tests.
+
proc ::tcltest::openfiles {} {
if {[catch {testchannel open} result]} {
return {}
@@ -1017,6 +1264,16 @@ proc ::tcltest::leakfiles {old} {
return $leak
}
+# ::tcltest::saveState --
+#
+# Save information regarding what procs and variables exist.
+#
+# Arguments:
+# none
+#
+# Results:
+# Modifies the variable ::tcltest::saveState
+
proc ::tcltest::saveState {} {
uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} {
@@ -1024,6 +1281,18 @@ proc ::tcltest::saveState {} {
}
}
+# ::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.
+
proc ::tcltest::restoreState {} {
foreach p [info procs] {
if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
@@ -1044,6 +1313,14 @@ proc ::tcltest::restoreState {} {
}
}
+# ::tcltest::normalizeMsg --
+#
+# Removes "extra" newlines from a string.
+#
+# Arguments:
+# msg String to be modified
+#
+
proc ::tcltest::normalizeMsg {msg} {
regsub "\n$" [string tolower $msg] "" msg
regsub -all "\n\n" $msg "\n" msg
@@ -1088,6 +1365,14 @@ proc ::tcltest::makeFile {contents name} {
}
}
+# ::tcltest::removeFile --
+#
+# Removes the named file from the filesystem
+#
+# Arguments:
+# name file to be removed
+#
+
proc ::tcltest::removeFile {name} {
if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
puts "::tcltest::removeFile: removing $name"
@@ -1112,6 +1397,14 @@ proc ::tcltest::makeDirectory {name} {
}
}
+# ::tcltest::removeDirectory --
+#
+# Removes a named directory from the file system.
+#
+# Arguments:
+# name Name of the directory to remove
+#
+
proc ::tcltest::removeDirectory {name} {
file delete -force $name
}