# This file contains support code for the Tcl test suite. It
# defines the tcltest namespace and finds and defines the output
# directory, constraints available, output and error channels,
# etc. used by Tcl tests. See the tcltest man page for more
# This design was based on the Tcl testing approach designed and
# initially implemented by Mary Ann May-Pumphrey of Sun
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# RCS: @(#) $Id: tcltest.tcl,v 1.78.2.13 2005/02/24 18:03:36 dgp Exp $
package require
Tcl 8.3 ;# uses [glob -directory]
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version
[package provide
Tcl]
variable patchLevel
[info patchlevel
]
##### Export the public tcltest procs; several categories
# Export the main functional commands that do useful things
namespace export cleanupTests loadTestedCommands makeDirectory
\
makeFile removeDirectory removeFile runAllTests test
# Export configuration commands that control the functional commands
namespace export configure customMatch errorChannel interpreter
\
outputChannel testConstraint
# Export commands that are duplication (candidates for deprecation)
namespace export bytestring
;# dups [encoding convertfrom identity]
namespace export debug
;# [configure -debug]
namespace export errorFile
;# [configure -errfile]
namespace export limitConstraints
;# [configure -limitconstraints]
namespace export loadFile
;# [configure -loadfile]
namespace export loadScript
;# [configure -load]
namespace export match
;# [configure -match]
namespace export matchFiles
;# [configure -file]
namespace export matchDirectories
;# [configure -relateddir]
namespace export normalizeMsg
;# application of [customMatch]
namespace export normalizePath
;# [file normalize] (8.4)
namespace export outputFile
;# [configure -outfile]
namespace export preserveCore
;# [configure -preservecore]
namespace export singleProcess
;# [configure -singleproc]
namespace export skip
;# [configure -skip]
namespace export skipFiles
;# [configure -notfile]
namespace export skipDirectories
;# [configure -asidefromdir]
namespace export temporaryDirectory
;# [configure -tmpdir]
namespace export testsDirectory
;# [configure -testdir]
namespace export verbose
;# [configure -verbose]
namespace export viewFile
;# binary encoding [read]
namespace export workingDirectory
;# [cd] [pwd]
# Export deprecated commands for tcltest 1 compatibility
namespace export getMatchingFiles mainThread restoreState saveState
\
# 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.
# pathVar - name of variable containing path to modify.
# The path is modified in place.
proc normalizePath
{pathVar
} {
##### Verification commands used to test values of variables and options
# Verification command that accepts everything
# Verification command that accepts valid Tcl lists
proc AcceptList
{ list } {
return [lrange $list 0 end
]
# Verification command that accepts a glob pattern
proc AcceptPattern
{ pattern
} {
return [AcceptAll
$pattern]
# Verification command that accepts integers
proc AcceptInteger
{ level
} {
# Verification command that accepts boolean values
proc AcceptBoolean
{ boolean
} {
return [expr {$boolean && $boolean}]
# Verification command that accepts (syntactically) valid Tcl scripts
proc AcceptScript
{ script
} {
if {![info complete
$script]} {
return -code error "invalid Tcl script: $script"
# Verification command that accepts (converts to) absolute pathnames
proc AcceptAbsolutePath
{ path
} {
return [file join [pwd] $path]
# Verification command that accepts existing readable directories
proc AcceptReadable
{ path
} {
if {![file readable
$path]} {
return -code error "\"$path\" is not readable"
proc AcceptDirectory
{ directory
} {
set directory
[AcceptAbsolutePath
$directory]
if {![file exists
$directory]} {
return -code error "\"$directory\" does not exist"
if {![file isdir
$directory]} {
return -code error "\"$directory\" is not a directory"
return [AcceptReadable
$directory]
##### Initialize internal arrays of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
# compatibility with older tests that directly access internals
# rather than go through command interfaces.
proc ArrayDefault
{varName value
} {
if {[array exists
$varName]} {
if {[info exists
$varName]} {
# Pre-initialized value is a scalar: destroy it!
array set $varName $value
# save the original environment so that it can be restored later
ArrayDefault originalEnv
[array get
::env]
# initialize numTests array to keep track of the number of tests
# that pass, fail, and are skipped.
ArrayDefault numTests
[list Total
0 Passed
0 Skipped
0 Failed
0]
# createdNewFiles will store test files as indices and the list of
# files (that should not have been) left behind by the test files
ArrayDefault createdNewFiles
{}
# initialize skippedBecause array to keep track of constraints that
# kept tests from running; a constraint name of "userSpecifiedSkip"
# means that the test appeared on the list of tests that matched the
# -skip value given to the flag; "userSpecifiedNonMatch" means that
# the test didn't match the argument given to the -match flag; both
# of these constraints are counted only if tcltest::debug is set to
ArrayDefault skippedBecause
{}
# initialize the testConstraints array to keep track of valid
# predefined constraints (see the explanation for the
# InitConstraints proc for more details).
ArrayDefault testConstraints
{}
##### Initialize internal variables of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
# compatibility with older tests that directly access internals
# rather than go through command interfaces.
proc Default
{varName value
{verify AcceptAll
}} {
if {![info exists
$varName]} {
variable $varName [$verify $value]
variable $varName [$verify [set $varName]]
# Save any arguments that we might want to pass through to other
# programs. This is used by the -args flag.
# Count the number of files tested (0 if runAllTests wasn't called).
# runAllTests will set testSingleFile to false, so stats will
# not be printed until runAllTests calls the cleanupTests proc.
# The currentFailure var stores the boolean value of whether the
# current test file has had any failures. The failFiles list
# stores the names of test files that had failures.
Default numTestFiles
0 AcceptInteger
Default testSingleFile true AcceptBoolean
Default currentFailure false AcceptBoolean
Default failFiles
{} AcceptList
# Tests should remove all files they create. The test suite will
# check the current working dir for files created by the tests.
# filesMade keeps track of such files created using the makeFile and
# makeDirectory procedures. filesExisted stores the names of
# Note that $filesExisted lists only those files that exist in
# the original [temporaryDirectory].
Default filesMade
{} AcceptList
Default filesExisted
{} AcceptList
proc FillFilesExisted
{} {
# Save the names of files that already exist in the scratch directory.
foreach file [glob -nocomplain -directory [temporaryDirectory
] *] {
lappend filesExisted
[file tail
$file]
# After successful filling, turn this into a no-op.
proc FillFilesExisted args
{}
# Kept only for compatibility
Default constraintsSpecified
{} AcceptList
trace variable constraintsSpecified r
{set ::tcltest::constraintsSpecified \
[array names
::tcltest::testConstraints] ;# }
# tests that use threads need to know which is the main thread
if {[info commands thread
::id] != {}} {
set mainThread
[thread
::id]
} elseif
{[info commands testthread
] != {}} {
set mainThread
[testthread id
]
# Set workingDirectory to [pwd]. The default output directory for
# Tcl tests is the working directory. Whenever this value changes
# change to that directory.
variable workingDirectory
trace variable workingDirectory w
\
[namespace code
{cd $workingDirectory ;#}]
Default workingDirectory
[pwd] AcceptAbsolutePath
proc workingDirectory
{ {dir
""} } {
variable workingDirectory
if {[llength [info level
0]] == 1} {
set workingDirectory
[AcceptAbsolutePath
$dir]
# Set the location of the execuatble
Default
tcltest [info nameofexecutable
]
trace variable tcltest w
[namespace code
{testConstraint stdio
\
[eval [ConstraintInitializer stdio
]] ;#}]
# save the platform information so it can be restored later
Default originalTclPlatform
[array get
::tcl_platform]
# If a core file exists, save its modification time.
if {[file exists
[file join [workingDirectory
] core
]]} {
[file mtime
[file join [workingDirectory
] core
]]
# stdout and stderr buffers for use when we want to store them
# keep track of test level for nested test commands
# the variables and procs that existed when saveState was called are
# stored in a variable of the same name
# Internationalization support -- used in [SetIso8859_1_Locale] and
# [RestoreLocale]. Those commands are used in cmdIL.test.
if {![info exists
[namespace current
]::isoLocale]} {
switch -- $::tcl_platform(platform
) {
# Try some 'known' values for some platforms:
switch -exact -- $::tcl_platform(os
) {
set isoLocale fr_FR.ISO_8859-1
set isoLocale fr_FR.iso88591
# Works on SunOS 4 and Solaris, and maybe
# others... Define it to something else on your
# system if you want to test those.
variable ChannelsWeOpened
; array set ChannelsWeOpened
{}
# output goes to stdout by default
Default outputChannel stdout
proc outputChannel
{ {filename ""} } {
variable ChannelsWeOpened
# This is very subtle and tricky, so let me try to explain.
# (Hopefully this longer comment will be clear when I come
# back in a few months, unlike its predecessor :) )
# The [outputChannel] command (and underlying variable) have to
# be kept in sync with the [configure -outfile] configuration
# option ( and underlying variable Option(-outfile) ). This is
# accomplished with a write trace on Option(-outfile) that will
# update [outputChannel] whenver a new value is written. That
# The trick is that in order to maintain compatibility with
# version 1 of tcltest, we must allow every configuration option
# to get its inital value from command line arguments. This is
# accomplished by setting initial read traces on all the
# configuration options to parse the command line option the first
# time they are read. These traces are cancelled whenever the
# program itself calls [configure].
# OK, then so to support tcltest 1 compatibility, it seems we want
# to get the return from [outputFile] to trigger the read traces,
# BUT! A little known feature of Tcl variable traces is that
# traces are disabled during the handling of other traces. So,
# if we trigger read traces on Option(-outfile) and that triggers
# command line parsing which turns around and sets an initial
# value for Option(-outfile) -- <whew!> -- the write trace that
# would keep [outputChannel] in sync with that new initial value
# SO, finally, as a workaround, instead of triggering read traces
# by invoking [outputFile], we instead trigger the same set of
# read traces by invoking [debug]. Any command that reads a
# configuration option would do. [debug] is just a handy one.
# The end result is that we support tcltest 1 compatibility and
# keep outputChannel and -outfile in sync in all cases.
if {[llength [info level
0]] == 1} {
if {[info exists ChannelsWeOpened
($outputChannel)]} {
unset ChannelsWeOpened
($outputChannel)
switch -exact -- $filename {
set outputChannel
$filename
set outputChannel
[open $filename a
]
set ChannelsWeOpened
($outputChannel) 1
# If we created the file in [temporaryDirectory], then
# [cleanupTests] will delete it, unless we claim it was
set outdir
[normalizePath
[file dirname
\
[file join [pwd] $filename]]]
if {[string equal
$outdir [temporaryDirectory
]]} {
set filename [file tail
$filename]
if {[lsearch -exact $filesExisted $filename] == -1} {
lappend filesExisted
$filename
# errors go to stderr by default
Default errorChannel stderr
proc errorChannel
{ {filename ""} } {
variable ChannelsWeOpened
# This is subtle and tricky. See the comment above in
# [outputChannel] for a detailed explanation.
if {[llength [info level
0]] == 1} {
if {[info exists ChannelsWeOpened
($errorChannel)]} {
unset ChannelsWeOpened
($errorChannel)
switch -exact -- $filename {
set errorChannel
$filename
set errorChannel
[open $filename a
]
set ChannelsWeOpened
($errorChannel) 1
# If we created the file in [temporaryDirectory], then
# [cleanupTests] will delete it, unless we claim it was
set outdir
[normalizePath
[file dirname
\
[file join [pwd] $filename]]]
if {[string equal
$outdir [temporaryDirectory
]]} {
set filename [file tail
$filename]
if {[lsearch -exact $filesExisted $filename] == -1} {
lappend filesExisted
$filename
##### Set up the configurable options
# The configurable options of the package
variable Option
; array set Option
{}
# Usage strings for those options
variable Usage
; array set Usage
{}
# Verification commands for those options
variable Verify
; array set Verify
{}
# Initialize the default values of the configurable options that are
# historically associated with an exported variable. If that variable
# is already set, support compatibility by accepting its pre-set value.
# Use [trace] to establish ongoing connection between the deprecated
# exported variable and the modern option kept as a true internal var.
# Also set up usage string and value testing for the option.
proc Option
{option value usage
{verify AcceptAll
} {varName
{}}} {
variable OptionControlledVariables
set Usage
($option) $usage
set Verify
($option) $verify
if {[catch {$verify $value} msg
]} {
if {[string length
$varName]} {
if {[info exists
$varName]} {
if {[catch {$verify [set $varName]} msg
]} {
namespace eval [namespace current
] \
[list upvar 0 Option
($option) $varName]
# Workaround for Bug (now Feature Request) 572889. Grrrr....
# Track all the variables tied to options
lappend OptionControlledVariables
$varName
# Later, set auto-configure read traces on all
# of them, since a single trace on Option does not work.
proc $varName {{value
{}}} [subst -nocommands {
if {[llength [info level
0]] == 2} {
Configure
$option [set value
]
return [Configure
$option]
proc MatchingOption
{option} {
set match
[array names Option
$option*]
switch -- [llength $match] {
set sorted
[lsort [array names Option
]]
set values
[join [lrange $sorted 0 end-1
] ", "]
append values
", or [lindex $sorted end]"
return -code error "unknown option $option: should be\
# Exact match trumps ambiguity
if {[lsearch -exact $match $option] >= 0} {
set values
[join [lrange $match 0 end-1
] ", "]
append values
", or [lindex $match end]"
return -code error "ambiguous option $option:\
proc EstablishAutoConfigureTraces
{} {
variable OptionControlledVariables
foreach varName
[concat $OptionControlledVariables Option
] {
trace variable $varName r
[namespace code
{ProcessCmdLineArgs
;#}]
proc RemoveAutoConfigureTraces
{} {
variable OptionControlledVariables
foreach varName
[concat $OptionControlledVariables Option
] {
foreach pair
[trace vinfo
$varName] {
foreach {op cmd
} $pair break
&& [string match
*ProcessCmdLineArgs
* $cmd]} {
trace vdelete
$varName $op $cmd
# Once the traces are removed, this can become a no-op
proc RemoveAutoConfigureTraces
{} {}
return [lsort [array names Option
]]
if {[catch {MatchingOption
[lindex $args 0]} option]} {
return -code error $option
while {[llength $args] > 1} {
if {[catch {MatchingOption
[lindex $args 0]} option]} {
return -code error $option
if {[catch {$Verify($option) [lindex $args 1]} value
]} {
return -code error "invalid $option\
value \"[lindex $args 1]\": $value"
set Option
($option) $value
set args
[lrange $args 2 end
]
if {[catch {MatchingOption
[lindex $args 0]} option]} {
return -code error $option
return -code error "missing value for option $option"
RemoveAutoConfigureTraces
set code
[catch {eval Configure
$args} msg
]
proc AcceptVerbose
{ level
} {
set level
[AcceptList
$level]
if {[llength $level] == 1} {
if {![regexp {^
(pass|body|skip|start|
error)$} $level]} {
# translate single characters abbreviations to expanded list
set level
[string map
{p pass b body s skip t start e
error} \
if {[regexp {^
(pass|body|skip|start|
error)$} $v]} {
return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
# Default verbosity is to show bodies of failed tests
Option
-verbose {body
error} {
Takes any combination of the values 'p'
, 's'
, 'b'
, 't' and 'e'.
Test suite will display all passed tests
if 'p' is specified
, all
skipped tests
if 's' is specified
, the bodies of failed tests
if
'b' is specified
, and when tests start
if 't' is specified.
ErrorInfo is displayed
if 'e' is specified.
# Match and skip patterns default to the empty list, except for
# matchFiles, which defaults to all .test files in the
# testsDirectory and matchDirectories, which defaults to all
Run all tests within the specified files that match one of the
list of
glob patterns given.
Skip all tests within the specified tests
(via
-match) and files
that match one of the
list of
glob patterns given.
Run tests in all test files that match the
glob pattern given.
} AcceptPattern matchFiles
# By default, skip files that appear to be SCCS lock files.
Option
-notfile l.
*.test
{
Skip all test files that match the
glob pattern given.
} AcceptPattern skipFiles
Run tests in directories that match the
glob pattern given.
} AcceptPattern matchDirectories
Option
-asidefromdir {} {
Skip tests in directories that match the
glob pattern given.
} AcceptPattern skipDirectories
# By default, don't save core files
If
2, save any core files produced during testing in the directory
specified by
-tmpdir. If
1, notify the user
if core files are
} AcceptInteger preserveCore
# debug output doesn't get printed by default; debug level 1 spits
# up only the tests that were skipped because they didn't match or
# were specifically skipped. A debug level of 2 would spit up the
# tcltest variables and flags provided; a debug level of 3 causes
# some additional output regarding operations of the test harness.
# The tcltest package currently implements only up to debug level 3.
proc SetSelectedConstraints args
{
foreach c
$Option(-constraints) {
Do not skip the listed constraints listed in
-constraints.
trace variable Option
(-constraints) w
\
[namespace code
{SetSelectedConstraints
;#}]
# Don't run only the "-constraint" specified tests by default
proc ClearUnselectedConstraints args
{
if {!$Option(-limitconstraints)} {return}
foreach c
[array names testConstraints
] {
if {[lsearch -exact $Option(-constraints) $c] == -1} {
Option
-limitconstraints false
{
whether to run only tests with the constraints
} AcceptBoolean limitConstraints
trace variable Option
(-limitconstraints) w
\
[namespace code
{ClearUnselectedConstraints
;#}]
# A test application has to know how to load the tested commands
Specifies the script to
load the tested commands.
} AcceptScript loadScript
# Default is to run each test file in a separate process
whether to run all tests in one process
} AcceptBoolean singleProcess
proc AcceptTemporaryDirectory
{ directory
} {
set directory
[AcceptAbsolutePath
$directory]
if {![file exists
$directory]} {
set directory
[AcceptDirectory
$directory]
if {![file writable
$directory]} {
if {[string equal
[workingDirectory
] $directory]} {
# Special exception: accept the default value
# even if the directory is not writable
return -code error "\"$directory\" is not writeable"
# Directory where files should be created
Option
-tmpdir [workingDirectory
] {
Save temporary files in the specified directory.
} AcceptTemporaryDirectory temporaryDirectory
trace variable Option
(-tmpdir) w
\
[namespace code
{normalizePath Option
(-tmpdir) ;#}]
# Tests should not rely on the current working directory.
# Files that are part of the test suite should be accessed relative
Option
-testdir [workingDirectory
] {
Search tests in the specified directory.
} AcceptDirectory testsDirectory
trace variable Option
(-testdir) w
\
[namespace code
{normalizePath Option
(-testdir) ;#}]
proc AcceptLoadFile
{ file } {
if {[string equal
"" $file]} {return $file}
set file [file join [temporaryDirectory
] $file]
return [AcceptReadable
$file]
proc ReadLoadScript
{args
} {
if {[string equal
"" $Option(-loadfile)]} {return}
set tmp
[open $Option(-loadfile) r
]
Read the script to
load the tested commands from the specified
file.
} AcceptLoadFile loadFile
trace variable Option
(-loadfile) w
[namespace code ReadLoadScript
]
proc AcceptOutFile
{ file } {
if {[string equal stderr
$file]} {return $file}
if {[string equal stdout
$file]} {return $file}
return [file join [temporaryDirectory
] $file]
# output goes to stdout by default
Send output from test runs to the specified
file.
} AcceptOutFile outputFile
trace variable Option
(-outfile) w
\
[namespace code
{outputChannel
$Option(-outfile) ;#}]
# errors go to stderr by default
Send errors from test runs to the specified
file.
} AcceptOutFile errorFile
trace variable Option
(-errfile) w
\
[namespace code
{errorChannel
$Option(-errfile) ;#}]
#####################################################################
# 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.
# Prints the specified string if the current debug level is
# higher than the provided level argument.
# level The lowest debug level triggering the output
# string The string to print out.
# Prints the string. Nothing else is allowed.
proc tcltest::DebugPuts {level
string} {
# tcltest::DebugPArray --
# Prints the contents of the specified array if the current
# debug level is higher than the provided level argument
# level The lowest debug level triggering the output
# arrayvar The name of the array to print out.
# Prints the contents of the array. Nothing else is allowed.
proc tcltest::DebugPArray {level arrayvar
} {
catch {upvar $arrayvar $arrayvar}
# Define our own [parray] in ::tcltest that will inherit use of the [puts]
# defined in ::tcltest. NOTE: Ought to construct with [info args] and
# [info default], but can't be bothered now. If [parray] changes, then
# this will need changing too.
proc tcltest::parray {a
{pattern
*}} [info body
::parray]
# Executes the script if the current debug level is greater than
# the provided level argument
# level The lowest debug level triggering the execution.
# script The tcl script executed upon a debug level high enough.
# Arbitrary side effects, dependent on the executed script.
proc tcltest::DebugDo {level script
} {
#####################################################################
proc tcltest::Warn {msg
} {
puts [outputChannel
] "WARNING: $msg"
# Accessor command for tcltest variable mainThread.
proc tcltest::mainThread { {new
""} } {
if {[llength [info level
0]] == 1} {
# tcltest::testConstraint --
# sets a test constraint to a value; to do multiple constraints,
# call this proc multiple times. also returns the value of the
# named constraint if no value was supplied.
# constraint - name of the constraint
# value - new value for constraint (should be boolean) - if not
# supplied, this is a query
# content of tcltest::testConstraints($constraint)
proc tcltest::testConstraint {constraint
{value
""}} {
DebugPuts
3 "entering testConstraint $constraint $value"
if {[llength [info level
0]] == 2} {
return $testConstraints($constraint)
# Check for boolean values
if {[catch {expr {$value && $value}} msg
]} {
&& [lsearch -exact $Option(-constraints) $constraint] == -1} {
set testConstraints
($constraint) $value
# tcltest::interpreter --
# the interpreter name stored in tcltest::tcltest
# content of tcltest::tcltest
proc tcltest::interpreter { {interp ""} } {
if {[llength [info level
0]] == 1} {
if {[string equal
{} $interp]} {
#####################################################################
# tcltest::AddToSkippedBecause --
# Increments the variable used to track how many tests were
# skipped because of a particular constraint.
# constraint The name of the constraint to be modified
# Modifies tcltest::skippedBecause; sets the variable to 1 if
# didn't previously exist - otherwise, it just increments it.
proc tcltest::AddToSkippedBecause { constraint
{value
1}} {
# add the constraint to the list of constraints that kept tests
if {[info exists skippedBecause
($constraint)]} {
incr skippedBecause
($constraint) $value
set skippedBecause
($constraint) $value
# Prints errors to tcltest::errorChannel and then flushes that
# channel, making sure that all messages are < 80 characters per
# errorMsg String containing the error to be printed
proc tcltest::PrintError {errorMsg
} {
set InitialMessage
"Error: "
set InitialMsgLen
[string length
$InitialMessage]
puts -nonewline [errorChannel
] $InitialMessage
# Keep track of where the end of the string is.
set endingIndex
[string length
$errorMsg]
if {$endingIndex < (80 - $InitialMsgLen)} {
puts [errorChannel
] $errorMsg
# Print up to 80 characters on the first line, including the
set beginningIndex
[string last
" " [string range
$errorMsg 0 \
[expr {80 - $InitialMsgLen}]]]
puts [errorChannel
] [string range
$errorMsg 0 $beginningIndex]
while {![string equal end
$beginningIndex]} {
puts -nonewline [errorChannel
] \
[string repeat
" " $InitialMsgLen]
if {($endingIndex - $beginningIndex)
< (80 - $InitialMsgLen)} {
puts [errorChannel
] [string trim
\
[string range
$errorMsg $beginningIndex end
]]
set newEndingIndex
[expr {[string last
" " \
[string range
$errorMsg $beginningIndex \
+ (80 - $InitialMsgLen)}]
if {($newEndingIndex <= 0)
||
($newEndingIndex <= $beginningIndex)} {
puts [errorChannel
] [string trim
\
[string range
$errorMsg \
$beginningIndex $newEndingIndex]]
set beginningIndex
$newEndingIndex
# The following trace procedure makes it so that we can safely
# refer to non-existent members of the testConstraints array
# without causing an error. Instead, reading a non-existent
# member will return 0. This is necessary because tests are
# allowed to use constraint "X" without ensuring that
# testConstraints("X") is defined.
# n1 - name of the array (testConstraints)
# n2 - array key value (constraint name)
# op - operation performed on testConstraints (generally r)
# sets testConstraints($n2) to 0 if it's referenced but never
proc tcltest::SafeFetch {n1 n2 op
} {
DebugPuts
3 "entering SafeFetch $n1 $n2 $op"
if {[string equal
{} $n2]} {return}
if {![info exists testConstraints
($n2)]} {
if {[catch {testConstraint
$n2 [eval [ConstraintInitializer
$n2]]}]} {
# tcltest::ConstraintInitializer --
# Get or set a script that when evaluated in the tcltest namespace
# will return a boolean value with which to initialize the
# constraint - name of the constraint initialized by the script
# script - the initializer script
# boolean value of the constraint - enabled or disabled
# Constraint is initialized for future reference by [test]
proc tcltest::ConstraintInitializer {constraint
{script
""}} {
variable ConstraintInitializer
DebugPuts
3 "entering ConstraintInitializer $constraint $script"
if {[llength [info level
0]] == 2} {
return $ConstraintInitializer($constraint)
# Check for boolean values
if {![info complete
$script]} {
return -code error "ConstraintInitializer must be complete script"
set ConstraintInitializer
($constraint) $script
# tcltest::InitConstraints --
# Call all registered constraint initializers to force initialization
# of all known constraints.
# See the tcltest man page for the list of built-in constraints defined
# The testConstraints array is reset to have an index for each
# built-in test constraint.
proc tcltest::InitConstraints {} {
variable ConstraintInitializer
foreach constraint
[array names ConstraintInitializer
] {
testConstraint
$constraint
proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer singleTestInterp
{singleProcess
}
# All the 'pc' constraints are here for backward compatibility and
# are not documented. They have been replaced with equivalent 'win'
ConstraintInitializer unixOnly
\
{string equal
$::tcl_platform(platform
) unix
}
ConstraintInitializer macOnly
\
{string equal
$::tcl_platform(platform
) macintosh
}
ConstraintInitializer pcOnly
\
{string equal
$::tcl_platform(platform
) windows
}
ConstraintInitializer winOnly
\
{string equal
$::tcl_platform(platform
) windows
}
ConstraintInitializer unix
{testConstraint unixOnly
}
ConstraintInitializer mac
{testConstraint macOnly
}
ConstraintInitializer pc
{testConstraint pcOnly
}
ConstraintInitializer win
{testConstraint winOnly
}
ConstraintInitializer unixOrPc
\
{expr {[testConstraint unix
] ||
[testConstraint pc
]}}
ConstraintInitializer macOrPc
\
{expr {[testConstraint mac
] ||
[testConstraint pc
]}}
ConstraintInitializer unixOrWin
\
{expr {[testConstraint unix
] ||
[testConstraint win
]}}
ConstraintInitializer macOrWin
\
{expr {[testConstraint mac
] ||
[testConstraint win
]}}
ConstraintInitializer macOrUnix
\
{expr {[testConstraint mac
] ||
[testConstraint unix
]}}
ConstraintInitializer nt
{string equal
$::tcl_platform(os
) "Windows NT"}
ConstraintInitializer
95 {string equal
$::tcl_platform(os
) "Windows 95"}
ConstraintInitializer
98 {string equal
$::tcl_platform(os
) "Windows 98"}
# The following Constraints switches are used to mark tests that
# should work, but have been temporarily disabled on certain
# platforms because they don't and we haven't gotten around to
# fixing the underlying problem.
ConstraintInitializer tempNotPc
{expr {![testConstraint pc
]}}
ConstraintInitializer tempNotWin
{expr {![testConstraint win
]}}
ConstraintInitializer tempNotMac
{expr {![testConstraint mac
]}}
ConstraintInitializer tempNotUnix
{expr {![testConstraint unix
]}}
# The following Constraints switches are used to mark tests that
# crash on certain platforms, so that they can be reactivated again
# when the underlying problem is fixed.
ConstraintInitializer pcCrash
{expr {![testConstraint pc
]}}
ConstraintInitializer winCrash
{expr {![testConstraint win
]}}
ConstraintInitializer macCrash
{expr {![testConstraint mac
]}}
ConstraintInitializer unixCrash
{expr {![testConstraint unix
]}}
ConstraintInitializer emptyTest
{format 0}
# By default, tests that expose known bugs are skipped.
ConstraintInitializer knownBug
{format 0}
# By default, non-portable tests are skipped.
ConstraintInitializer nonPortable
{format 0}
# Some tests require user interaction.
ConstraintInitializer userInteraction
{format 0}
# Some tests must be skipped if the interpreter is not in
ConstraintInitializer interactive
\
{expr {[info exists
::tcl_interactive] && $::tcl_interactive}}
# Some tests can only be run if the installation came from a CD
# image instead of a web image. Some tests must be skipped if you
# are running as root on Unix. Other tests can only be run if you
# are running as root on Unix.
ConstraintInitializer root
{expr \
{[string equal unix
$::tcl_platform(platform
)]
&& ([string equal root
$::tcl_platform(user
)]
||
[string equal
"" $::tcl_platform(user
)])}}
ConstraintInitializer notRoot
{expr {![testConstraint root
]}}
# Set nonBlockFiles constraint: 1 means this platform supports
# setting files into nonblocking mode.
ConstraintInitializer nonBlockFiles
{
set code
[expr {[catch {set f
[open defs r
]}]
||
[catch {fconfigure $f -blocking off
}]}]
# Set asyncPipeClose constraint: 1 means this platform supports
# async flush and async close on a pipe.
# Test for SCO Unix - cannot run async flushing tests because a
# potential problem with select is apparently interfering.
ConstraintInitializer asyncPipeClose
{expr {
!([string equal unix
$::tcl_platform(platform
)]
&& ([catch {exec uname
-X | fgrep
{Release
= 3.2v
}}] == 0))}}
# Test to see if we have a broken version of sprintf with respect
# to the "e" format of floating-point numbers.
ConstraintInitializer eformat
{string equal
[format %g
5e-5] 5e-05}
# Test to see if execed commands such as cat, echo, rm and so forth
# are present on this machine.
ConstraintInitializer unixExecs
{
if {[string equal macintosh
$::tcl_platform(platform
)]} {
if {[string equal windows
$::tcl_platform(platform
)]} {
set file _tcl_test_remove_me.txt
[catch {exec cat
$file}] ||
[catch {exec echo hello
}] ||
[catch {exec sh
-c echo hello
}] ||
[catch {exec wc
$file}] ||
[catch {exec sleep
1}] ||
[catch {exec echo abc
> $file}] ||
[catch {exec chmod
644 $file}] ||
[catch {exec rm
$file}] ||
[llength [auto_execok mkdir
]] == 0 ||
[llength [auto_execok fgrep
]] == 0 ||
[llength [auto_execok grep
]] == 0 ||
[llength [auto_execok ps
]] == 0
ConstraintInitializer stdio
{
if {![catch {set f
[open "|[list [interpreter]]" w
]}]} {
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
# Deliberately call socket with the wrong number of arguments. The
# error message you get will indicate whether sockets are available
ConstraintInitializer
socket {
string compare
$msg "sockets are not available on this system"
# Check for internationalization
ConstraintInitializer hasIsoLocale
{
if {[llength [info commands testlocale
]] == 0} {
set code
[string length
[SetIso8859_1_Locale
]]
#####################################################################
# Usage and command line arguments processing.
# tcltest::PrintUsageInfo
# Prints out the usage information for package tcltest. This can
# be customized with the redefinition of [PrintUsageInfoHook].
proc tcltest::PrintUsageInfo {} {
proc tcltest::Usage { {option ""} } {
if {[llength [info level
0]] == 1} {
set msg
"Usage: [file tail [info nameofexecutable]] script "
append msg
"?-help? ?flag value? ... \n"
append msg
"Available flags (and valid input values) are:"
set allOpts
[concat -help [Configure
]]
foreach [list x type
($opt) usage
($opt)] $foo break
set line
($opt) " $opt $type($opt) "
set length
($opt) [string length
$line($opt)]
if {$length($opt) > $max} {set max
$length($opt)}
set rest
[expr {72 - $max}]
append msg
[string repeat
" " [expr {$max - $length($opt)}]]
set u
[string trim
$usage($opt)]
catch {append u
" (default: \[[Configure $opt]])"}
regsub -all {\s
*\n\s
*} $u " " u
while {[string length
$u] > $rest} {
set break [string wordstart
$u $rest]
set break [string wordend
$u 0]
append msg
[string range
$u 0 [expr {$break - 1}]]
set u
[string trim
[string range
$u $break end
]]
append msg
\n[string repeat
" " $max]
} elseif
{[string equal
-help $option]} {
return [list -help "" "Display this usage information."]
set type
[lindex [info args
$Verify($option)] 0]
return [list $option $type $Usage($option)]
# tcltest::ProcessFlags --
# process command line arguments supplied in the flagArray - this
# is called by processCmdLineArgs. Modifies tcltest variables
# according to the content of the flagArray.
# flagArray - array containing name/value pairs of flags
# sets tcltest variables according to their values as defined by
proc tcltest::ProcessFlags {flagArray
} {
if {[lsearch -exact $flagArray {-help}] != -1} {
if {[llength $flagArray] == 0} {
RemoveAutoConfigureTraces
while {[llength $args]>1 && [catch {eval configure
$args} msg
]} {
# Something went wrong parsing $args for tcltest options
# Check whether the problem is "unknown option"
if {[regexp {^
unknown option (\S
+):} $msg -> option]} {
# Could be this is an option the Hook knows about
set moreOptions
[processCmdLineArgsAddFlagsHook
]
if {[lsearch -exact $moreOptions $option] == -1} {
# Nope. Report the error, including additional options,
if {[llength $moreOptions]} {
append msg
[join [lrange $moreOptions 0 end-1
] ", "]
append msg
"or [lindex $moreOptions end]"
# error is something other than "unknown option"
# notify user of the error; and exit
# To recover, find that unknown option and remove up to it.
while {![string equal
[lindex $args 0] $option]} {
set args
[lrange $args 2 end
]
set args
[lrange $args 2 end
]
if {[llength $args] == 1} {
"missing value for option [lindex $args 0]"
array set flag
$flagArray
processCmdLineArgsHook
[array get flag
]
# tcltest::ProcessCmdLineArgs --
# This procedure must be run after constraint initialization is
# set up (by [DefineConstraintInitializers]) because some constraints
# Perform configuration according to the command-line options.
# Sets the above-named variables in the tcltest namespace.
proc tcltest::ProcessCmdLineArgs {} {
# The "argv" var doesn't exist in some cases, so use {}.
if {![info exists
::argv]} {
# Spit out everything you know if we're at a debug level 2 or
DebugPuts
2 "Flags passed into tcltest:"
if {[info exists
::env(TCLTEST_OPTIONS
)]} {
" ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
if {[info exists
::argv]} {
DebugPuts
2 " argv: $::argv"
DebugPuts
2 "tcltest::debug = [debug]"
DebugPuts
2 "tcltest::testsDirectory = [testsDirectory]"
DebugPuts
2 "tcltest::workingDirectory = [workingDirectory]"
DebugPuts
2 "tcltest::temporaryDirectory = [temporaryDirectory]"
DebugPuts
2 "tcltest::outputChannel = [outputChannel]"
DebugPuts
2 "tcltest::errorChannel = [errorChannel]"
DebugPuts
2 "Original environment (tcltest::originalEnv):"
DebugPArray
2 originalEnv
DebugPuts
2 "Constraints:"
DebugPArray
2 testConstraints
#####################################################################
# Code to run the tests goes here.
# Used to redefine puts in test environment. Stores whatever goes
# out on stdout in tcltest::outData and stderr in errData before
# sending it on to the regular puts.
# Intercepts puts; data that would otherwise go to stdout, stderr,
# or file channels specified in outputChannel and errorChannel
# does not get sent to the normal puts function.
namespace eval tcltest::Replace {
proc tcltest::Replace::puts {args
} {
variable [namespace parent
]::outData
variable [namespace parent
]::errData
# Only the string to be printed is specified
append outData
[lindex $args 0]\n
# return [Puts [lindex $args 0]]
# Either -nonewline or channelId has been specified
if {[string equal
-nonewline [lindex $args 0]]} {
append outData
[lindex $args end
]
# return [Puts -nonewline [lindex $args end]]
set channel
[lindex $args 0]
if {[string equal
-nonewline [lindex $args 0]]} {
# Both -nonewline and channelId are specified, unless
# it's an error. -nonewline is supposed to be argv[0].
set channel
[lindex $args 1]
if {[info exists channel
]} {
if {[string equal
$channel [[namespace parent
]::outputChannel]]
||
[string equal
$channel stdout
]} {
append outData
[lindex $args end
]$newline
} elseif
{[string equal
$channel [[namespace parent
]::errorChannel]]
||
[string equal
$channel stderr
]} {
append errData
[lindex $args end
]$newline
# If we haven't returned by now, we don't know how to handle the
# input. Let puts handle it.
# Evaluate the script in the test environment. If ignoreOutput is
# false, store data sent to stderr and stdout in outData and
# errData. Otherwise, ignore this output altogether.
# script Script to evaluate
# ?ignoreOutput? Indicates whether or not to ignore output
# sent to stdout & stderr
# result from running the script
# Empties the contents of outData and errData before running a
# test if ignoreOutput is set to 0.
proc tcltest::Eval {script
{ignoreOutput
1}} {
DebugPuts
3 "[lindex [info level 0] 0] called"
rename ::puts [namespace current
]::Replace::Puts
[list namespace import
[namespace origin Replace
::puts]]
namespace import Replace
::puts
set result
[uplevel 1 $script]
namespace eval :: namespace forget
puts
rename [namespace current
]::Replace::Puts ::puts
# tcltest::CompareStrings --
# compares the expected answer to the actual answer, depending on
# the mode provided. Mode determines whether a regexp, exact,
# glob or custom comparison is done.
# actual - string containing the actual result
# expected - pattern to be matched against
# mode - type of comparison to be done
proc tcltest::CompareStrings {actual expected mode
} {
if {![info exists CustomMatch
($mode)]} {
return -code error "No matching command registered for `-match $mode'"
set match
[namespace eval :: $CustomMatch($mode) [list $expected $actual]]
if {[catch {expr {$match && $match}} result
]} {
return -code error "Invalid result from `-match $mode' command: $result"
# tcltest::customMatch --
# registers a command to be called when a particular type of
# nickname - Keyword for the type of matching
# cmd - Incomplete command that implements that type of matching
# when completed with expected string and actual string
# Sets the variable tcltest::CustomMatch
proc tcltest::customMatch {mode script
} {
if {![info complete
$script]} {
"invalid customMatch script; can't evaluate after completion"
set CustomMatch
($mode) $script
# tcltest::SubstArguments list
# This helper function takes in a list of words, then perform a
# substitution on the list as though each word in the list is a separate
# argument to the Tcl function. For example, if this function is
# SubstArguments {$a {$a}}
# Then it is as though the function is invoked as:
# This code is adapted from Paul Duffin's function "SplitIntoWords".
# The original function can be found on:
# http://purl.org/thecliff/tcl/wiki/858.html
# a list containing the result of the substitution
# An error may occur if the list containing unbalanced quote or
proc tcltest::SubstArguments {argList
} {
# We need to split the argList up into tokens but cannot use list
# operations as they throw away some significant quoting, and
# [split] ignores braces as it should. Therefore what we do is
# gradually build up a string out of whitespace seperated strings.
# We cannot use [split] to split the argList into whitespace
# separated strings as it throws away the whitespace which maybe
# important so we have to do it all by hand.
while {[string length
$argList]} {
# Look for the next word containing a quote: " { }
if {[regexp -indices {[^
\t\n]*[\"\{\}]+[^
\t\n]*} \
# Get the text leading up to this word, but not including
# this word, from the argList.
set text [string range
$argList 0 \
[expr {[lindex $all 0] - 1}]]
# Get the word with the quote
set word
[string range
$argList \
[lindex $all 0] [lindex $all 1]]
# Remove all text up to and including the word from the
set argList
[string range
$argList \
[expr {[lindex $all 1] + 1}] end
]
# Take everything up to the end of the argList.
# If we saw a word with quote before, then there is a
# multi-word token starting with that word. In this case,
# add the text and the current word to this token.
# Add the text to the result. There is no need to parse
# the text because it couldn't be a part of any multi-word
# token. Then start a new multi-word token with the word
# because we need to pass this token to the Tcl parser to
# check for balancing quotes
if { [catch {llength $token} length
] == 0 && $length == 1} {
# The token is a valid list so add it to the result.
# lappend result [string trim $token]
# If the last token has not been added to the list then there
if { [string length
$token] } {
error "incomplete token \"$token\""
# This procedure runs a test and prints an error message if the test
# fails. If verbose has been set, it also prints a message even if the
# test succeeds. The test will be skipped if it doesn't match the
# match variable, if it matches an element in skip, or if one of the
# elements of "constraints" turns out not to be true.
# If testLevel is 1, then this is a top level test, and we record
# pass/fail information; otherwise, this information is not logged and
# is not added to running totals.
# Only description is a required attribute. All others are optional.
# Default values are indicated.
# constraints - A list of one or more keywords, each of which
# must be the name of an element in the array
# "testConstraints". If any of these elements is
# zero, the test is skipped. This attribute is
# optional; default is {}
# body - Script to run to carry out the test. It must
# return a result that can be checked for
# correctness. This attribute is optional;
# result - Expected result from script. This attribute is
# optional; default is {}.
# output - Expected output sent to stdout. This attribute
# is optional; default is {}.
# errorOutput - Expected output sent to stderr. This attribute
# is optional; default is {}.
# returnCodes - Expected return codes. This attribute is
# optional; default is {0 2}.
# setup - Code to run before $script (above). This
# attribute is optional; default is {}.
# cleanup - Code to run after $script (above). This
# attribute is optional; default is {}.
# match - specifies type of matching to do on result,
# output, errorOutput; this must be a string
# previously registered by a call to [customMatch].
# The strings exact, glob, and regexp are pre-registered
# by the tcltest package. Default value is exact.
# name - Name of test, in the form foo-1.2.
# description - Short textual description of the test, to
# help humans understand what it does.
# Just about anything is possible depending on the test.
proc tcltest::test {name description args
} {
DebugPuts
3 "test $name $args"
puts "test name '$name' re-used; prior use in $TestNames($name)"
set TestNames
($name) [info script
]
# Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
foreach item
{constraints setup cleanup body result returnCodes
# Set the default match mode
# Set the default match values for return codes (0 is the standard
# expected return value if everything went well; 2 represents
# 'return' being used in the test script).
set returnCodes
[list 0 2]
# The old test format can't have a 3rd argument (constraints or
# script) that starts with '-'.
if {[string match
-* [lindex $args 0]]
||
([llength $args] <= 1)} {
if {[llength $args] == 1} {
set list [SubstArguments
[lindex $args 0]]
foreach {element value
} $list {
set testAttributes
($element) $value
foreach item
{constraints match setup body cleanup
\
result returnCodes output errorOutput
} {
if {[info exists testAttributes
(-$item)]} {
set testAttributes
(-$item) [uplevel 1 \
::concat $testAttributes(-$item)]
array set testAttributes
$args
set validFlags
{-setup -cleanup -body -result -returnCodes \
-match -output -errorOutput -constraints}
foreach flag
[array names testAttributes
] {
if {[lsearch -exact $validFlags $flag] == -1} {
set sorted
[lsort $validFlags]
set options [join [lrange $sorted 0 end-1
] ", "]
append options ", or [lindex $sorted end]"
return -code error "bad option \"$flag\": must be $options"
# store whatever the user gave us
foreach item
[array names testAttributes
] {
set [string trimleft
$item "-"] $testAttributes($item)
# Check the values supplied for -match
if {[lsearch [array names CustomMatch
] $match] == -1} {
set sorted
[lsort [array names CustomMatch
]]
set values
[join [lrange $sorted 0 end-1
] ", "]
append values
", or [lindex $sorted end]"
return -code error "bad -match value \"$match\":\
# Replace symbolic valies supplied for -returnCodes
foreach {strcode numcode
} {ok
0 normal
0 error 1 return 2 break 3 continue 4} {
set returnCodes
[string map
-nocase [list $strcode $numcode] $returnCodes]
# This is parsing for the old test command format; it is here
# for backward compatibility.
set result
[lindex $args end
]
if {[llength $args] == 2} {
set body
[lindex $args 0]
} elseif
{[llength $args] == 3} {
set constraints
[lindex $args 0]
set body
[lindex $args 1]
return -code error "wrong # args:\
should be \"test name desc ?options?\""
if {[Skipped
$name $constraints]} {
# Save information about the core file.
if {[file exists
[file join [workingDirectory
] core
]]} {
set coreModTime
[file mtime
[file join [workingDirectory
] core
]]
# First, run the setup script
set code
[catch {uplevel 1 $setup} setupMsg
]
set errorInfo
(setup
) $::errorInfo
set errorCode
(setup
) $::errorCode
set setupFailure
[expr {$code != 0}]
# Only run the test body if the setup was successful
# Verbose notification of $body start
puts [outputChannel
] "---- $name start"
set command
[list [namespace origin RunTest
] $name $body]
if {[info exists output
] ||
[info exists errorOutput
]} {
set testResult
[uplevel 1 [list [namespace origin Eval
] $command 0]]
set testResult
[uplevel 1 [list [namespace origin Eval
] $command 1]]
foreach {actualAnswer returnCode
} $testResult break
set errorInfo
(body
) $::errorInfo
set errorCode
(body
) $::errorCode
# Always run the cleanup script
set code
[catch {uplevel 1 $cleanup} cleanupMsg
]
set errorInfo
(cleanup
) $::errorInfo
set errorCode
(cleanup
) $::errorCode
set cleanupFailure
[expr {$code != 0}]
# check for a core file first - if one was created by the test,
if {[file exists
[file join [workingDirectory
] core
]]} {
# There's only a test failure if there is a core file
# and (1) there previously wasn't one or (2) the new
# one is different from the old one.
if {[info exists coreModTime
]} {
if {$coreModTime != [file mtime
\
[file join [workingDirectory
] core
]]} {
if {([preserveCore
] > 1) && ($coreFailure)} {
append coreMsg
"\nMoving file to:\
[file join [temporaryDirectory] core-$name]"
catch {file rename -force \
[file join [workingDirectory
] core
] \
[file join [temporaryDirectory
] core-
$name]
if {[string length
$msg] > 0} {
append coreMsg
"\nError:\
Problem renaming core file: $msg"
# check if the return code matched the expected return code
if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
# If expected output/error strings exist, we have to compare
# them. If the comparison fails, then so did the test.
if {[info exists output
] && !$codeFailure} {
if {[set outputCompare
[catch {
CompareStrings
$outData $output $match
set outputFailure
[expr {!$outputMatch}]
if {[info exists errorOutput
] && !$codeFailure} {
if {[set errorCompare
[catch {
CompareStrings
$errData $errorOutput $match
set errorFailure
[expr {!$errorMatch}]
# check if the answer matched the expected answer
# Only check if we ran the body of the test (no setup failure)
if {$setupFailure ||
$codeFailure} {
} elseif
{[set scriptCompare
[catch {
CompareStrings
$actualAnswer $result $match
set scriptFailure
[expr {!$scriptMatch}]
# if we didn't experience any failures, then we passed
if {!($setupFailure ||
$cleanupFailure ||
$coreFailure
||
$outputFailure ||
$errorFailure ||
$codeFailure
puts [outputChannel
] "++++ $name PASSED"
# We know the test failed, tally it...
# ... then report according to the type of failure
variable currentFailure true
puts [outputChannel
] "\n==== $name\
[string trim $description] FAILED"
if {[string length
$body]} {
puts [outputChannel
] "==== Contents of test case:"
puts [outputChannel
] $body
puts [outputChannel
] "---- Test setup\
if {[info exists errorInfo
(setup
)]} {
puts [outputChannel
] "---- errorInfo(setup): $errorInfo(setup)"
puts [outputChannel
] "---- errorCode(setup): $errorCode(setup)"
puts [outputChannel
] "---- Error testing result: $scriptMatch"
puts [outputChannel
] "---- Result was:\n$actualAnswer"
puts [outputChannel
] "---- Result should have been\
($match matching):\n$result"
0 { set msg
"Test completed normally" }
1 { set msg
"Test generated error" }
2 { set msg
"Test generated return exception" }
3 { set msg
"Test generated break exception" }
4 { set msg
"Test generated continue exception" }
default { set msg
"Test generated exception" }
puts [outputChannel
] "---- $msg; Return code was: $returnCode"
puts [outputChannel
] "---- Return code should have been\
if {[info exists errorInfo
(body
)] && ([lsearch $returnCodes 1]<0)} {
puts [outputChannel
] "---- errorInfo: $errorInfo(body)"
puts [outputChannel
] "---- errorCode: $errorCode(body)"
puts [outputChannel
] "---- Error testing output: $outputMatch"
puts [outputChannel
] "---- Output was:\n$outData"
puts [outputChannel
] "---- Output should have been\
($match matching):\n$output"
puts [outputChannel
] "---- Error testing errorOutput: $errorMatch"
puts [outputChannel
] "---- Error output was:\n$errData"
puts [outputChannel
] "---- Error output should have\
been ($match matching):\n$errorOutput"
puts [outputChannel
] "---- Test cleanup failed:\n$cleanupMsg"
if {[info exists errorInfo
(cleanup
)]} {
puts [outputChannel
] "---- errorInfo(cleanup): $errorInfo(cleanup)"
puts [outputChannel
] "---- errorCode(cleanup): $errorCode(cleanup)"
puts [outputChannel
] "---- Core file produced while running\
puts [outputChannel
] "==== $name FAILED\n"
# Given a test name and it constraints, returns a boolean indicating
# whether the current configuration says the test should be skipped.
# Side Effects: Maintains tally of total tests seen and tests skipped.
proc tcltest::Skipped {name constraints
} {
# skip the test if it's name matches an element of skip
if {[string match
$pattern $name]} {
DebugDo
1 {AddToSkippedBecause userSpecifiedSkip
}
# skip the test if it's name doesn't match any element of match
foreach pattern
[match
] {
if {[string match
$pattern $name]} {
DebugDo
1 {AddToSkippedBecause userSpecifiedNonMatch
}
if {[string equal
{} $constraints]} {
# If we're limited to the listed constraints and there aren't
# any listed, then we shouldn't run the test.
if {[limitConstraints
]} {
AddToSkippedBecause userSpecifiedLimitConstraint
# "constraints" argument exists;
# make sure that the constraints are satisfied.
if {[string match
{*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
catch {set doTest
[uplevel #0 expr $constraints]}
} elseif
{[regexp {[^.a-zA-Z0-9
\n\r\t]+} $constraints] != 0} {
# something like {a || b} should be turned into
# $testConstraints(a) || $testConstraints(b).
regsub -all {[.
\w
]+} $constraints {$testConstraints(&)} c
catch {set doTest
[eval expr $c]}
} elseif
{![catch {llength $constraints}]} {
# just simple constraints such as {unixOnly fonts}.
foreach constraint
$constraints {
if {(![info exists testConstraints
($constraint)]) \
||
(!$testConstraints($constraint))} {
# store the constraint that kept the test from
set constraints
$constraint
puts [outputChannel
] "++++ $name SKIPPED: $constraints"
AddToSkippedBecause
$constraints
# This is where the body of a test is evaluated. The combination of
# [RunTest] and [Eval] allows the output and error output of the test
# body to be captured for comparison against the expected values.
proc tcltest::RunTest {name script
} {
DebugPuts
3 "Running $name {$script}"
# If there is no "memory" command (because memory debugging isn't
# enabled), then don't attempt to use the command.
if {[llength [info commands
memory]] == 1} {
set code
[catch {uplevel 1 $script} actualAnswer
]
return [list $actualAnswer $code]
#####################################################################
# tcltest::cleanupTestsHook --
# This hook allows a harness that builds upon tcltest to specify
# additional things that should be done at cleanup.
if {[llength [info commands
tcltest::cleanupTestsHook]] == 0} {
proc tcltest::cleanupTestsHook {} {}
# tcltest::cleanupTests --
# Remove files and dirs created using the makeFile and makeDirectory
# commands since the last time this proc was invoked.
# Print the names of the files created without the makeFile command
# since the tests were invoked.
# Print the number tests (total, passed, failed, and skipped) since the
# Restore original environment (as reported by special variable env).
# calledFromAllFile - if 0, behave as if we are running a single
# test file within an entire suite of tests. if we aren't running
# a single test file, then don't report status. check for new
# files created during the test run and report on them. if 1,
# report collated status from all the test file runs.
proc tcltest::cleanupTests {{calledFromAllFile
0}} {
variable originalTclPlatform
set testFileName
[file tail
[info script
]]
# Remove files and directories created by the makeFile and
# makeDirectory procedures. Record the names of files in
# workingDirectory that were not pre-existing, and associate them
# with the test file that created them.
if {!$calledFromAllFile} {
foreach file $filesMade {
if {[file exists
$file]} {
DebugDo
1 {Warn
"cleanupTests deleting $file..."}
catch {file delete
-force $file}
foreach file [glob -nocomplain \
-directory [temporaryDirectory
] *] {
lappend currentFiles
[file tail
$file]
foreach file $currentFiles {
if {[lsearch -exact $filesExisted $file] == -1} {
set filesExisted
$currentFiles
if {[llength $newFiles] > 0} {
set createdNewFiles
($testFileName) $newFiles
if {$calledFromAllFile ||
$testSingleFile} {
puts -nonewline [outputChannel
] "$testFileName:"
foreach index
[list "Total" "Passed" "Skipped" "Failed"] {
puts -nonewline [outputChannel
] \
"\t$index\t$numTests($index)"
# print number test files sourced
# print names of files that ran tests which failed
if {$calledFromAllFile} {
"Sourced $numTestFiles Test Files."
if {[llength $failFiles] > 0} {
"Files with failing tests: $failFiles"
# if any tests were skipped, print the constraints that kept
set constraintList
[array names skippedBecause
]
if {[llength $constraintList] > 0} {
"Number of tests skipped for each constraint:"
foreach constraint
[lsort $constraintList] {
"\t$skippedBecause($constraint)\t$constraint"
unset skippedBecause
($constraint)
# report the names of test files in createdNewFiles, and reset
set testFilesThatTurded
[lsort [array names createdNewFiles
]]
if {[llength $testFilesThatTurded] > 0} {
puts [outputChannel
] "Warning: files left behind:"
foreach testFile
$testFilesThatTurded {
"\t$testFile:\t$createdNewFiles($testFile)"
unset createdNewFiles
($testFile)
# reset filesMade, filesExisted, and numTests
foreach index
[list "Total" "Passed" "Skipped" "Failed"] {
# exit only if running Tk in non-interactive mode
# This should be changed to determine if an event
# loop is running, which is the real issue.
# Actually, this doesn't belong here at all. A package
# really has no business [exit]-ing an application.
if {![catch {package present Tk
}] && ![testConstraint interactive
]} {
# if we're deferring stat-reporting until all files are sourced,
# then add current file to failFile list if any tests in this
&& ([lsearch -exact $failFiles $testFileName] == -1)} {
lappend failFiles
$testFileName
# restore the environment to the state it was in before this package
foreach index
[array names
::env] {
if {![info exists originalEnv
($index)]} {
if {$::env($index) != $originalEnv($index)} {
lappend changedEnv
$index
set ::env($index) $originalEnv($index)
foreach index
[array names originalEnv
] {
if {![info exists
::env($index)]} {
lappend removedEnv
$index
set ::env($index) $originalEnv($index)
if {[llength $newEnv] > 0} {
"env array elements created:\t$newEnv"
if {[llength $changedEnv] > 0} {
"env array elements changed:\t$changedEnv"
if {[llength $removedEnv] > 0} {
"env array elements removed:\t$removedEnv"
set changedTclPlatform
{}
foreach index
[array names originalTclPlatform
] {
if {$::tcl_platform($index) \
!= $originalTclPlatform($index)} {
lappend changedTclPlatform
$index
set ::tcl_platform($index) $originalTclPlatform($index)
if {[llength $changedTclPlatform] > 0} {
puts [outputChannel
] "tcl_platform array elements\
changed:\t$changedTclPlatform"
if {[file exists
[file join [workingDirectory
] core
]]} {
if {[preserveCore
] > 1} {
puts "rename core file (> 1)"
puts [outputChannel
] "produced core file! \
[file join [temporaryDirectory] core-$testFileName]"
catch {file rename -force \
[file join [workingDirectory
] core
] \
[file join [temporaryDirectory
] core-
$testFileName]
if {[string length
$msg] > 0} {
PrintError
"Problem renaming file: $msg"
# Print a message if there is a core file and (1) there
# previously wasn't one or (2) the new one is different
if {[info exists coreModTime
]} {
if {$coreModTime != [file mtime
\
[file join [workingDirectory
] core
]]} {
puts [outputChannel
] "A core file was created!"
puts [outputChannel
] "A core file was created!"
#####################################################################
# Procs that determine which tests/test files to run
# tcltest::GetMatchingFiles
# Looks at the patterns given to match and skip files and uses
# them to put together a list of the tests that will be run.
# The constructed list is returned to the user. This will
# primarily be used in 'all.tcl' files. It is used in
# a lower case version is needed for compatibility with tcltest 1.0
proc tcltest::getMatchingFiles args
{eval GetMatchingFiles
$args}
proc tcltest::GetMatchingFiles { args
} {
# Finding tests only in [testsDirectory] is normal operation.
# This procedure is written to accept multiple directory arguments
# only to satisfy version 1 compatibility.
set dirList
[list [testsDirectory
]]
foreach directory
$dirList {
# List files in $directory that match patterns to run.
foreach match
[matchFiles
] {
set matchFileList
[concat $matchFileList \
[glob -directory $directory -types {b c f p s
} \
# List files in $directory that match patterns to skip.
foreach skip
[skipFiles
] {
set skipFileList
[concat $skipFileList \
[glob -directory $directory -types {b c f p s
} \
# Add to result list all files in match list and not in skip list
foreach file $matchFileList {
if {[lsearch -exact $skipFileList $file] == -1} {
lappend matchingFiles
$file
if {[llength $matchingFiles] == 0} {
PrintError
"No test files remain after applying your match and\
# tcltest::GetMatchingDirectories --
# Looks at the patterns given to match and skip directories and
# uses them to put together a list of the test directories that we
# should attempt to run. (Only subdirectories containing an
# "all.tcl" file are put into the list.)
# root directory from which to search
# The constructed list is returned to the user. This is used in
# the primary all.tcl file.
proc tcltest::GetMatchingDirectories {rootdir
} {
# Determine the skip list first, to avoid [glob]-ing over subdirectories
# we're going to throw away anyway. Be sure we skip the $rootdir if it
# comes up to avoid infinite loops.
set skipDirs
[list $rootdir]
foreach pattern
[skipDirectories
] {
set skipDirs
[concat $skipDirs [glob -directory $rootdir -types d
\
-nocomplain -- $pattern]]
# Now step through the matching directories, prune out the skipped ones
foreach pattern
[matchDirectories
] {
foreach path
[glob -directory $rootdir -types d
-nocomplain -- \
if {[lsearch -exact $skipDirs $path] == -1} {
set matchDirs
[concat $matchDirs [GetMatchingDirectories
$path]]
if {[file exists
[file join $path all.tcl
]]} {
if {[llength $matchDirs] == 0} {
DebugPuts
1 "No test directories remain after applying match\
# tcltest::runAllTests --
# prints output and sources test files according to the match and
# skip patterns provided. after sourcing test files, it goes on
# to source all.tcl files in matching test subdirectories.
proc tcltest::runAllTests { {shell
""} } {
if {[llength [info level
0]] == 1} {
puts [outputChannel
] "Tests running in interp: $shell"
puts [outputChannel
] "Tests located in: [testsDirectory]"
puts [outputChannel
] "Tests running in: [workingDirectory]"
puts [outputChannel
] "Temporary files stored in\
# [file system] first available in Tcl 8.4
if {![catch {file system
[testsDirectory
]} result
]
&& ![string equal native
[lindex $result 0]]} {
# If we aren't running in the native filesystem, then we must
# run the tests in a single process (via 'source'), because
# trying to run then via a pipe will fail since the files don't
"Test files sourced into current interpreter"
"Test files run in separate interpreters"
if {[llength [skip
]] > 0} {
puts [outputChannel
] "Skipping tests that match: [skip]"
puts [outputChannel
] "Running tests that match: [match]"
if {[llength [skipFiles
]] > 0} {
"Skipping test files that match: [skipFiles]"
if {[llength [matchFiles
]] > 0} {
"Only running test files that match: [matchFiles]"
set timeCmd
{clock format [clock seconds
]}
puts [outputChannel
] "Tests began at [eval $timeCmd]"
# Run each of the specified tests
foreach file [lsort [GetMatchingFiles
]] {
set tail
[file tail
$file]
puts [outputChannel
] $tail
uplevel 1 [list ::source $file]
# Pass along our configuration to the child processes.
# EXCEPT for the -outfile, because the parent process
# needs to read and process output of children.
foreach opt
[Configure
] {
if {[string equal
$opt -outfile]} {continue}
lappend childargv
$opt [Configure
$opt]
set cmd
[linsert $childargv 0 |
$shell $file]
set pipeFd
[open $cmd "r"]
while {[gets $pipeFd line
] >= 0} {
} ""] $line null testFile
\
Total Passed Skipped Failed
]} {
foreach index
{Total Passed Skipped Failed
} {
incr numTests
($index) [set $index]
lappend failFiles
$testFile
} elseif
{[regexp [join {
{^Number of tests skipped
}
} ""] $line match skipped constraint
]} {
if {[string match
\t* $match]} {
AddToSkippedBecause
$constraint $skipped
puts [outputChannel
] $line
puts [outputChannel
] "Test file error: $msg"
# append the name of the test to a list to be reported
lappend testFileFailures
$file
puts [outputChannel
] "\nTests ended at [eval $timeCmd]"
if {[info exists testFileFailures
]} {
puts [outputChannel
] "\nTest files exiting with errors: \n"
foreach file $testFileFailures {
puts [outputChannel
] " [file tail $file]\n"
# Checking for subdirectories in which to run tests
foreach directory
[GetMatchingDirectories
[testsDirectory
]] {
set dir
[file tail
$directory]
puts [outputChannel
] [string repeat ~
44]
puts [outputChannel
] "$dir test began at [eval $timeCmd]\n"
uplevel 1 [list ::source [file join $directory all.tcl
]]
set endTime
[eval $timeCmd]
puts [outputChannel
] "\n$dir test ended at $endTime"
puts [outputChannel
] [string repeat ~
44]
#####################################################################
# Test utility procs - not used in tcltest, but may be useful for
# 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
proc tcltest::loadTestedCommands {} {
if {[string equal
{} [loadScript
]]} {
return [uplevel 1 [loadScript
]]
# Save information regarding what procs and variables exist.
# Modifies the variable saveState
proc tcltest::saveState {} {
uplevel 1 [list ::set [namespace which
-variable saveState
]] \
{[::list [::info procs
] [::info vars
]]}
DebugPuts
2 "[lindex [info level 0] 0]: $saveState"
# tcltest::restoreState --
# Remove procs and variables that didn't exist before the call to
# Removes procs and variables from your environment if they don't
# exist in the saveState variable.
proc tcltest::restoreState {} {
foreach p
[uplevel 1 {::info procs
}] {
if {([lsearch [lindex $saveState 0] $p] < 0)
&& ![string equal
[namespace current
]::$p \
[uplevel 1 [list ::namespace origin
$p]]]} {
DebugPuts
2 "[lindex [info level 0] 0]: Removing proc $p"
uplevel 1 [list ::catch [list ::rename $p {}]]
foreach p
[uplevel 1 {::info vars
}] {
if {[lsearch [lindex $saveState 1] $p] < 0} {
DebugPuts
2 "[lindex [info level 0] 0]:\
uplevel 1 [list ::catch [list ::unset $p]]
# tcltest::normalizeMsg --
# Removes "extra" newlines from a string.
# msg String to be modified
# string with extra newlines removed
proc tcltest::normalizeMsg {msg
} {
regsub "\n$" [string tolower
$msg] "" msg
set msg
[string map
[list "\n\n" "\n"] $msg]
return [string map
[list "\n\}" "\}"] $msg]
# Create a new file with the name <name>, and write <contents> to it.
# If this file hasn't been created via makeFile since the last time
# cleanupTests was called, add it to the $filesMade list, so it will be
# removed by the next call to cleanupTests.
# contents content of the new file
# name name of the new file
# directory directory name for new file
# absolute path to the file created
proc tcltest::makeFile {contents name
{directory
""}} {
if {[llength [info level
0]] == 3} {
set directory
[temporaryDirectory
]
set fullName
[file join $directory $name]
DebugPuts
3 "[lindex [info level 0] 0]:\
putting ``$contents'' into $fullName"
set fd
[open $fullName w
]
fconfigure $fd -translation lf
if {[string equal
[string index
$contents end
] \n]} {
puts -nonewline $fd $contents
if {[lsearch -exact $filesMade $fullName] == -1} {
lappend filesMade
$fullName
# Removes the named file from the filesystem
# name file to be removed
# directory directory from which to remove file
# return value from [file delete]
proc tcltest::removeFile {name
{directory
""}} {
if {[llength [info level
0]] == 2} {
set directory
[temporaryDirectory
]
set fullName
[file join $directory $name]
DebugPuts
3 "[lindex [info level 0] 0]: removing $fullName"
set idx
[lsearch -exact $filesMade $fullName]
set filesMade
[lreplace $filesMade $idx $idx]
Warn
"removeFile removing \"$fullName\":\n not created by makeFile"
if {![file isfile
$fullName]} {
Warn
"removeFile removing \"$fullName\":\n not a file"
return [file delete
$fullName]
# tcltest::makeDirectory --
# Create a new dir with the name <name>.
# If this dir hasn't been created via makeDirectory since the last time
# cleanupTests was called, add it to the $directoriesMade list, so it
# will be removed by the next call to cleanupTests.
# name name of the new directory
# directory directory in which to create new dir
# absolute path to the directory created
proc tcltest::makeDirectory {name
{directory
""}} {
if {[llength [info level
0]] == 2} {
set directory
[temporaryDirectory
]
set fullName
[file join $directory $name]
DebugPuts
3 "[lindex [info level 0] 0]: creating $fullName"
if {[lsearch -exact $filesMade $fullName] == -1} {
lappend filesMade
$fullName
# tcltest::removeDirectory --
# Removes a named directory from the file system.
# name Name of the directory to remove
# directory Directory from which to remove
# return value from [file delete]
proc tcltest::removeDirectory {name
{directory
""}} {
if {[llength [info level
0]] == 2} {
set directory
[temporaryDirectory
]
set fullName
[file join $directory $name]
DebugPuts
3 "[lindex [info level 0] 0]: deleting $fullName"
set idx
[lsearch -exact $filesMade $fullName]
set filesMade
[lreplace $filesMade $idx $idx]
Warn
"removeDirectory removing \"$fullName\":\n not created\
if {![file isdirectory
$fullName]} {
Warn
"removeDirectory removing \"$fullName\":\n not a directory"
return [file delete
-force $fullName]
# reads the content of a file and returns it
# name of the file to read
# directory in which file is located
# content of the named file
proc tcltest::viewFile {name
{directory
""}} {
if {[llength [info level
0]] == 2} {
set directory
[temporaryDirectory
]
set fullName
[file join $directory $name]
set data
[read -nonewline $f]
# Construct a string that consists of the requested sequence of bytes,
# as opposed to a string of properly formed UTF-8 characters.
# This allows the tester to
# 1. Create denormalized or improperly formed strings to pass to C
# procedures that are supposed to accept strings with embedded NULL
# 2. Confirm that a string result has a certain pattern of bytes, for
# instance to confirm that "\xe0\0" in a Tcl script is stored
# internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
# Generally, it's a bad idea to examine the bytes in a Tcl string or to
# construct improperly formed strings in this manner, because it involves
# exposing that Tcl uses UTF-8 internally.
proc tcltest::bytestring {string} {
return [encoding convertfrom identity
$string]
# used in io tests, uses testchannel
proc tcltest::OpenFiles {} {
if {[catch {testchannel
open} result
]} {
# used in io tests, uses testchannel
proc tcltest::LeakFiles {old
} {
if {[catch {testchannel
open} new
]} {
if {[lsearch $old $p] < 0} {
# Internationalization / ISO support procs -- dl
# tcltest::SetIso8859_1_Locale --
# used in cmdIL.test, uses testlocale
proc tcltest::SetIso8859_1_Locale {} {
if {[info commands testlocale
] != ""} {
set previousLocale
[testlocale ctype
]
testlocale ctype
$isoLocale
# tcltest::RestoreLocale --
# used in cmdIL.test, uses testlocale
proc tcltest::RestoreLocale {} {
if {[info commands testlocale
] != ""} {
testlocale ctype
$previousLocale
# Kill all threads except for the main thread.
# Do nothing if testthread is not defined.
# Returns the number of existing threads.
proc tcltest::threadReap {} {
if {[info commands testthread
] != {}} {
# testthread built into tcltest
testthread errorproc ThreadNullError
while {[llength [testthread names
]] > 1} {
foreach tid
[testthread names
] {
if {$tid != [mainThread
]} {
testthread
send -async $tid {testthread
exit}
## Enter a bit a sleep to give the threads enough breathing
## room to kill themselves off, otherwise the end up with a
## massive queue of repeated events
testthread errorproc ThreadError
return [llength [testthread names
]]
} elseif
{[info commands thread
::id] != {}} {
thread
::errorproc ThreadNullError
while {[llength [thread
::names]] > 1} {
foreach tid
[thread
::names] {
if {$tid != [mainThread
]} {
catch {thread
::send -async $tid {thread
::exit}}
## Enter a bit a sleep to give the threads enough breathing
## room to kill themselves off, otherwise the end up with a
## massive queue of repeated events
thread
::errorproc ThreadError
return [llength [thread
::names]]
# Initialize the constraints and set up command line arguments
# Define initializers for all the built-in contraint definitions
DefineConstraintInitializers
# Set up the constraints in the testConstraints array to be lazily
# initialized by a registered initializer, or by "false" if no
# initializer is registered.
trace variable testConstraints r
[namespace code SafeFetch
]
# Only initialize constraints at package load time if an
# [initConstraintsHook] has been pre-defined. This is only
# for compatibility support. The modern way to add a custom
# test constraint is to just call the [testConstraint] command
# straight away, without all this "hook" nonsense.
if {[string equal
[namespace current
] \
[namespace qualifiers
[namespace which initConstraintsHook
]]]} {
proc initConstraintsHook
{} {}
# Define the standard match commands
customMatch exact
[list string equal
]
customMatch
glob [list string match
]
customMatch
regexp [list regexp --]
# If the TCLTEST_OPTIONS environment variable exists, configure
# tcltest according to the option values it specifies. This has
# the effect of resetting tcltest's default configuration.
proc ConfigureFromEnvironment
{} {
upvar #0 env(TCLTEST_OPTIONS) options
if {[catch {llength $options} msg
]} {
Warn
"invalid TCLTEST_OPTIONS \"$options\":\n invalid\
if {[llength $::env(TCLTEST_OPTIONS
)] % 2} {
Warn
"invalid TCLTEST_OPTIONS: \"$options\":\n should be\
-option value ?-option value ...?"
if {[catch {eval Configure
$::env(TCLTEST_OPTIONS
)} msg
]} {
Warn
"invalid TCLTEST_OPTIONS: \"$options\":\n $msg"
if {[info exists
::env(TCLTEST_OPTIONS
)]} {
proc LoadTimeCmdLineArgParsingRequired
{} {
if {[info exists
::argv] && [lsearch -exact $::argv -help] != -1} {
# The command line asks for -help, so give it (and exit)
# right now. ([configure] does not process -help)
foreach hook
{ PrintUsageInfoHook processCmdLineArgsHook
processCmdLineArgsAddFlagsHook
} {
if {[string equal
[namespace current
] [namespace qualifiers
\
[namespace which
$hook]]]} {
# Only initialize configurable options from the command line arguments
# at package load time if necessary for backward compatibility. This
# lets the tcltest user call [configure] for themselves if they wish.
# Traces are established for auto-configuration from the command line
# if any configurable options are accessed before the user calls
if {[LoadTimeCmdLineArgParsingRequired
]} {
EstablishAutoConfigureTraces
package provide
[namespace tail
[namespace current
]] $Version