summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/tcltest/tcltest.tcl443
-rw-r--r--library/tcltest1.0/tcltest.tcl443
2 files changed, 648 insertions, 238 deletions
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
generated by cgit v0.12 at 2024-12-12 09:43:03 (GMT)