summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog34
-rw-r--r--doc/tcltest.n35
-rw-r--r--library/tcltest/tcltest.tcl443
-rw-r--r--library/tcltest1.0/tcltest.tcl443
-rw-r--r--tests/autoMkindex.test8
-rw-r--r--tests/basic.test6
-rw-r--r--tests/pkgMkIndex.test20
-rw-r--r--tests/socket.test3
-rwxr-xr-xtests/tcltest.test50
-rw-r--r--tests/unixInit.test5
-rw-r--r--tests/unixNotfy.test8
11 files changed, 790 insertions, 265 deletions
diff --git a/ChangeLog b/ChangeLog
index 004bc16..b2403a4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,21 @@
+1999-10-19 Jennifer Hom <jenn@scriptics.com>
+
+ * tests/tcltest.test:
+ * doc/tcltest.n:
+ * library/tcltest1.0/tcltest.tcl: Removed the extra return at the
+ end of the tcltest.tcl file.
+
+ Applied patches sent in by Andreas Kupries to add helper procs for
+ debug output, add 3 new flags (-testsdir, -load, -loadfile), and
+ internally refactors common code for dealing with paths into
+ separate procedures. [Bug: 2838, 2842]
+
1999-10-12 Jim Ingham <jingham@scriptics.com>
* mac/tclMacLoad.c: Stupid bug - we converted the filename to
external, but used the unconverted version.
* mac/tclMacFCmd.c: Fix a merge error in the bug fix for [Bug: 2869]
+
1999-10-12 Jeff Hobbs <hobbs@scriptics.com>
* generic/regc_color.c:
@@ -147,6 +160,12 @@
* generic/tclCmdMZ.c: changed [string equal] to return an Int
type object (was a Boolean)
+1999-09-01 Jennifer Hom <jenn@scriptics.com>
+
+ * library/tcltest1.0/tcltest.tcl: Process command-line arguments
+ only ::tcltest doesn't have a child namespace (requires that
+ command-line args are processed in that namespace)
+
1999-09-01 Jeff Hobbs <hobbs@scriptics.com>
* generic/tclParseExpr.c: changed '"' to '\"' to make FreeBSD
@@ -173,6 +192,14 @@
1999-08-27 Jennifer Hom <jenn@scriptics.com>
+ * tests/env.test:
+ * tests/exec.test:
+ * tests/io.test:
+ * tests/event.test:
+ * tests/tcltest.test: Added 'exit' calls to scripts that the tests
+ themselves write, and removed accidental checkin of knownBugThreaded
+ constraints for Solaris and Linux.
+
* library/tcltest1.0/tcltest.tcl: Modified tcltest so that
variables are only initialized to their default values if they did
not previously exist.
@@ -374,6 +401,13 @@
instead to send a message to the socket event window to tell it to
terminate its thread.
+1999-07-30 Jennifer Hom <jenn@scriptics.com>
+
+ * tests/tcltest.test:
+ * library/tcltest1.0/tcltest.tcl: Exit with non-zero status if
+ there were problems with the way the test suite was started
+ (e.g. wrong # arguments).
+
1999-07-30 Jeff Hobbs <hobbs@scriptics.com>
* generic/tclInt.decls: added declaractions necessary for the
diff --git a/doc/tcltest.n b/doc/tcltest.n
index 99f354d..56f10a8 100644
--- a/doc/tcltest.n
+++ b/doc/tcltest.n
@@ -6,7 +6,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: tcltest.n,v 1.6 1999/08/31 01:48:25 jenn Exp $
+'\" RCS: @(#) $Id: tcltest.n,v 1.7 1999/10/19 18:08:40 jenn Exp $
'\"
.so man.macros
.TH "Tcltest" n 8.2 Tcl "Tcl Built-In Commands"
@@ -23,6 +23,8 @@ Tcltest \- Test harness support code and utilities
.sp
\fB::tcltest::getMatchingTestFiles\fR
.sp
+\fB::tcltest::loadTestedCommands\fR
+.sp
\fB::tcltest::makeFile \fIcontents name\fR
.sp
\fB::tcltest::removeFile \fIname\fR
@@ -96,6 +98,12 @@ This command is used when you want to run multiple test files. It returns
the list of tests that should be sourced in an 'all.tcl' file. See the
section \fI"Running test files"\fR for more information.
.TP
+\fB::tcltest::loadTestedCommands\fP
+This command uses the script specified via the \fI-load\fR or
+\fI-loadfile\fR to load the commands checked by the test suite.
+Allowed to be empty, as the tested commands could have been compiled
+into the interpreter running the test suite.
+.TP
\fB::tcltest::makeFile\fP \fIcontents name\fR
Create a file that will be automatically be removed by
\fB::tcltest::cleanupTests\fR at the end of a test file.
@@ -250,11 +258,16 @@ specified using -tmpdir on the command line.
\fB::tcltest::testsDirectory\fR
where the tests reside - defaults to \fI::tcltest::workingDirectory\fR
if the script cannot determine where the \fItests\fR directory is
-located. This variable should be explicitly set if tests are being
-run from an all.tcl file.
+located. It is possible to change the default by specifying
+\fI-testdir\fR on the commandline. This variable should be
+explicitly set if tests are being run from an all.tcl file.
.TP
\fB::tcltest::tcltest\fR
-the name of the executable used to invoke the test suite.
+the name of the executable used to invoke the test suite.
+.TP
+\fB::tcltest::loadScript\fR
+The script executed \fBloadTestedCommands\fR. Specified either by
+\fI-load\fR or \fI-loadfile\fR.
.SH "TEST CONSTRAINTS"
Constraints are used to determine whether a test should be skipped.
Each constraint is stored as an index in the array
@@ -433,10 +446,24 @@ interested in running only those tests that are constrained to be
unixOnly and no other tests.
(::tcltest::limitConstraints)
.TP
+\fB-load <script>\fR
+will use the specified script to load the commands under test
+(::tcltest::loadTestedCommands). The default is the empty
+script. See -loadfile below too. (::tcltest::loadScript)
+.TP
+\fB-loadfile <scriptfile>\fR
+will use the contents of the named file to load the commands under
+test (::tcltest::loadTestedCommands). See -load above too. The default
+is the empty script. (::tcltest::loadScript)
+.TP
\fB-tmpdir <directoryName>\fR
put any temporary files (created with ::tcltest::makeFile and
::tcltest::makeDirectory) into the named directory. The default
location is ::tcltest::workingDirectory. (::tcltest::temporaryDirectory)
+.TP
+\fB-testdir <directoryName>\fR
+search the test suite to execute in the named directory. The default
+location is ::tcltest::workingDirectory. (::tcltest::testsDirectory)
.TP
\fB-preservecore <level>\fR
check for core files. This flag is used to determine how much
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 644e3c8..d633b21 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -12,21 +12,19 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.14 1999/09/21 23:11:24 jenn Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.15 1999/10/19 18:08:42 jenn Exp $
package provide tcltest 1.0
-# Ensure that we have a minimal auto_path so we don't pick up extra junk.
-set auto_path [list [info library]]
-
# create the "tcltest" namespace for all testing variables and procedures
-namespace eval tcltest {
+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]
+ viewFile bytestring safeFetch threadReap getMatchingFiles \
+ loadTestedCommands]
foreach proc $procList {
namespace export $proc
}
@@ -156,10 +154,18 @@ namespace eval tcltest {
}
# 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 {}
+ }
+
# tests that use threads need to know which is the main thread
if {![info exists mainThread]} {
@@ -191,10 +197,11 @@ namespace eval tcltest {
# ::tcltest::testsDirectory.
if {![info exists testsDirectory]} {
- set oDir [pwd]
+ set oldpwd [pwd]
catch {cd [file join [file dirname [info script]] .. .. tests]}
variable testsDirectory [pwd]
- cd $oDir
+ cd $oldpwd
+ unset oldpwd
}
# the variables and procs that existed when ::tcltest::saveState was
@@ -255,8 +262,86 @@ namespace eval tcltest {
$::tcltest::workingDirectory core]]
}
}
+
+ # Tcl version numbers
+ if {![info exists version]} {
+ variable version 8.3
+ }
+ if {![info exists patchLevel]} {
+ variable patchLevel 8.3.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.
+#
+
+proc ::tcltest::DebugPuts {level string} {
+ variable debug
+ if {$debug >= $level} {
+ puts $string
+ }
+}
+
+# ::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.
+#
+
+proc ::tcltest::DebugPArray {level arrayvar} {
+ variable debug
+
+ if {$debug >= $level} {
+ catch {upvar $arrayvar $arrayvar}
+ parray $arrayvar
+ }
+}
+
+# ::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.
+#
+
+proc ::tcltest::DebugDo {level script} {
+ variable debug
+
+ if {$debug >= $level} {
+ uplevel $script
+ }
+}
+
# ::tcltest::AddToSkippedBecause --
#
# Increments the variable used to track how many tests were skipped
@@ -604,7 +689,7 @@ proc ::tcltest::initConstraints {} {
set ::tcltest::testConstraints(hasIsoLocale) 0
} else {
set ::tcltest::testConstraints(hasIsoLocale) \
- [string length [::tcltest::set_iso8859_1_locale]]
+ [string length [::tcltest::set_iso8859_1_locale]]
::tcltest::restore_locale
}
}
@@ -631,47 +716,138 @@ 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\
- -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\
- -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."]
+ -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\
+ -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::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 --
#
# This hook is used to add to the list of command line arguments that are
@@ -734,7 +910,7 @@ proc ::tcltest::processCmdLineArgs {} {
if {[catch {array set flag $flagArray}]} {
::tcltest::PrintError "odd number of arguments specified on command line: \
- $argv"
+ $argv"
::tcltest::PrintUsageInfo
exit 1
}
@@ -742,7 +918,8 @@ proc ::tcltest::processCmdLineArgs {} {
# -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
+ -preservecore -limitconstraints -args -testdir \
+ -load -loadfile
set defaultFlags [concat $defaultFlags \
[ ::tcltest::processCmdLineArgsAddFlagsHook ]]
@@ -825,37 +1002,43 @@ proc ::tcltest::processCmdLineArgs {} {
set tmpDirError ""
if {[info exists flag(-tmpdir)]} {
set ::tcltest::temporaryDirectory $flag(-tmpdir)
-
- if {![string equal \
- [file pathtype $::tcltest::temporaryDirectory] \
- "absolute"]} {
- set ::tcltest::temporaryDirectory [file join [pwd] \
- $::tcltest::temporaryDirectory]
- }
+
+ MakeAbsolutePath ::tcltest::temporaryDirectory
set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
}
if {[file exists $::tcltest::temporaryDirectory]} {
- if {![file isdir $::tcltest::temporaryDirectory]} {
- ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
- is not a directory"
- exit 1
- } elseif {![file writable $::tcltest::temporaryDirectory]} {
- ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
- is not writeable"
- exit 1
- } elseif {![file readable $::tcltest::temporaryDirectory]} {
- ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
- is not readable"
- exit 1
- }
+ ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError
} else {
file mkdir $::tcltest::temporaryDirectory
}
- set oldpwd [pwd]
- cd $::tcltest::temporaryDirectory
- set ::tcltest::temporaryDirectory [pwd]
- cd $oldpwd
+ NormalizePath ::tcltest::temporaryDirectory
+
+ # 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 \
@@ -868,20 +1051,35 @@ proc ::tcltest::processCmdLineArgs {} {
if {[info exists flag(-outfile)]} {
set tmp $flag(-outfile)
- if {![string equal [file pathtype $tmp] "absolute"]} {
- set tmp [file join $::tcltest::temporaryDirectory $tmp]
- }
+ MakeAbsolutePath tmp $::tcltest::temporaryDirectory
set ::tcltest::outputChannel [open $tmp w]
}
if {[info exists flag(-errfile)]} {
set tmp $flag(-errfile)
- if {![string equal [file pathtype $tmp] "absolute"]} {
- set tmp [file join $::tcltest::temporaryDirectory $tmp]
- }
+ MakeAbsolutePath tmp $::tcltest::temporaryDirectory
set ::tcltest::errorChannel [open $tmp w]
}
+ # 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])} {
+ set ::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
+ }
+
# If the user specifies debug testing, print out extra information during
# the run.
if {[info exists flag(-debug)]} {
@@ -896,21 +1094,40 @@ proc ::tcltest::processCmdLineArgs {} {
# Call the hook
::tcltest::processCmdLineArgsHook [array get flag]
- # Spit out everything you know if we're at debug level 2 or greater
- if {$::tcltest::debug > 1} {
- puts "Flags passed into tcltest:"
- parray flag
- puts "::tcltest::debug = $::tcltest::debug"
- puts "::tcltest::testsDirectory = $::tcltest::testsDirectory"
- puts "::tcltest::workingDirectory = $::tcltest::workingDirectory"
- puts "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
- puts "::tcltest::outputChannel = $::tcltest::outputChannel"
- puts "::tcltest::errorChannel = $::tcltest::errorChannel"
- puts "Original environment (::tcltest::originalEnv):"
- parray ::tcltest::originalEnv
- puts "Constraints:"
- parray ::tcltest::testConstraints
+ # Spit out everything you know if we're at a debug level 2 or greater
+
+ 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
+ DebugPuts 2 "Constraints:"
+ DebugPArray 2 ::tcltest::testConstraints
+}
+
+# ::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
+
+proc ::tcltest::loadTestedCommands {} {
+ if {$::tcltest::loadScript == {}} {
+ return
}
+
+ uplevel #0 $::tcltest::loadScript
}
# ::tcltest::cleanupTests --
@@ -1153,9 +1370,8 @@ if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
# expectedAnswer - Expected result from script.
proc ::tcltest::test {name description script expectedAnswer args} {
- if {$::tcltest::debug > 2} {
- puts "Running $name ($description)"
- }
+
+ DebugPuts 3 "Running $name ($description)"
incr ::tcltest::numTests(Total)
@@ -1164,9 +1380,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
foreach pattern $::tcltest::skip {
if {[string match $pattern $name]} {
incr ::tcltest::numTests(Skipped)
- if {$::tcltest::debug} {
- ::tcltest::AddToSkippedBecause userSpecifiedSkip
- }
+ DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip}
return
}
}
@@ -1183,9 +1397,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
}
if {!$ok} {
incr ::tcltest::numTests(Skipped)
- if {$::tcltest::debug} {
- ::tcltest::AddToSkippedBecause userSpecifiedNonMatch
- }
+ DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
return
}
}
@@ -1422,9 +1634,7 @@ proc ::tcltest::leakfiles {old} {
proc ::tcltest::saveState {} {
uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
- if {$::tcltest::debug > 1} {
- puts "::tcltest::saveState: $::tcltest::saveState"
- }
+ DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState"
}
# ::tcltest::restoreState --
@@ -1443,18 +1653,15 @@ proc ::tcltest::restoreState {} {
foreach p [info procs] {
if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
(![string equal ::tcltest::$p [namespace origin $p]])} {
- if {$::tcltest::debug > 2} {
- puts "::tcltest::restoreState: Removing proc $p"
- }
+
+ DebugPuts 3 "::tcltest::restoreState: Removing proc $p"
rename $p {}
}
}
foreach p [uplevel #0 {info vars}] {
if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
- if {$::tcltest::debug > 2} {
- puts "::tcltest::restoreState: Removing variable $p"
- }
- uplevel #0 "unset $p"
+ DebugPuts 3 "::tcltest::restoreState: Removing variable $p"
+ uplevel #0 "catch {unset $p}"
}
}
}
@@ -1485,9 +1692,8 @@ proc ::tcltest::normalizeMsg {msg} {
proc ::tcltest::makeFile {contents name} {
global tcl_platform
- if {$::tcltest::debug > 2} {
- puts "::tcltest::makeFile: putting $contents into $name"
- }
+ DebugPuts 3 "::tcltest::makeFile: putting $contents into $name"
+
set fd [open [file join $::tcltest::temporaryDirectory $name] w]
fconfigure $fd -translation lf
@@ -1516,9 +1722,7 @@ proc ::tcltest::makeFile {contents name} {
#
proc ::tcltest::removeFile {name} {
- if {$::tcltest::debug > 2} {
- puts "::tcltest::removeFile: removing $name"
- }
+ DebugPuts 3 "::tcltest::removeFile: removing $name"
file delete [file join $::tcltest::temporaryDirectory $name]
}
@@ -1665,10 +1869,11 @@ proc ::tcltest::threadReap {} {
# 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 ::tcltest] == {}} {
::tcltest::processCmdLineArgs
}
}
-
-return
diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl
index 644e3c8..d633b21 100644
--- a/library/tcltest1.0/tcltest.tcl
+++ b/library/tcltest1.0/tcltest.tcl
@@ -12,21 +12,19 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.14 1999/09/21 23:11:24 jenn Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.15 1999/10/19 18:08:42 jenn Exp $
package provide tcltest 1.0
-# Ensure that we have a minimal auto_path so we don't pick up extra junk.
-set auto_path [list [info library]]
-
# create the "tcltest" namespace for all testing variables and procedures
-namespace eval tcltest {
+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]
+ viewFile bytestring safeFetch threadReap getMatchingFiles \
+ loadTestedCommands]
foreach proc $procList {
namespace export $proc
}
@@ -156,10 +154,18 @@ namespace eval tcltest {
}
# 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 {}
+ }
+
# tests that use threads need to know which is the main thread
if {![info exists mainThread]} {
@@ -191,10 +197,11 @@ namespace eval tcltest {
# ::tcltest::testsDirectory.
if {![info exists testsDirectory]} {
- set oDir [pwd]
+ set oldpwd [pwd]
catch {cd [file join [file dirname [info script]] .. .. tests]}
variable testsDirectory [pwd]
- cd $oDir
+ cd $oldpwd
+ unset oldpwd
}
# the variables and procs that existed when ::tcltest::saveState was
@@ -255,8 +262,86 @@ namespace eval tcltest {
$::tcltest::workingDirectory core]]
}
}
+
+ # Tcl version numbers
+ if {![info exists version]} {
+ variable version 8.3
+ }
+ if {![info exists patchLevel]} {
+ variable patchLevel 8.3.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.
+#
+
+proc ::tcltest::DebugPuts {level string} {
+ variable debug
+ if {$debug >= $level} {
+ puts $string
+ }
+}
+
+# ::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.
+#
+
+proc ::tcltest::DebugPArray {level arrayvar} {
+ variable debug
+
+ if {$debug >= $level} {
+ catch {upvar $arrayvar $arrayvar}
+ parray $arrayvar
+ }
+}
+
+# ::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.
+#
+
+proc ::tcltest::DebugDo {level script} {
+ variable debug
+
+ if {$debug >= $level} {
+ uplevel $script
+ }
+}
+
# ::tcltest::AddToSkippedBecause --
#
# Increments the variable used to track how many tests were skipped
@@ -604,7 +689,7 @@ proc ::tcltest::initConstraints {} {
set ::tcltest::testConstraints(hasIsoLocale) 0
} else {
set ::tcltest::testConstraints(hasIsoLocale) \
- [string length [::tcltest::set_iso8859_1_locale]]
+ [string length [::tcltest::set_iso8859_1_locale]]
::tcltest::restore_locale
}
}
@@ -631,47 +716,138 @@ 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\
- -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\
- -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."]
+ -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\
+ -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::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 --
#
# This hook is used to add to the list of command line arguments that are
@@ -734,7 +910,7 @@ proc ::tcltest::processCmdLineArgs {} {
if {[catch {array set flag $flagArray}]} {
::tcltest::PrintError "odd number of arguments specified on command line: \
- $argv"
+ $argv"
::tcltest::PrintUsageInfo
exit 1
}
@@ -742,7 +918,8 @@ proc ::tcltest::processCmdLineArgs {} {
# -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
+ -preservecore -limitconstraints -args -testdir \
+ -load -loadfile
set defaultFlags [concat $defaultFlags \
[ ::tcltest::processCmdLineArgsAddFlagsHook ]]
@@ -825,37 +1002,43 @@ proc ::tcltest::processCmdLineArgs {} {
set tmpDirError ""
if {[info exists flag(-tmpdir)]} {
set ::tcltest::temporaryDirectory $flag(-tmpdir)
-
- if {![string equal \
- [file pathtype $::tcltest::temporaryDirectory] \
- "absolute"]} {
- set ::tcltest::temporaryDirectory [file join [pwd] \
- $::tcltest::temporaryDirectory]
- }
+
+ MakeAbsolutePath ::tcltest::temporaryDirectory
set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
}
if {[file exists $::tcltest::temporaryDirectory]} {
- if {![file isdir $::tcltest::temporaryDirectory]} {
- ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
- is not a directory"
- exit 1
- } elseif {![file writable $::tcltest::temporaryDirectory]} {
- ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
- is not writeable"
- exit 1
- } elseif {![file readable $::tcltest::temporaryDirectory]} {
- ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
- is not readable"
- exit 1
- }
+ ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError
} else {
file mkdir $::tcltest::temporaryDirectory
}
- set oldpwd [pwd]
- cd $::tcltest::temporaryDirectory
- set ::tcltest::temporaryDirectory [pwd]
- cd $oldpwd
+ NormalizePath ::tcltest::temporaryDirectory
+
+ # 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 \
@@ -868,20 +1051,35 @@ proc ::tcltest::processCmdLineArgs {} {
if {[info exists flag(-outfile)]} {
set tmp $flag(-outfile)
- if {![string equal [file pathtype $tmp] "absolute"]} {
- set tmp [file join $::tcltest::temporaryDirectory $tmp]
- }
+ MakeAbsolutePath tmp $::tcltest::temporaryDirectory
set ::tcltest::outputChannel [open $tmp w]
}
if {[info exists flag(-errfile)]} {
set tmp $flag(-errfile)
- if {![string equal [file pathtype $tmp] "absolute"]} {
- set tmp [file join $::tcltest::temporaryDirectory $tmp]
- }
+ MakeAbsolutePath tmp $::tcltest::temporaryDirectory
set ::tcltest::errorChannel [open $tmp w]
}
+ # 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])} {
+ set ::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
+ }
+
# If the user specifies debug testing, print out extra information during
# the run.
if {[info exists flag(-debug)]} {
@@ -896,21 +1094,40 @@ proc ::tcltest::processCmdLineArgs {} {
# Call the hook
::tcltest::processCmdLineArgsHook [array get flag]
- # Spit out everything you know if we're at debug level 2 or greater
- if {$::tcltest::debug > 1} {
- puts "Flags passed into tcltest:"
- parray flag
- puts "::tcltest::debug = $::tcltest::debug"
- puts "::tcltest::testsDirectory = $::tcltest::testsDirectory"
- puts "::tcltest::workingDirectory = $::tcltest::workingDirectory"
- puts "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
- puts "::tcltest::outputChannel = $::tcltest::outputChannel"
- puts "::tcltest::errorChannel = $::tcltest::errorChannel"
- puts "Original environment (::tcltest::originalEnv):"
- parray ::tcltest::originalEnv
- puts "Constraints:"
- parray ::tcltest::testConstraints
+ # Spit out everything you know if we're at a debug level 2 or greater
+
+ 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
+ DebugPuts 2 "Constraints:"
+ DebugPArray 2 ::tcltest::testConstraints
+}
+
+# ::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
+
+proc ::tcltest::loadTestedCommands {} {
+ if {$::tcltest::loadScript == {}} {
+ return
}
+
+ uplevel #0 $::tcltest::loadScript
}
# ::tcltest::cleanupTests --
@@ -1153,9 +1370,8 @@ if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
# expectedAnswer - Expected result from script.
proc ::tcltest::test {name description script expectedAnswer args} {
- if {$::tcltest::debug > 2} {
- puts "Running $name ($description)"
- }
+
+ DebugPuts 3 "Running $name ($description)"
incr ::tcltest::numTests(Total)
@@ -1164,9 +1380,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
foreach pattern $::tcltest::skip {
if {[string match $pattern $name]} {
incr ::tcltest::numTests(Skipped)
- if {$::tcltest::debug} {
- ::tcltest::AddToSkippedBecause userSpecifiedSkip
- }
+ DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip}
return
}
}
@@ -1183,9 +1397,7 @@ proc ::tcltest::test {name description script expectedAnswer args} {
}
if {!$ok} {
incr ::tcltest::numTests(Skipped)
- if {$::tcltest::debug} {
- ::tcltest::AddToSkippedBecause userSpecifiedNonMatch
- }
+ DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
return
}
}
@@ -1422,9 +1634,7 @@ proc ::tcltest::leakfiles {old} {
proc ::tcltest::saveState {} {
uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
- if {$::tcltest::debug > 1} {
- puts "::tcltest::saveState: $::tcltest::saveState"
- }
+ DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState"
}
# ::tcltest::restoreState --
@@ -1443,18 +1653,15 @@ proc ::tcltest::restoreState {} {
foreach p [info procs] {
if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
(![string equal ::tcltest::$p [namespace origin $p]])} {
- if {$::tcltest::debug > 2} {
- puts "::tcltest::restoreState: Removing proc $p"
- }
+
+ DebugPuts 3 "::tcltest::restoreState: Removing proc $p"
rename $p {}
}
}
foreach p [uplevel #0 {info vars}] {
if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
- if {$::tcltest::debug > 2} {
- puts "::tcltest::restoreState: Removing variable $p"
- }
- uplevel #0 "unset $p"
+ DebugPuts 3 "::tcltest::restoreState: Removing variable $p"
+ uplevel #0 "catch {unset $p}"
}
}
}
@@ -1485,9 +1692,8 @@ proc ::tcltest::normalizeMsg {msg} {
proc ::tcltest::makeFile {contents name} {
global tcl_platform
- if {$::tcltest::debug > 2} {
- puts "::tcltest::makeFile: putting $contents into $name"
- }
+ DebugPuts 3 "::tcltest::makeFile: putting $contents into $name"
+
set fd [open [file join $::tcltest::temporaryDirectory $name] w]
fconfigure $fd -translation lf
@@ -1516,9 +1722,7 @@ proc ::tcltest::makeFile {contents name} {
#
proc ::tcltest::removeFile {name} {
- if {$::tcltest::debug > 2} {
- puts "::tcltest::removeFile: removing $name"
- }
+ DebugPuts 3 "::tcltest::removeFile: removing $name"
file delete [file join $::tcltest::temporaryDirectory $name]
}
@@ -1665,10 +1869,11 @@ proc ::tcltest::threadReap {} {
# 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 ::tcltest] == {}} {
::tcltest::processCmdLineArgs
}
}
-
-return
diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test
index b034077..27de741 100644
--- a/tests/autoMkindex.test
+++ b/tests/autoMkindex.test
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: autoMkindex.test,v 1.6 1999/06/26 03:54:10 jenn Exp $
+# RCS: @(#) $Id: autoMkindex.test,v 1.7 1999/10/19 18:08:44 jenn Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -41,6 +41,9 @@ proc AutoMkindexTestReset {} {
set result ""
+set origDir [pwd]
+cd $::tcltest::testsDirectory
+
test autoMkindex-1.1 {remove any existing tclIndex file} {
file delete tclIndex
file exists tclIndex
@@ -188,4 +191,7 @@ if {[info exists removeAutoMkindex]} {
if {[file exists tclIndex]} {
file delete -force tclIndex
}
+
+cd $origDir
+
::tcltest::cleanupTests
diff --git a/tests/basic.test b/tests/basic.test
index 3d9588b..66c7551 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -15,7 +15,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: basic.test,v 1.8 1999/10/13 00:32:29 hobbs Exp $
+# RCS: @(#) $Id: basic.test,v 1.9 1999/10/19 18:08:44 jenn Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -494,10 +494,10 @@ test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of tra
} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}}
test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
testcmdtrace tracetest {set stuff [info tclversion]}
-} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.3}}
+} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff $::tcltest::version"]
test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
testcmdtrace deletetest {set stuff [info tclversion]}
-} 8.3
+} $::tcltest::version
}
test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test
index 52eb048..7fbb909 100644
--- a/tests/pkgMkIndex.test
+++ b/tests/pkgMkIndex.test
@@ -8,13 +8,16 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: pkgMkIndex.test,v 1.11 1999/07/01 17:36:19 jenn Exp $
+# RCS: @(#) $Id: pkgMkIndex.test,v 1.12 1999/10/19 18:08:44 jenn Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import ::tcltest::*
}
+set origDir [pwd]
+cd $::tcltest::testsDirectory
+
set fullPkgPath [file join $::tcltest::testsDirectory pkg]
# Add the pkg1 directory to auto_path, so that its packages can be found.
@@ -158,6 +161,8 @@ proc pkgtest::createIndex { args } {
set dirPath [lindex $parsed 1]
set patternList [lindex $parsed 2]
+ file mkdir $dirPath
+
if {[catch {
file delete [file join $dirPath pkgIndex.tcl]
eval pkg_mkIndex $options $dirPath $patternList
@@ -243,7 +248,7 @@ proc pkgtest::runIndex { args } {
set result [list 0 [makePkgList [parseIndex $idxFile]]]
} err]} {
set result [list 1 $err]
- }
+ }
file delete $idxFile
} else {
set result $rv
@@ -342,16 +347,7 @@ test pkgMkIndex-11.1 {conflicting namespace imports} {
# cleanup
namespace delete pkgtest
+cd $origDir
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/socket.test b/tests/socket.test
index 6856026..59a3173 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: socket.test,v 1.12 1999/07/01 17:36:19 jenn Exp $
+# RCS: @(#) $Id: socket.test,v 1.13 1999/10/19 18:08:44 jenn Exp $
# Running socket tests with a remote server:
# ------------------------------------------
@@ -1385,6 +1385,7 @@ test socket-12.1 {testing inheritance of server sockets} \
set f [open script2 w]
puts $f [list set tcltest $::tcltest::tcltest]
puts $f {
+ package require tcltest
set f [socket -server accept 2828]
proc accept { file addr port } {
close $file
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 13df747..b5d2b72 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -10,7 +10,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.test,v 1.8 1999/08/27 21:45:18 jenn Exp $
+# RCS: @(#) $Id: tcltest.test,v 1.9 1999/10/19 18:08:44 jenn Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -106,7 +106,7 @@ test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
} {0 1 1 0 1}
-
+
# -skip
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
set result [catch {exec $::tcltest::tcltest test.tcl -skip a* -v 'ps'} msg]
@@ -133,7 +133,7 @@ test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg]
} {0 1 0 0 1}
-
+
# -constraints, -limitconstraints
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
set result [catch {exec $::tcltest::tcltest test.tcl -constraints knownBug -v 'ps'} msg]
@@ -265,6 +265,26 @@ test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc} {
list [regexp {not writeable} [join $msg]]
} {1}
+# -testdir
+test tcltest-8.5 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
+ file delete -force thisdirectorydoesnotexist
+ catch {exec $::tcltest::tcltest a.tcl -testdir thisdirectorydoesnotexist} msg
+ list [regexp "does not exist" [join $msg]]
+} {1}
+
+test tcltest-8.6 {tcltest a.tcl -testdir thisdirectoryisafile} {
+ catch {exec $::tcltest::tcltest a.tcl -testdir thisdirectoryisafile} msg
+ # The join is necessary because the message can be split on multiple lines
+ list [regexp "not a directory" [join $msg]]
+} {1}
+
+test tcltest-8.7 {tcltest a.tcl -testdir notReadableDir} {unixOnly} {
+ catch {exec $::tcltest::tcltest a.tcl -testdir $notReadableDir} msg
+ # The join is necessary because the message can be split on multiple lines
+ list [regexp {not readable} [join $msg]]
+} {1}
+
+
switch $tcl_platform(platform) {
"unix" {
file attributes $notReadableDir -permissions 777
@@ -290,9 +310,12 @@ test tcltest-9.2 {-file a*.tcl} {unixOrPc} {
list [regexp assocd\.test $msg]
} {0}
+
+
makeFile {
package require tcltest
namespace import ::tcltest::*
+
test makecore {make a core file} {
set f [open core w]
close $f
@@ -300,6 +323,7 @@ makeFile {
::tcltest::cleanupTests
return
} makecore.tcl
+
# -preservecore
test tcltest-10.1 {-preservecore 0} {unixOrPc} {
catch {exec $::tcltest::tcltest makecore.tcl -preservecore 0} msg
@@ -347,6 +371,26 @@ test tcltest-11.3 {-args {-foo bar -baz}} {unixOrPc} {
list $msg
} {{=-foo bar -baz=}}
+# -load -loadfile
+makeFile {
+ package require tcltest
+ namespace import ::tcltest::*
+ puts $::tcltest::loadScript
+ exit
+} load.tcl
+
+test tcltest-12.1 {-load xxx} {
+ catch {exec $::tcltest::tcltest load.tcl -load xxx} msg
+ set msg
+} {xxx}
+
+test tcltest-12.1 {-loadfile load.tcl} {
+ catch {exec $::tcltest::tcltest load.tcl -d 2 -loadfile load.tcl} msg
+ list \
+ [regexp {tcltest} [join $msg [split $msg \n]]] \
+ [regexp {loadScript} [join $msg [split $msg \n]]]
+} {1 1}
+
# Begin testing of tcltest procs ...
# PrintError
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 7073cc6..77a6bb4 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unixInit.test,v 1.10 1999/07/08 17:29:30 jenn Exp $
+# RCS: @(#) $Id: unixInit.test,v 1.11 1999/10/19 18:08:44 jenn Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -27,7 +27,7 @@ set env(LANG) C
# Some tests will fail if they are run on a machine that doesn't have
# this Tcl version installed (as opposed to built) on it.
if {[catch {
- set f [open "|[list $::tcltest::tcltest]" w+]
+ set f [open "|[list $::tcltest::tcltest exit]" w+]
exec kill -PIPE [pid $f]
close $f
}]} {
@@ -35,6 +35,7 @@ if {[catch {
} else {
set ::tcltest::testConstraints(installedTcl) 1
}
+
test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly installedTcl} {
set x {}
diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test
index ac0f169..2552d2a 100644
--- a/tests/unixNotfy.test
+++ b/tests/unixNotfy.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: unixNotfy.test,v 1.7 1999/07/01 17:36:20 jenn Exp $
+# RCS: @(#) $Id: unixNotfy.test,v 1.8 1999/10/19 18:08:44 jenn Exp $
# The tests should not be run if you have a notifier which is unable to
# detect infinite vwaits, as the tests below will hang. The presence of
@@ -21,6 +21,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import ::tcltest::*
}
+if {[info exists tk_version]} {
+ puts "When run in a Tk shell, these tests run hang. Skipping tests ..."
+ ::tcltest::cleanupTests
+ return
+}
+
set ::tcltest::testConstraints(testthread) \
[expr {[info commands testthread] != {}}]
generated by cgit v0.12 at 2024-11-05 09:46:31 (GMT)