diff options
Diffstat (limited to 'library')
| -rw-r--r-- | library/tcltest/pkgIndex.tcl | 3 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 3227 | ||||
| -rwxr-xr-x | library/tcltest/tcltest2.tcl | 3490 | ||||
| -rw-r--r-- | library/tcltest1.0/pkgIndex.tcl | 3 | ||||
| -rw-r--r-- | library/tcltest1.0/tcltest.tcl | 3227 | ||||
| -rwxr-xr-x | library/tcltest1.0/tcltest2.tcl | 3490 |
6 files changed, 4814 insertions, 8626 deletions
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index e3746e2..da93644 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -8,5 +8,4 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded tcltest 1.0 [list source [file join $dir tcltest.tcl]] -package ifneeded tcltest 2.0 [list source [file join $dir tcltest2.tcl]] +package ifneeded tcltest 2.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 63639e3..80f80c7 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1,7 +1,7 @@ # tcltest.tcl -- # # This file contains support code for the Tcl test suite. It -# defines the ::tcltest namespace and finds and defines the output +# defines the tcltest namespace and finds and defines the output # directory, constraints available, output and error channels, etc. used # by Tcl tests. See the tcltest man page for more details. # @@ -10,11 +10,10 @@ # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.27 2000/09/06 18:50:15 hobbs Exp $ - -package provide tcltest 1.0 +# RCS: @(#) $Id: tcltest.tcl,v 1.28 2000/10/24 22:30:32 jenn Exp $ # create the "tcltest" namespace for all testing variables and procedures @@ -23,19 +22,25 @@ namespace eval tcltest { # Export the public tcltest procs set procList [list test cleanupTests saveState restoreState \ normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring safeFetch threadReap getMatchingFiles \ - loadTestedCommands normalizePath] + viewFile bytestring threadReap debug testConstraint \ + limitConstraints loadTestedCommands normalizePath verbose match \ + skip matchFiles skipFiles preserveCore loadScript loadFile \ + mainThread workingDirectory singleProcess interpreter runAllTests \ + outputChannel outputFile errorChannel \ + errorFile temporaryDirectory testsDirectory matchDirectories \ + skipDirectories ] foreach proc $procList { namespace export $proc } - # ::tcltest::verbose defaults to "b" + # tcltest::verbose defaults to {body} if {![info exists verbose]} { - variable verbose "b" + variable verbose {body} } # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory + # matchFiles, which defaults to all .test files in the testsDirectory and + # matchDirectories, which defaults to all directories. if {![info exists match]} { variable match {} @@ -49,6 +54,12 @@ namespace eval tcltest { if {![info exists skipFiles]} { variable skipFiles {} } + if {![info exists matchDirectories]} { + variable matchDirectories {*} + } + if {![info exists skipDirectories]} { + variable skipDirectories {} + } # By default, don't save core files if {![info exists preserveCore]} { @@ -59,11 +70,17 @@ namespace eval tcltest { if {![info exists outputChannel]} { variable outputChannel stdout } + if {![info exists outputFile]} { + variable outputFile stdout + } # errors go to stderr by default if {![info exists errorChannel]} { variable errorChannel stderr } + if {![info exists errorFile]} { + variable errorFile stderr + } # debug output doesn't get printed by default; debug level 1 spits # up only the tests that were skipped because they didn't match or were @@ -81,9 +98,9 @@ namespace eval tcltest { variable parameters {} } - # Count the number of files tested (0 if all.tcl wasn't called). - # The all.tcl file will set testSingleFile to false, so stats will - # not be printed until all.tcl calls the cleanupTests proc. + # Count the number of files tested (0 if runAllTests wasn't called). + # runAllTests will set testSingleFile to false, so stats will + # not be printed until runAllTests calls the cleanupTests proc. # The currentFailure var stores the boolean value of whether the # current test file has had any failures. The failFiles list # stores the names of test files that had failures. @@ -103,9 +120,9 @@ namespace eval tcltest { # Tests should remove all files they create. The test suite will # check the current working dir for files created by the tests. - # ::tcltest::filesMade keeps track of such files created using the - # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. - # ::tcltest::filesExisted stores the names of pre-existing files. + # tcltest::filesMade keeps track of such files created using the + # tcltest::makeFile and tcltest::makeDirectory procedures. + # tcltest::filesExisted stores the names of pre-existing files. if {![info exists filesMade]} { variable filesMade {} @@ -114,43 +131,47 @@ namespace eval tcltest { variable filesExisted {} } - # ::tcltest::numTests will store test files as indices and the list + # tcltest::numTests will store test files as indices and the list # of files (that should not have been) left behind by the test files. if {![info exists createdNewFiles]} { variable createdNewFiles - array set ::tcltest::createdNewFiles {} + array set tcltest::createdNewFiles {} } - # initialize ::tcltest::numTests array to keep track fo the number of + # initialize tcltest::numTests array to keep track fo the number of # tests that pass, fail, and are skipped. if {![info exists numTests]} { variable numTests - array set ::tcltest::numTests \ + array set tcltest::numTests \ [list Total 0 Passed 0 Skipped 0 Failed 0] } - # initialize ::tcltest::skippedBecause array to keep track of + # initialize tcltest::skippedBecause array to keep track of # constraints that kept tests from running; a constraint name of # "userSpecifiedSkip" means that the test appeared on the list of tests # that matched the -skip value given to the flag; "userSpecifiedNonMatch" # means that the test didn't match the argument given to the -match flag; - # both of these constraints are counted only if ::tcltest::debug is set to + # both of these constraints are counted only if tcltest::debug is set to # true. if {![info exists skippedBecause]} { variable skippedBecause - array set ::tcltest::skippedBecause {} + array set tcltest::skippedBecause {} } - # initialize the ::tcltest::testConstraints array to keep track of valid + # initialize the tcltest::testConstraints array to keep track of valid # predefined constraints (see the explanation for the - # ::tcltest::initConstraints proc for more details). + # tcltest::initConstraints proc for more details). if {![info exists testConstraints]} { variable testConstraints - array set ::tcltest::testConstraints {} + array set tcltest::testConstraints {} + } + + if {![info exists constraintsSpecified]} { + variable constraintsSpecified {} } # Don't run only the constrained tests by default @@ -166,6 +187,11 @@ namespace eval tcltest { variable loadScript {} } + # and the filename of the script file, if it exists + if {![info exists loadFile]} { + variable loadFile {} + } + # tests that use threads need to know which is the main thread if {![info exists mainThread]} { @@ -181,10 +207,10 @@ namespace eval tcltest { if {![info exists originalEnv]} { variable originalEnv - array set ::tcltest::originalEnv [array get ::env] + array set tcltest::originalEnv [array get ::env] } - # Set ::tcltest::workingDirectory to [pwd]. The default output directory + # Set tcltest::workingDirectory to [pwd]. The default output directory # for Tcl tests is the working directory. if {![info exists workingDirectory]} { @@ -196,7 +222,7 @@ namespace eval tcltest { # Tests should not rely on the current working directory. # Files that are part of the test suite should be accessed relative to - # ::tcltest::testsDirectory. + # tcltest::testsDirectory. if {![info exists testsDirectory]} { set oldpwd [pwd] @@ -206,30 +232,40 @@ namespace eval tcltest { unset oldpwd } - # the variables and procs that existed when ::tcltest::saveState was + # Default is to run each test file in a separate process + if {![info exists singleProcess]} { + variable singleProcess 0 + } + + # the variables and procs that existed when tcltest::saveState was # called are stored in a variable of the same name if {![info exists saveState]} { variable saveState {} } - # Internationalization support + # Internationalization support -- used in tcltest::set_iso8859_1_locale + # and tcltest::restore_locale. Those commands are used in cmdIL.test. + if {![info exists previousLocale]} { + variable previousLocale + } + if {![info exists isoLocale]} { variable isoLocale fr - switch $tcl_platform(platform) { + switch -- $tcl_platform(platform) { "unix" { # Try some 'known' values for some platforms: switch -exact -- $tcl_platform(os) { "FreeBSD" { - set ::tcltest::isoLocale fr_FR.ISO_8859-1 + set tcltest::isoLocale fr_FR.ISO_8859-1 } HP-UX { - set ::tcltest::isoLocale fr_FR.iso88591 + set tcltest::isoLocale fr_FR.iso88591 } Linux - IRIX { - set ::tcltest::isoLocale fr + set tcltest::isoLocale fr } default { @@ -237,12 +273,12 @@ namespace eval tcltest { # define it to something else on your system #if you want to test those. - set ::tcltest::isoLocale iso_8859_1 + set tcltest::isoLocale iso_8859_1 } } } "windows" { - set ::tcltest::isoLocale French + set tcltest::isoLocale French } } } @@ -250,7 +286,7 @@ namespace eval tcltest { # Set the location of the execuatble if {![info exists tcltest]} { variable tcltest [info nameofexecutable] - } + } # save the platform information so it can be restored later if {![info exists originalTclPlatform]} { @@ -259,29 +295,34 @@ namespace eval tcltest { # If a core file exists, save its modification time. if {![info exists coreModificationTime]} { - if {[file exists [file join $::tcltest::workingDirectory core]]} { + if {[file exists [file join $tcltest::workingDirectory core]]} { variable coreModificationTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + $tcltest::workingDirectory core]] } } - # Tcl version numbers - if {![info exists version]} { - variable version 8.4 + # stdout and stderr buffers for use when we want to store them + if {![info exists outData]} { + variable outData {} } - if {![info exists patchLevel]} { - variable patchLevel 8.4a2 + if {![info exists errData]} { + variable errData {} } + + # keep track of test level for nested test commands + variable testLevel 0 } -# ::tcltest::Debug* -- +##################################################################### + +# tcltest::Debug* -- # # Internal helper procedures to write out debug information # dependent on the chosen level. A test shell may overide # them, f.e. to redirect the output into a different # channel, or even into a GUI. -# ::tcltest::DebugPuts -- +# tcltest::DebugPuts -- # # Prints the specified string if the current debug level is # higher than the provided level argument. @@ -293,15 +334,19 @@ namespace eval tcltest { # Results: # Prints the string. Nothing else is allowed. # +# Side Effects: +# None. +# -proc ::tcltest::DebugPuts {level string} { +proc tcltest::DebugPuts {level string} { variable debug if {$debug >= $level} { puts $string } + return } -# ::tcltest::DebugPArray -- +# tcltest::DebugPArray -- # # Prints the contents of the specified array if the current # debug level is higher than the provided level argument @@ -313,17 +358,21 @@ proc ::tcltest::DebugPuts {level string} { # Results: # Prints the contents of the array. Nothing else is allowed. # +# Side Effects: +# None. +# -proc ::tcltest::DebugPArray {level arrayvar} { +proc tcltest::DebugPArray {level arrayvar} { variable debug if {$debug >= $level} { catch {upvar $arrayvar $arrayvar} parray $arrayvar } + return } -# ::tcltest::DebugDo -- +# tcltest::DebugDo -- # # Executes the script if the current debug level is greater than # the provided level argument @@ -335,16 +384,779 @@ proc ::tcltest::DebugPArray {level arrayvar} { # Results: # Arbitrary side effects, dependent on the executed script. # +# Side Effects: +# None. +# -proc ::tcltest::DebugDo {level script} { +proc tcltest::DebugDo {level script} { variable debug if {$debug >= $level} { uplevel $script } + return +} + +##################################################################### + +# tcltest::CheckDirectory -- +# +# This procedure checks whether the specified path is a readable +# and/or writable directory. If one of the conditions is not +# satisfied an error is printed and the application aborted. The +# procedure assumes that the caller already checked the existence +# of the path. +# +# Arguments +# rw Information what attributes to check. Allowed values: +# r, w, rw, wr. If 'r' is part of the value the directory +# must be readable. 'w' associates to 'writable'. +# dir The directory to check. +# errMsg The string to prepend to the actual error message before +# printing it. +# +# Results +# none +# +# Side Effects: +# None. +# + +proc tcltest::CheckDirectory {rw dir errMsg} { + # Allowed values for 'rw': r, w, rw, wr + + if {![file isdir $dir]} { + set msg "$errMsg \"$dir\" is not a directory" + error $msg + } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { + set msg "$errMsg \"$dir\" is not writeable" + error $msg + } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { + set msg "$errMsg \"$dir\" is not readable" + error $msg + } + return +} + +# tcltest::normalizePath -- +# +# This procedure resolves any symlinks in the path thus creating a +# path without internal redirection. It assumes that the incoming +# path is absolute. +# +# Arguments +# pathVar contains the name of the variable containing the path to modify. +# +# Results +# The path is modified in place. +# +# Side Effects: +# None. +# + +proc tcltest::normalizePath {pathVar} { + upvar $pathVar path + + set oldpwd [pwd] + catch {cd $path} + set path [pwd] + cd $oldpwd + return $path +} + + +# tcltest::MakeAbsolutePath -- +# +# This procedure checks whether the incoming path is absolute or not. +# Makes it absolute if it was not. +# +# Arguments +# pathVar contains the name of the variable containing the path to modify. +# prefix is optional, contains the path to use to make the other an +# absolute one. The current working directory is used if it was +# not specified. +# +# Results +# The path is modified in place. +# +# Side Effects: +# None. +# + +proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { + upvar $pathVar path + + if {![string equal [file pathtype $path] "absolute"]} { + if {$prefix == {}} { + set prefix [pwd] + } + + set path [file join $prefix $path] + } + return $path +} + +##################################################################### + +# tcltest::<variableName> +# +# Accessor functions for tcltest variables that can be modified externally. +# These are vars that could otherwise be modified using command line +# arguments to tcltest. + +# tcltest::verbose -- +# +# Set or return the verbosity level (tcltest::verbose) for tests. This +# determines what gets printed to the screen and when, with regard to the +# running of the tests. The proc does not check for invalid values. It +# assumes that a string that doesn't match its predefined keywords +# is a string containing letter-specified verbosity levels. +# +# Arguments: +# A string containing any combination of 'pbste' or a list of keywords +# (listed in parens) +# p = print output whenever a test passes (pass) +# b = print the body of the test when it fails (body) +# s = print when a test is skipped (skip) +# t = print when a test starts (start) +# e = print errorInfo and errorCode when a test encounters an error +# (error) +# +# Results: +# content of tcltest::verbose - this is always the character combination +# (pbste) instead of the list form. +# +# Side effects: +# None. + +proc tcltest::verbose { {level ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::verbose + } + if {[llength $level] > 1} { + set tcltest::verbose $level + } else { + if {[regexp {pass|body|skip|start|error} $level]} { + set tcltest::verbose $level + } else { + set levelList [split $level {}] + set tcltest::verbose [string map {p pass b body s skip t start e + error} $levelList] + } + } + return $tcltest::verbose +} + +# tcltest::isVerbose -- +# +# Returns true if argument is one of the verbosity levels currently being +# used; returns false otherwise. +# +# Arguments: +# level +# +# Results: +# boolean 1 (true) or 0 (false), depending on whether or not the level +# provided is one of the ones stored in tcltest::verbose. +# +# Side effects: +# None. + +proc tcltest::isVerbose {level} { + if {[lsearch -exact [tcltest::verbose] $level] == -1} { + return 0 + } + return 1 +} + + + +# tcltest::match -- +# +# Set or return the match patterns (tcltest::match) that determine which +# tests are run. +# +# Arguments: +# List containing match patterns (glob format) +# +# Results: +# content of tcltest::match +# +# Side effects: +# none + +proc tcltest::match { {matchList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::match + } + set tcltest::match $matchList +} + +# tcltest::skip -- +# +# Set or return the skip patterns (tcltest::skip) that determine which +# tests are skipped. +# +# Arguments: +# List containing skip patterns (glob format) +# +# Results: +# content of tcltest::skip +# +# Side effects: +# None. + +proc tcltest::skip { {skipList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skip + } + set tcltest::skip $skipList +} + +# tcltest::matchFiles -- +# +# set or return the match patterns for file sourcing +# +# Arguments: +# list containing match file list (glob format) +# +# Results: +# content of tcltest::matchFiles +# +# Side effects: +# None. + +proc tcltest::matchFiles { {matchFileList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::matchFiles + } + set tcltest::matchFiles $matchFileList +} + +# tcltest::skipFiles -- +# +# set or return the skip patterns for file sourcing +# +# Arguments: +# list containing the skip file list (glob format) +# +# Results: +# content of tcltest::skipFiles +# +# Side effects: +# None. + +proc tcltest::skipFiles { {skipFileList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skipFiles + } + set tcltest::skipFiles $skipFileList +} + + +# tcltest::matchDirectories -- +# +# set or return the list of directories for matching (glob pattern list) +# +# Arguments: +# list of glob patterns matching subdirectories of +# tcltest::testsDirectory +# +# Results: +# content of tcltest::matchDirectories +# +# Side effects: +# None. + +proc tcltest::matchDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::matchDirectories + } + set tcltest::matchDirectories $dirlist +} + +# tcltest::skipDirectories -- +# +# set or return the list of directories to skip (glob pattern list) +# +# Arguments: +# list of glob patterns matching directories to skip; these directories +# are subdirectories of tcltest::testsDirectory +# +# Results: +# content of tcltest::skipDirectories +# +# Side effects: +# None. + +proc tcltest::skipDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skipDirectories + } + set tcltest::skipDirectories $dirlist +} + +# tcltest::preserveCore -- +# +# set or return the core preservation level. This proc does not do any +# error checking for invalid values. +# +# Arguments: +# core level: +# '0' = don't do anything with core files (default) +# '1' = notify the user if core files are created +# '2' = save any core files produced during testing to +# tcltest::temporaryDirectory +# +# Results: +# content of tcltest::preserveCore +# +# Side effects: +# None. + +proc tcltest::preserveCore { {coreLevel ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::preserveCore + } + set tcltest::preserveCore $coreLevel +} + +# tcltest::outputChannel -- +# +# set or return the output file descriptor based on the supplied file +# name (where tcltest puts all of its output) +# +# Arguments: +# output file descriptor +# +# Results: +# file descriptor corresponding to supplied file name (or currently set +# file descriptor, if no new filename was supplied) - this is the content +# of tcltest::outputChannel +# +# Side effects: +# None. + +proc tcltest::outputChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::outputChannel + } + if {($filename == "stderr") || ($filename == "stdout")} { + set tcltest::outputChannel $filename + } else { + set tcltest::outputChannel [open $filename w] + } + return $tcltest::outputChannel +} + +# tcltest::outputFile -- +# +# set or return the output file name (where tcltest puts all of its +# output); calls tcltest::outputChannel to set the corresponding file +# descriptor +# +# Arguments: +# output file name +# +# Results: +# file name corresponding to supplied file name (or currently set +# file name, if no new filename was supplied) - this is the content +# of tcltest::outputFile +# +# Side effects: +# if the file name supplied is relative, it will be made absolute with +# respect to the predefined temporaryDirectory + +proc tcltest::outputFile { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::outputFile + } + if {($filename != "stderr") && ($filename != "stdout")} { + MakeAbsolutePath filename $tcltest::temporaryDirectory + } + tcltest::outputChannel $filename + set tcltest::outputFile $filename +} + +# tcltest::errorChannel -- +# +# set or return the error file descriptor based on the supplied file name +# (where tcltest sends all its errors) +# +# Arguments: +# error file name +# +# Results: +# file descriptor corresponding to the supplied file name (or currently +# set file descriptor, if no new filename was supplied) - this is the +# content of tcltest::errorChannel +# +# Side effects: +# opens the descriptor in w mode unless the filename is set to stderr or +# stdout + +proc tcltest::errorChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::errorChannel + } + if {($filename == "stderr") || ($filename == "stdout")} { + set tcltest::errorChannel $filename + } else { + set tcltest::errorChannel [open $filename w] + } + return $tcltest::errorChannel +} + +# tcltest::errorFile -- +# +# set or return the error file name; calls tcltest::errorChannel to set +# the corresponding file descriptor +# +# Arguments: +# error file name +# +# Results: +# content of tcltest::errorFile +# +# Side effects: +# if the file name supplied is relative, it will be made absolute with +# respect to the predefined temporaryDirectory + +proc tcltest::errorFile { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::errorFile + } + if {($filename != "stderr") && ($filename != "stdout")} { + MakeAbsolutePath filename $tcltest::temporaryDirectory + } + set tcltest::errorFile $filename + errorChannel $tcltest::errorFile + return $tcltest::errorFile +} + +# tcltest::debug -- +# +# set or return the debug level for tcltest; this proc does not check for +# invalid values +# +# Arguments: +# debug level: +# '0' = no debug output (default) +# '1' = skipped tests +# '2' = tcltest variables and supplied flags +# '3' = harness operations +# +# Results: +# content of tcltest::debug +# +# Side effects: +# None. + +proc tcltest::debug { {debugLevel ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::debug + } + set tcltest::debug $debugLevel +} + +# tcltest::testConstraint -- +# +# sets a test constraint to a value; to do multiple constraints, call +# this proc multiple times. also returns the value of the named +# constraint if no value was supplied. +# +# Arguments: +# constraint - name of the constraint +# value - new value for constraint (should be boolean) - if not supplied, +# this is a query +# +# Results: +# content of tcltest::testConstraints($constraint) +# +# Side effects: +# appends the constraint name to tcltest::constraintsSpecified + +proc tcltest::testConstraint {constraint {value ""}} { + DebugPuts 3 "entering testConstraint $constraint $value" + if {[llength [info level 0]] == 2} { + return $tcltest::testConstraints($constraint) + } + lappend tcltest::constraintsSpecified $constraint + set tcltest::testConstraints($constraint) $value +} + +# tcltest::constraintsSpecified -- +# +# returns a list of all the constraint names specified using +# testConstraint +# +# Arguments: +# None. +# +# Results: +# list of the constraint names in tcltest::constraintsSpecified +# +# Side effects: +# None. + +proc tcltest::constraintsSpecified {} { + return $tcltest::constraintsSpecified +} + +# tcltest::constraintList -- +# +# returns a list of all the constraint names +# +# Arguments: +# None. +# +# Results: +# list of the constraint names in tcltest::testConstraints +# +# Side effects: +# None. + +proc tcltest::constraintList {} { + return [array names tcltest::testConstraints] +} + +# tcltest::limitConstraints -- +# +# sets the limited constraints to tcltest::limitConstraints +# +# Arguments: +# list of constraint names +# +# Results: +# content of tcltest::limitConstraints +# +# Side effects: +# None. + +proc tcltest::limitConstraints { {constraintList ""} } { + DebugPuts 3 "entering limitConstraints $constraintList" + if {[llength [info level 0]] == 1} { + return $tcltest::limitConstraints + } + set tcltest::limitConstraints $constraintList + foreach elt [tcltest::constraintList] { + if {[lsearch -exact [tcltest::constraintsSpecified] $elt] == -1} { + tcltest::testConstraint $elt 0 + } + } + return $tcltest::limitConstraints +} + +# tcltest::loadScript -- +# +# sets the load script +# +# Arguments: +# script to be set +# +# Results: +# contents of tcltest::loadScript +# +# Side effects: +# None. + +proc tcltest::loadScript { {script ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::loadScript + } + set tcltest::loadScript $script +} + +# tcltest::loadFile -- +# +# set the load file (containing the load script); +# put the content of the load file into loadScript +# +# Arguments: +# script's file name +# +# Results: +# content of tcltest::loadFile +# +# Side effects: +# None. + +proc tcltest::loadFile { {scriptFile ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::loadFile + } + MakeAbsolutePath scriptFile $tcltest::temporaryDirectory + set tmp [open $scriptFile r] + tcltest::loadScript [read $tmp] + close $tmp + set tcltest::loadFile $scriptFile +} + +# tcltest::workingDirectory -- +# +# set workingDirectory to the given path. +# If the path is relative, make it absolute. +# change directory to the stated working directory, if resetting the +# value +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::workingDirectory +# +# Side effects: +# None. + +proc tcltest::workingDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::workingDirectory + } + set tcltest::workingDirectory $dir + MakeAbsolutePath tcltest::workingDirectory + cd $tcltest::workingDirectory + return $tcltest::workingDirectory +} + +# tcltest::temporaryDirectory -- +# +# Set tcltest::temporaryDirectory to the given path. +# If the path is relative, make it absolute. If the file exists but +# is not a dir, then return an error. +# +# If tcltest::temporaryDirectory does not already exist, create it. +# If you cannot create it, then return an error (the file mkdir isn't +# caught and will propagate). +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::temporaryDirectory +# +# Side effects: +# None. + +proc tcltest::temporaryDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::temporaryDirectory + } + set tcltest::temporaryDirectory $dir + + MakeAbsolutePath tcltest::temporaryDirectory + set tmpDirError "bad argument for temporary directory: " + + if {[file exists $tcltest::temporaryDirectory]} { + tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError + } else { + file mkdir $tcltest::temporaryDirectory + } + + normalizePath tcltest::temporaryDirectory +} + +# tcltest::testsDirectory -- +# +# Set tcltest::testsDirectory to the given path. +# If the path is relative, make it absolute. If the file exists but +# is not a dir, then return an error. +# +# If tcltest::testsDirectory does not already exist, return an error. +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::testsDirectory +# +# Side effects: +# None. + +proc tcltest::testsDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::testsDirectory + } + + set tcltest::testsDirectory $dir + + MakeAbsolutePath tcltest::testsDirectory + set testDirError "bad argument for tests directory: " + + if {[file exists $tcltest::testsDirectory]} { + tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError + } else { + set msg "$testDirError \"$tcltest::testsDirectory\" does not exist" + error $msg + } + + normalizePath tcltest::testsDirectory +} + +# tcltest::singleProcess -- +# +# sets tcltest::singleProcess to the value provided. +# +# Arguments: +# value for singleProcess: +# 1 = source each test file into the current process +# 0 = run each test file in its own process +# +# Results: +# content of tcltest::singleProcess +# +# Side effects: +# None. + +proc tcltest::singleProcess { {value ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::singleProcess + } + set tcltest::singleProcess $value +} + +# tcltest::interpreter -- +# +# the interpreter name stored in tcltest::tcltest +# +# Arguments: +# executable name +# +# Results: +# content of tcltest::tcltest +# +# Side effects: +# None. + +proc tcltest::interpreter { {interp ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::tcltest + } + set tcltest::tcltest $interp +} + +# tcltest::mainThread -- +# +# sets or returns the thread id stored in tcltest::mainThread +# +# Arguments: +# thread id +# +# Results: +# content of tcltest::mainThread +# +# Side effects: +# None. + +proc tcltest::mainThread { {threadid ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::mainThread + } + set tcltest::mainThread $threadid } -# ::tcltest::AddToSkippedBecause -- +##################################################################### + +# tcltest::AddToSkippedBecause -- # # Increments the variable used to track how many tests were skipped # because of a particular constraint. @@ -353,52 +1165,61 @@ proc ::tcltest::DebugDo {level script} { # constraint The name of the constraint to be modified # # Results: -# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't +# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't # previously exist - otherwise, it just increments it. +# +# Side effects: +# None. -proc ::tcltest::AddToSkippedBecause { constraint } { +proc tcltest::AddToSkippedBecause { constraint {value 1}} { # add the constraint to the list of constraints that kept tests # from running - if {[info exists ::tcltest::skippedBecause($constraint)]} { - incr ::tcltest::skippedBecause($constraint) + if {[info exists tcltest::skippedBecause($constraint)]} { + incr tcltest::skippedBecause($constraint) $value } else { - set ::tcltest::skippedBecause($constraint) 1 + set tcltest::skippedBecause($constraint) $value } return } -# ::tcltest::PrintError -- +# tcltest::PrintError -- # -# Prints errors to ::tcltest::errorChannel and then flushes that +# Prints errors to tcltest::errorChannel and then flushes that # channel, making sure that all messages are < 80 characters per line. # # Arguments: # errorMsg String containing the error to be printed # +# +# Results: +# None. +# +# Side effects: +# None. -proc ::tcltest::PrintError {errorMsg} { +proc tcltest::PrintError {errorMsg} { set InitialMessage "Error: " set InitialMsgLen [string length $InitialMessage] - puts -nonewline $::tcltest::errorChannel $InitialMessage + puts -nonewline [errorChannel] $InitialMessage # Keep track of where the end of the string is. set endingIndex [string length $errorMsg] if {$endingIndex < 80} { - puts $::tcltest::errorChannel $errorMsg + puts [errorChannel] $errorMsg } else { # Print up to 80 characters on the first line, including the # InitialMessage. set beginningIndex [string last " " [string range $errorMsg 0 \ [expr {80 - $InitialMsgLen}]]] - puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] + puts [errorChannel] [string range $errorMsg 0 $beginningIndex] while {$beginningIndex != "end"} { - puts -nonewline $::tcltest::errorChannel \ + puts -nonewline [errorChannel] \ [string repeat " " $InitialMsgLen] if {[expr {$endingIndex - $beginningIndex}] < 72} { - puts $::tcltest::errorChannel [string trim \ + puts [errorChannel] [string trim \ [string range $errorMsg $beginningIndex end]] set beginningIndex end } else { @@ -409,25 +1230,52 @@ proc ::tcltest::PrintError {errorMsg} { || ($newEndingIndex <= $beginningIndex)} { set newEndingIndex end } - puts $::tcltest::errorChannel [string trim \ + puts [errorChannel] [string trim \ [string range $errorMsg \ - $beginningIndex $newEndingIndex]] + $beginningIndex $newEndingIndex]] set beginningIndex $newEndingIndex } } } - flush $::tcltest::errorChannel + flush [errorChannel] return } -if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { - proc ::tcltest::initConstraintsHook {} {} +if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { + proc tcltest::initConstraintsHook {} {} +} + +# tcltest::safeFetch -- +# +# The following trace procedure makes it so that we can safely refer to +# non-existent members of the tcltest::testConstraints array without +# causing an error. Instead, reading a non-existent member will return +# 0. This is necessary because tests are allowed to use constraint "X" +# without ensuring that tcltest::testConstraints("X") is defined. +# +# Arguments: +# n1 - name of the array (tcltest::testConstraints) +# n2 - array key value (constraint name) +# op - operation performed on tcltest::testConstraints (generally r) +# +# Results: +# none +# +# Side effects: +# sets tcltest::testConstraints($n2) to 0 if it's referenced but never +# before used + +proc tcltest::safeFetch {n1 n2 op} { + DebugPuts 3 "entering safeFetch $n1 $n2 $op" + if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { + tcltest::testConstraint $n2 0 + } } -# ::tcltest::initConstraints -- +# tcltest::initConstraints -- # -# Check Constraintsuration information that will determine which tests -# to run. To do this, create an array ::tcltest::testConstraints. Each +# Check constraint information that will determine which tests +# to run. To do this, create an array tcltest::testConstraints. Each # element has a 0 or 1 value. If the element is "true" then tests # with that constraint will be run, otherwise tests with that constraint # will be skipped. See the tcltest man page for the list of built-in @@ -437,101 +1285,110 @@ if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { # none # # Results: -# The ::tcltest::testConstraints array is reset to have an index for +# The tcltest::testConstraints array is reset to have an index for # each built-in test constraint. +# +# Side Effects: +# None. +# -proc ::tcltest::initConstraints {} { +proc tcltest::initConstraints {} { global tcl_platform tcl_interactive tk_version - # The following trace procedure makes it so that we can safely refer to - # non-existent members of the ::tcltest::testConstraints array without - # causing an error. Instead, reading a non-existent member will return 0. - # This is necessary because tests are allowed to use constraint "X" without - # ensuring that ::tcltest::testConstraints("X") is defined. + # Safely refer to non-existent members of the tcltest::testConstraints + # array without causing an error. + trace variable tcltest::testConstraints r tcltest::safeFetch - trace variable ::tcltest::testConstraints r ::tcltest::safeFetch + tcltest::initConstraintsHook - proc ::tcltest::safeFetch {n1 n2 op} { - if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} { - set ::tcltest::testConstraints($n2) 0 - } - } + tcltest::testConstraint singleTestInterp [singleProcess] - ::tcltest::initConstraintsHook + # All the 'pc' constraints are here for backward compatibility and are not + # documented. They have been replaced with equivalent 'win' constraints. - set ::tcltest::testConstraints(unixOnly) \ + tcltest::testConstraint unixOnly \ [string equal $tcl_platform(platform) "unix"] - set ::tcltest::testConstraints(macOnly) \ + tcltest::testConstraint macOnly \ [string equal $tcl_platform(platform) "macintosh"] - set ::tcltest::testConstraints(pcOnly) \ + tcltest::testConstraint pcOnly \ + [string equal $tcl_platform(platform) "windows"] + tcltest::testConstraint winOnly \ [string equal $tcl_platform(platform) "windows"] - set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly) - set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly) - set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly) - - set ::tcltest::testConstraints(unixOrPc) \ - [expr {$::tcltest::testConstraints(unix) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrPc) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrUnix) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(unix)}] - - set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \ - "Windows NT"] - set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \ - "Windows 95"] - set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \ - "Windows 98"] + tcltest::testConstraint unix [tcltest::testConstraint unixOnly] + tcltest::testConstraint mac [tcltest::testConstraint macOnly] + tcltest::testConstraint pc [tcltest::testConstraint pcOnly] + tcltest::testConstraint win [tcltest::testConstraint winOnly] + + tcltest::testConstraint unixOrPc \ + [expr {[tcltest::testConstraint unix] \ + || [tcltest::testConstraint pc]}] + tcltest::testConstraint macOrPc \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint pc]}] + tcltest::testConstraint unixOrWin \ + [expr {[tcltest::testConstraint unix] \ + || [tcltest::testConstraint win]}] + tcltest::testConstraint macOrWin \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint win]}] + tcltest::testConstraint macOrUnix \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint unix]}] + + tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"] + tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"] + tcltest::testConstraint 98 [string equal $tcl_platform(os) "Windows 98"] # The following Constraints switches are used to mark tests that should # work, but have been temporarily disabled on certain platforms because # they don't and we haven't gotten around to fixing the underlying # problem. - set ::tcltest::testConstraints(tempNotPc) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(tempNotMac) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(tempNotUnix) \ - [expr {!$::tcltest::testConstraints(unix)}] + tcltest::testConstraint tempNotPc \ + [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint tempNotWin \ + [expr {![tcltest::testConstraint win]}] + tcltest::testConstraint tempNotMac \ + [expr {![tcltest::testConstraint mac]}] + tcltest::testConstraint tempNotUnix \ + [expr {![tcltest::testConstraint unix]}] # The following Constraints switches are used to mark tests that crash on # certain platforms, so that they can be reactivated again when the # underlying problem is fixed. - set ::tcltest::testConstraints(pcCrash) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macCrash) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(unixCrash) \ - [expr {!$::tcltest::testConstraints(unix)}] + tcltest::testConstraint pcCrash \ + [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint winCrash \ + [expr {![tcltest::testConstraint win]}] + tcltest::testConstraint macCrash \ + [expr {![tcltest::testConstraint mac]}] + tcltest::testConstraint unixCrash \ + [expr {![tcltest::testConstraint unix]}] # Skip empty tests - set ::tcltest::testConstraints(emptyTest) 0 + tcltest::testConstraint emptyTest 0 # By default, tests that expose known bugs are skipped. - set ::tcltest::testConstraints(knownBug) 0 + tcltest::testConstraint knownBug 0 # By default, non-portable tests are skipped. - set ::tcltest::testConstraints(nonPortable) 0 + tcltest::testConstraint nonPortable 0 # Some tests require user interaction. - set ::tcltest::testConstraints(userInteraction) 0 + tcltest::testConstraint userInteraction 0 # Some tests must be skipped if the interpreter is not in interactive mode if {[info exists tcl_interactive]} { - set ::tcltest::testConstraints(interactive) $::tcl_interactive + tcltest::testConstraint interactive $::tcl_interactive } else { - set ::tcltest::testConstraints(interactive) 0 + tcltest::testConstraint interactive 0 } # Some tests can only be run if the installation came from a CD image @@ -539,8 +1396,8 @@ proc ::tcltest::initConstraints {} { # Some tests must be skipped if you are running as root on Unix. # Other tests can only be run if you are running as root on Unix. - set ::tcltest::testConstraints(root) 0 - set ::tcltest::testConstraints(notRoot) 1 + tcltest::testConstraint root 0 + tcltest::testConstraint notRoot 1 set user {} if {[string equal $tcl_platform(platform) "unix"]} { catch {set user [exec whoami]} @@ -548,21 +1405,21 @@ proc ::tcltest::initConstraints {} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} } if {([string equal $user "root"]) || ([string equal $user ""])} { - set ::tcltest::testConstraints(root) 1 - set ::tcltest::testConstraints(notRoot) 0 + tcltest::testConstraint root 1 + tcltest::testConstraint notRoot 0 } } # Set nonBlockFiles constraint: 1 means this platform supports - # setting files into nonblocking mode. + # ting files into nonblocking mode. if {[catch {set f [open defs r]}]} { - set ::tcltest::testConstraints(nonBlockFiles) 1 + tcltest::testConstraint nonBlockFiles 1 } else { if {[catch {fconfigure $f -blocking off}] == 0} { - set ::tcltest::testConstraints(nonBlockFiles) 1 + tcltest::testConstraint nonBlockFiles 1 } else { - set ::tcltest::testConstraints(nonBlockFiles) 0 + tcltest::testConstraint nonBlockFiles 0 } close $f } @@ -576,75 +1433,75 @@ proc ::tcltest::initConstraints {} { if {[string equal $tcl_platform(platform) "unix"]} { if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - set ::tcltest::testConstraints(asyncPipeClose) 0 + tcltest::testConstraint asyncPipeClose 0 } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 + tcltest::testConstraint asyncPipeClose 1 } } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 + tcltest::testConstraint asyncPipeClose 1 } # Test to see if we have a broken version of sprintf with respect # to the "e" format of floating-point numbers. - set ::tcltest::testConstraints(eformat) 1 + tcltest::testConstraint eformat 1 if {![string equal "[format %g 5e-5]" "5e-05"]} { - set ::tcltest::testConstraints(eformat) 0 + tcltest::testConstraint eformat 0 } # Test to see if execed commands such as cat, echo, rm and so forth are # present on this machine. - set ::tcltest::testConstraints(unixExecs) 1 + tcltest::testConstraint unixExecs 1 if {[string equal $tcl_platform(platform) "macintosh"]} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([string equal $tcl_platform(platform) "windows"])} { if {[catch {exec cat defs}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec sh -c echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec wc defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {$::tcltest::testConstraints(unixExecs) == 1} { + if {[tcltest::testConstraint unixExecs] == 1} { exec echo hello > removeMe if {[catch {exec rm removeMe}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec sleep 1}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec fgrep unixExecs defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec ps}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec echo abc > removeMe}] == 0) && \ ([catch {exec chmod 644 removeMe}] == 1) && \ ([catch {exec rm removeMe}] == 0)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } else { catch {exec rm -f removeMe} } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec mkdir removeMe}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } else { catch {exec rm -r removeMe} } @@ -653,14 +1510,14 @@ proc ::tcltest::initConstraints {} { # Locate tcltest executable if {![info exists tk_version]} { - set tcltest [info nameofexecutable] + set tcltest::tcltest [info nameofexecutable] - if {$tcltest == "{}"} { - set tcltest {} + if {$tcltest::tcltest == "{}"} { + set tcltest::tcltest {} } } - set ::tcltest::testConstraints(stdio) 0 + tcltest::testConstraint stdio 0 catch { catch {file delete -force tmp} set f [open tmp w] @@ -672,7 +1529,7 @@ proc ::tcltest::initConstraints {} { set f [open "|[list $tcltest tmp]" r] close $f - set ::tcltest::testConstraints(stdio) 1 + tcltest::testConstraint stdio 1 } catch {file delete -force tmp} @@ -681,50 +1538,62 @@ proc ::tcltest::initConstraints {} { # system. catch {socket} msg - set ::tcltest::testConstraints(socket) \ + tcltest::testConstraint socket \ [expr {$msg != "sockets are not available on this system"}] # Check for internationalization if {[info commands testlocale] == ""} { # No testlocale command, no tests... - set ::tcltest::testConstraints(hasIsoLocale) 0 + tcltest::testConstraint hasIsoLocale 0 } else { - set ::tcltest::testConstraints(hasIsoLocale) \ - [string length [::tcltest::set_iso8859_1_locale]] - ::tcltest::restore_locale + tcltest::testConstraint hasIsoLocale \ + [string length [tcltest::set_iso8859_1_locale]] + tcltest::restore_locale } } -# ::tcltest::PrintUsageInfoHook +##################################################################### + +# Handle command line arguments (from argv) and default arg settings +# (in TCLTEST_OPTIONS). + +# tcltest::PrintUsageInfoHook # # Hook used for customization of display of usage information. # -if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} { - proc ::tcltest::PrintUsageInfoHook {} {} +if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} { + proc tcltest::PrintUsageInfoHook {} {} } -# ::tcltest::PrintUsageInfo +# tcltest::PrintUsageInfo # # Prints out the usage information for package tcltest. This can be -# customized with the redefinition of ::tcltest::PrintUsageInfoHook. +# customized with the redefinition of tcltest::PrintUsageInfoHook. # # Arguments: # none # +# Results: +# none +# +# Side Effects: +# none -proc ::tcltest::PrintUsageInfo {} { +proc tcltest::PrintUsageInfo {} { puts [format "Usage: [file tail [info nameofexecutable]] \ script ?-help? ?flag value? ... \n\ Available flags (and valid input values) are: \n\ -help \t Display this usage information. \n\ -verbose level \t Takes any combination of the values \n\ - \t 'p', 's' and 'b'. Test suite will \n\ + \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\ \t display all passed tests if 'p' is \n\ \t specified, all skipped tests if 's' \n\ - \t is specified, and the bodies of \n\ - \t failed tests if 'b' is specified. \n\ + \t is specified, the bodies of \n\ + \t failed tests if 'b' is specified, \n\ + \t and when tests start if 't' is specified. \n\ + \t ErrorInfo is displayed if 'e' is specified. \n\ \t The default value is 'b'. \n\ -constraints list\t Do not skip the listed constraints\n\ -limitconstraints bool\t Only run tests with the constraints\n\ @@ -740,17 +1609,21 @@ proc ::tcltest::PrintUsageInfo {} { \t match the glob pattern given. \n\ -notfile pattern\t Skip all test files that match the \n\ \t glob pattern given. \n\ + -relateddir pattern\t Run tests in directories that match \n\ + \t the glob pattern given. \n\ + -asidefromdir pattern\t Skip tests in directories that match \n\ + \t the glob pattern given.\n\ -preservecore level \t If 2, save any core files produced \n\ \t during testing in the directory \n\ \t specified by -tmpdir. If 1, notify the\n\ \t user if core files are created. The default \n\ - \t is $::tcltest::preserveCore. \n\ + \t is $tcltest::preserveCore. \n\ -tmpdir directory\t Save temporary files in the specified\n\ \t directory. The default value is \n\ - \t $::tcltest::temporaryDirectory. \n\ + \t $tcltest::temporaryDirectory. \n\ -testdir directories\t Search tests in the specified\n\ \t directories. The default value is \n\ - \t $::tcltest::testsDirectory. \n\ + \t $tcltest::testsDirectory. \n\ -outfile file \t Send output from test runs to the \n\ \t specified file. The default is \n\ \t stdout. \n\ @@ -762,207 +1635,98 @@ proc ::tcltest::PrintUsageInfo {} { -load script \t Specifies the script to load the tested \n\ \t commands. \n\ -debug level \t Internal debug flag."] - ::tcltest::PrintUsageInfoHook + tcltest::PrintUsageInfoHook return } -# ::tcltest::CheckDirectory -- -# -# This procedure checks whether the specified path is a readable -# and/or writable directory. If one of the conditions is not -# satisfied an error is printed and the application aborted. The -# procedure assumes that the caller already checked the existence -# of the path. -# -# Arguments -# rw Information what attributes to check. Allowed values: -# r, w, rw, wr. If 'r' is part of the value the directory -# must be readable. 'w' associates to 'writable'. -# dir The directory to check. -# errMsg The string to prepend to the actual error message before -# printing it. -# -# Results -# none -# - -proc ::tcltest::CheckDirectory {rw dir errMsg} { - # Allowed values for 'rw': r, w, rw, wr - - if {![file isdir $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not a directory" - exit 1 - } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not writeable" - exit 1 - } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not readable" - exit 1 - } -} - -# ::tcltest::normalizePath -- -# -# This procedure resolves any symlinks in the path thus creating a -# path without internal redirection. It assumes that the incoming -# path is absolute. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::normalizePath {pathVar} { - upvar $pathVar path - - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd -} - -# ::tcltest::MakeAbsolutePath -- -# -# This procedure checks whether the incoming path is absolute or not. -# Makes it absolute if it was not. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# prefix is optional, contains the path to use to make the other an -# absolute one. The current working directory is used if it was -# not specified. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} { - upvar $pathVar path - - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { - set prefix [pwd] - } - - set path [file join $prefix $path] - } -} - -# ::tcltest::processCmdLineArgsFlagsHook -- +# tcltest::processCmdLineArgsFlagsHook -- # # This hook is used to add to the list of command line arguments that are -# processed by ::tcltest::processCmdLineArgs. +# processed by tcltest::ProcessFlags. It is called at the beginning of +# ProcessFlags. # -if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { - proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} +if {[namespace inscope tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { + proc tcltest::processCmdLineArgsAddFlagsHook {} {} } -# ::tcltest::processCmdLineArgsHook -- +# tcltest::processCmdLineArgsHook -- # # This hook is used to actually process the flags added by -# ::tcltest::processCmdLineArgsAddFlagsHook. +# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of +# ProcessFlags. # # Arguments: # flags The flags that have been pulled out of argv # -if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} { - proc ::tcltest::processCmdLineArgsHook {flag} {} +if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} { + proc tcltest::processCmdLineArgsHook {flag} {} } -# ::tcltest::processCmdLineArgs -- +# tcltest::ProcessFlags -- # -# Use command line args to set the verbose, skip, and -# match, outputChannel, errorChannel, debug, and temporaryDirectory -# variables. -# -# This procedure must be run after constraints are initialized, because -# some constraints can be overridden. +# process command line arguments supplied in the flagArray - this is +# called by processCmdLineArgs +# modifies tcltest variables according to the content of the flagArray. # # Arguments: -# none +# flagArray - array containing name/value pairs of flags # # Results: -# Sets the above-named variables in the tcltest namespace. - -proc ::tcltest::processCmdLineArgs {} { - global argv - - # The "argv" var doesn't exist in some cases, so use {}. - - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv - } - - # Allow for 1-char abbreviations, where applicable (e.g., -match == -m). - # Note that -verbose cannot be abbreviated to -v in wish because it - # conflicts with the wish option -visual. +# sets tcltest variables according to their values as defined by +# flagArray +# +# Side effects: +# None. +proc tcltest::ProcessFlags {flagArray} { # Process -help first - if {([lsearch -exact $flagArray {-help}] != -1) || \ - ([lsearch -exact $flagArray {-h}] != -1)} { - ::tcltest::PrintUsageInfo - exit 1 - } - - if {[catch {array set flag $flagArray}]} { - ::tcltest::PrintError "odd number of arguments specified on command line: \ - $argv" - ::tcltest::PrintUsageInfo + if {[lsearch -exact $flagArray {-help}] != -1} { + tcltest::PrintUsageInfo exit 1 } + + catch {array set flag $flagArray} # -help is not listed since it has already been processed lappend defaultFlags -verbose -match -skip -constraints \ -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints -args -testdir \ - -load -loadfile + -preservecore -limitconstraints -testdir \ + -load -loadfile -asidefromdir \ + -relateddir -singleproc set defaultFlags [concat $defaultFlags \ - [ ::tcltest::processCmdLineArgsAddFlagsHook ]] - - foreach arg $defaultFlags { - set abbrev [string range $arg 0 1] - if {([info exists flag($abbrev)]) && \ - ([lsearch -exact $flagArray $arg] < [lsearch -exact \ - $flagArray $abbrev])} { - set flag($arg) $flag($abbrev) - } - } - - # Set ::tcltest::parameters to the arg of the -args flag, if given - if {[info exists flag(-args)]} { - set ::tcltest::parameters $flag(-args) - } - - # Set ::tcltest::verbose to the arg of the -verbose flag, if given + [tcltest::processCmdLineArgsAddFlagsHook ]] + # Set tcltest::verbose to the arg of the -verbose flag, if given if {[info exists flag(-verbose)]} { - set ::tcltest::verbose $flag(-verbose) + tcltest::verbose $flag(-verbose) } - # Set ::tcltest::match to the arg of the -match flag, if given. - + # Set tcltest::match to the arg of the -match flag, if given. if {[info exists flag(-match)]} { - set ::tcltest::match $flag(-match) + tcltest::match $flag(-match) } - # Set ::tcltest::skip to the arg of the -skip flag, if given - + # Set tcltest::skip to the arg of the -skip flag, if given if {[info exists flag(-skip)]} { - set ::tcltest::skip $flag(-skip) + tcltest::skip $flag(-skip) } # Handle the -file and -notfile flags if {[info exists flag(-file)]} { - set ::tcltest::matchFiles $flag(-file) + tcltest::matchFiles $flag(-file) } if {[info exists flag(-notfile)]} { - set ::tcltest::skipFiles $flag(-notfile) + tcltest::skipFiles $flag(-notfile) + } + + # Handle -relateddir and -asidefromdir flags + if {[info exists flag(-relateddir)]} { + tcltest::matchDirectories $flag(-relateddir) + } + if {[info exists flag(-asidefromdir)]} { + tcltest::skipDirectories $flag(-asidefromdir) } # Use the -constraints flag, if given, to turn on constraints that are @@ -971,7 +1735,7 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-constraints)]} { foreach elt $flag(-constraints) { - set ::tcltest::testConstraints($elt) 1 + tcltest::testConstraint $elt 1 } } @@ -980,87 +1744,35 @@ proc ::tcltest::processCmdLineArgs {} { # the -constraints flag was not specified, print out an error and exit. if {[info exists flag(-limitconstraints)]} { if {![info exists flag(-constraints)]} { - puts "You can only use the -limitconstraints flag with \ - -constraints" - exit 1 - } - set ::tcltest::limitConstraints $flag(-limitconstraints) - foreach elt [array names ::tcltest::testConstraints] { - if {[lsearch -exact $flag(-constraints) $elt] == -1} { - set ::tcltest::testConstraints($elt) 0 - } + set msg "-limitconstraints flag can only be used with -constraints" + error $msg } + tcltest::limitConstraints $flag(-limitconstraints) } - # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if + # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist, create it. - # If you cannot create it, then return an error. - set tmpDirError "" if {[info exists flag(-tmpdir)]} { - set ::tcltest::temporaryDirectory $flag(-tmpdir) - - MakeAbsolutePath ::tcltest::temporaryDirectory - set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: " - } - if {[file exists $::tcltest::temporaryDirectory]} { - ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError - } else { - file mkdir $::tcltest::temporaryDirectory + tcltest::temporaryDirectory $flag(-tmpdir) } - normalizePath ::tcltest::temporaryDirectory - - # Set the ::tcltest::testsDirectory to the arg of -testdir, if + # Set the tcltest::testsDirectory to the arg of -testdir, if # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist return an error. - set testDirError "" if {[info exists flag(-testdir)]} { - set ::tcltest::testsDirectory $flag(-testdir) - - MakeAbsolutePath ::tcltest::testsDirectory - set testDirError "bad argument \"$flag(-testdir)\" to -testdir: " - } - if {[file exists $::tcltest::testsDirectory]} { - ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError - } else { - ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \ - does not exist" - exit 1 - } - - normalizePath ::tcltest::testsDirectory - - # Save the names of files that already exist in - # the output directory. - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend ::tcltest::filesExisted [file tail $file] + tcltest::testsDirectory $flag(-testdir) } # If an alternate error or output files are specified, change the # default channels. if {[info exists flag(-outfile)]} { - set tmp $flag(-outfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::outputChannel [open $tmp w] + tcltest::outputFile $flag(-outfile) } if {[info exists flag(-errfile)]} { - set tmp $flag(-errfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::errorChannel [open $tmp w] + tcltest::errorFile $flag(-errfile) } # If a load script was specified, either directly or through @@ -1068,294 +1780,647 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-load)] && \ ([lsearch -exact $flagArray -load] > \ - [lsearch -exact $flagArray -loadfile])} { - set ::tcltest::loadScript $flag(-load) + [lsearch -exact $flagArray -loadfile])} { + tcltest::loadScript $flag(-load) } if {[info exists flag(-loadfile)] && \ ([lsearch -exact $flagArray -loadfile] > \ - [lsearch -exact $flagArray -load]) } { - set tmp $flag(-loadfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set tmp [open $tmp r] - set ::tcltest::loadScript [read $tmp] - close $tmp + [lsearch -exact $flagArray -load]) } { + tcltest::loadFile $flag(-loadfile) } # If the user specifies debug testing, print out extra information during # the run. if {[info exists flag(-debug)]} { - set ::tcltest::debug $flag(-debug) + tcltest::debug $flag(-debug) } # Handle -preservecore if {[info exists flag(-preservecore)]} { - set ::tcltest::preserveCore $flag(-preservecore) + tcltest::preserveCore $flag(-preservecore) + } + + # Handle -singleproc flag + if {[info exists flag(-singleproc)]} { + tcltest::singleProcess $flag(-singleproc) } # Call the hook - ::tcltest::processCmdLineArgsHook [array get flag] + tcltest::processCmdLineArgsHook [array get flag] + return +} - # Spit out everything you know if we're at a debug level 2 or greater +# tcltest::processCmdLineArgs -- +# +# Use command line args to set tcltest namespace variables. +# +# This procedure must be run after constraints are initialized, because +# some constraints can be overridden. +# +# Set variables based on the contents of the environment variable +# TCLTEST_OPTIONS first, then override with command-line options, if +# specified. +# +# Arguments: +# none +# +# Results: +# Sets the above-named variables in the tcltest namespace. +# +# Side Effects: +# None. +# + +proc tcltest::processCmdLineArgs {} { + global argv + + # If the TCLTEST_OPTIONS environment variable exists, parse it first, then + # the argv list. The command line argument parsing will be a two-pass + # affair from now on, so that TCLTEST_OPTIONS contain the default options. + # These can be overridden by the command line flags. + + if {[info exists ::env(TCLTEST_OPTIONS)]} { + tcltest::ProcessFlags $::env(TCLTEST_OPTIONS) + } + + # The "argv" var doesn't exist in some cases, so use {}. + if {(![info exists argv]) || ([llength $argv] < 1)} { + set flagArray {} + } else { + set flagArray $argv + } + + tcltest::ProcessFlags $flagArray - DebugPuts 2 "Flags passed into tcltest:" - DebugPArray 2 flag - DebugPuts 2 "::tcltest::debug = $::tcltest::debug" - DebugPuts 2 "::tcltest::testsDirectory = $::tcltest::testsDirectory" - DebugPuts 2 "::tcltest::workingDirectory = $::tcltest::workingDirectory" - DebugPuts 2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory" - DebugPuts 2 "::tcltest::outputChannel = $::tcltest::outputChannel" - DebugPuts 2 "::tcltest::errorChannel = $::tcltest::errorChannel" - DebugPuts 2 "Original environment (::tcltest::originalEnv):" - DebugPArray 2 ::tcltest::originalEnv + # Spit out everything you know if we're at a debug level 2 or greater + DebugPuts 2 "Flags passed into tcltest:" + if {[info exists ::env(TCLTEST_OPTIONS)]} { + DebugPuts 2 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" + } + if {[info exists argv]} { + DebugPuts 2 " argv: $argv" + } + DebugPuts 2 "tcltest::debug = [tcltest::debug]" + DebugPuts 2 "tcltest::testsDirectory = [tcltest::testsDirectory]" + DebugPuts 2 "tcltest::workingDirectory = [tcltest::workingDirectory]" + DebugPuts 2 "tcltest::temporaryDirectory = [tcltest::temporaryDirectory]" + DebugPuts 2 "tcltest::outputChannel = [outputChannel]" + DebugPuts 2 "tcltest::errorChannel = [errorChannel]" + DebugPuts 2 "Original environment (tcltest::originalEnv):" + DebugPArray 2 tcltest::originalEnv DebugPuts 2 "Constraints:" - DebugPArray 2 ::tcltest::testConstraints + DebugPArray 2 tcltest::testConstraints + return } -# ::tcltest::loadTestedCommands -- +##################################################################### + +# Code to run the tests goes here. + +# tcltest::testPuts -- # -# Uses the specified script to load the commands to test. Allowed to -# be empty, as the tested commands could have been compiled into the -# interpreter. +# Used to redefine puts in test environment. +# Stores whatever goes out on stdout in tcltest::outData and stderr in +# tcltest::errData before sending it on to the regular puts. # -# Arguments -# none +# Arguments: +# same as standard puts # -# Results -# none +# Results: +# none +# +# Side effects: +# Intercepts puts; data that would otherwise go to stdout, stderr, or +# file channels specified in tcltest::outputChannel and errorChannel does +# not get sent to the normal puts function. + +proc tcltest::testPuts {args} { + set len [llength $args] + if {$len == 1} { + # Only the string to be printed is specified + append tcltest::outData "[lindex $args 0]\n" + return +# return [tcltest::normalPuts [lindex $args 0]] + } elseif {$len == 2} { + # Either -nonewline or channelId has been specified + if {[regexp {^-nonewline} [lindex $args 0]]} { + append tcltest::outData "[lindex $args end]" + return +# return [tcltest::normalPuts -nonewline [lindex $args end]] + } else { + set channel [lindex $args 0] + } + } elseif {$len == 3} { + if {[lindex $args 0] == "-nonewline"} { + # Both -nonewline and channelId are specified, unless it's an + # error. -nonewline is supposed to be argv[0]. + set channel [lindex $args 1] + } + } -proc ::tcltest::loadTestedCommands {} { - if {$::tcltest::loadScript == {}} { + if {[info exists channel]} { + if {($channel == [outputChannel]) || ($channel == "stdout")} { + append tcltest::outData "[lindex $args end]\n" + } elseif {($channel == [errorChannel]) || ($channel == "stderr")} { + append tcltest::errData "[lindex $args end]\n" + } return + # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]] } - - uplevel #0 $::tcltest::loadScript + + # If we haven't returned by now, we don't know how to handle the input. + # Let puts handle it. + return [eval tcltest::normalPuts $args] } -# ::tcltest::cleanupTests -- +# tcltest::testEval -- # -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. +# Evaluate the script in the test environment. If ignoreOutput is +# false, store data sent to stderr and stdout in tcltest::outData and +# tcltest::errData. Otherwise, ignore this output altogether. # -# Print the names of the files created without the makeFile command -# since the tests were invoked. +# Arguments: +# script Script to evaluate +# ?ignoreOutput? Indicates whether or not to ignore output sent to +# stdout & stderr # -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). - -proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { - - set testFileName [file tail [info script]] +# Results: +# result from running the script +# +# Side effects: +# Empties the contents of tcltest::outData and tcltest::errData before +# running a test if ignoreOutput is set to 0. - # Call the cleanup hook - ::tcltest::cleanupTestsHook +proc tcltest::testEval {script {ignoreOutput 1}} { + DebugPuts 3 "testEval called" + if {!$ignoreOutput} { + set tcltest::outData {} + set tcltest::errData {} + uplevel rename ::puts tcltest::normalPuts + uplevel rename tcltest::testPuts ::puts + } + set result [uplevel $script] + if {!$ignoreOutput} { + uplevel rename ::puts tcltest::testPuts + uplevel rename tcltest::normalPuts ::puts + } + return $result +} - # Remove files and directories created by the :tcltest::makeFile and - # ::tcltest::makeDirectory procedures. - # Record the names of files in ::tcltest::workingDirectory that were not - # pre-existing, and associate them with the test file that created them. +# compareStrings -- +# +# compares the expected answer to the actual answer, depending on the +# mode provided. Mode determines whether a regexp, exact, or glob +# comparison is done. +# +# Arguments: +# actual - string containing the actual result +# expected - pattern to be matched against +# mode - type of comparison to be done +# +# Results: +# result of the match +# +# Side effects: +# None. - if {!$calledFromAllFile} { - foreach file $::tcltest::filesMade { - if {[file exists $file]} { - catch {file delete -force $file} - } +proc tcltest::compareStrings {actual expected mode} { + switch -- $mode { + exact { + set retval [string equal $actual $expected] } - set currentFiles {} - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend currentFiles [file tail $file] + glob { + set retval [string match $expected $actual] } - set newFiles {} - foreach file $currentFiles { - if {[lsearch -exact $::tcltest::filesExisted $file] == -1} { - lappend newFiles $file - } - } - set ::tcltest::filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set ::tcltest::createdNewFiles($testFileName) $newFiles + regexp { + set retval [regexp -- $expected $actual] } } + return $retval +} - if {$calledFromAllFile || $::tcltest::testSingleFile} { - # print stats +# +# tcltest::substArguments list +# +# This helper function takes in a list of words, then perform a +# substitution on the list as though each word in the list is a +# separate argument to the Tcl function. For example, if this +# function is invoked as: +# +# substArguments {$a {$a}} +# +# Then it is as though the function is invoked as: +# +# substArguments $a {$a} +# +# This code is adapted from Paul Duffin's function "SplitIntoWords". +# The original function can be found on: +# +# http://purl.org/thecliff/tcl/wiki/858.html +# +# Results: +# a list containing the result of the substitution +# +# Exceptions: +# An error may occur if the list containing unbalanced quote or +# unknown variable. +# +# Side Effects: +# None. +# + +proc tcltest::substArguments {argList} { + + # We need to split the argList up into tokens but cannot use + # list operations as they throw away some significant + # quoting, and [split] ignores braces as it should. + # Therefore what we do is gradually build up a string out of + # whitespace seperated strings. We cannot use [split] to + # split the argList into whitespace seperated strings as it + # throws away the whitespace which maybe important so we + # have to do it all by hand. + + set result {} + set token "" + + while {[string length $argList]} { + # Look for the next word containing a quote: " { } + if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ + $argList all]} { + # Get the text leading up to this word, but not + # including this word, from the argList. + set text [string range $argList 0 \ + [expr {[lindex $all 0] - 1}]] + # Get the word with the quote + set word [string range $argList \ + [lindex $all 0] [lindex $all 1]] + + # Remove all text up to and including the word from the + # argList. + set argList [string range $argList \ + [expr {[lindex $all 1] + 1}] end] + } else { + # Take everything up to the end of the argList. + set text $argList + set word {} + set argList {} + } + + if {$token != {}} { + # If we saw a word with quote before, then there is a + # multi-word token starting with that word. In this case, + # add the text and the current word to this token. + append token $text $word + } else { + # Add the text to the result. There is no need to parse + # the text because it couldn't be a part of any multi-word + # token. Then start a new multi-word token with the word + # because we need to pass this token to the Tcl parser to + # check for balancing quotes + append result $text + set token $word + } + + if { [catch {llength $token} length] == 0 && $length == 1} { + # The token is a valid list so add it to the result. + # lappend result [string trim $token] + append result \{$token\} + set token {} + } + } - puts -nonewline $::tcltest::outputChannel "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline $::tcltest::outputChannel \ - "\t$index\t$::tcltest::numTests($index)" - } - puts $::tcltest::outputChannel "" + # If the last token has not been added to the list then there + # is a problem. + if { [string length $token] } { + error "incomplete token \"$token\"" + } - # print number test files sourced - # print names of files that ran tests which failed + return $result +} - if {$calledFromAllFile} { - puts $::tcltest::outputChannel \ - "Sourced $::tcltest::numTestFiles Test Files." - set ::tcltest::numTestFiles 0 - if {[llength $::tcltest::failFiles] > 0} { - puts $::tcltest::outputChannel \ - "Files with failing tests: $::tcltest::failFiles" - set ::tcltest::failFiles {} - } - } - # if any tests were skipped, print the constraints that kept them - # from running. +# tcltest::test -- +# +# This procedure runs a test and prints an error message if the test fails. +# If tcltest::verbose has been set, it also prints a message even if the +# test succeeds. The test will be skipped if it doesn't match the +# tcltest::match variable, if it matches an element in +# tcltest::skip, or if one of the elements of "constraints" turns +# out not to be true. +# +# If testLevel is 1, then this is a top level test, and we record pass/fail +# information; otherwise, this information is not logged and is not added to +# running totals. +# +# Attributes: +# Only description is a required attribute. All others are optional. +# Default values are indicated. +# +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "tcltest::testConstraints". If any +# of these elements is zero, the test is +# skipped. This attribute is optional; default is {} +# body - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. This attribute is optional; +# default is {} +# result - Expected result from script. This attribute is +# optional; default is {}. +# output - Expected output sent to stdout. This attribute +# is optional; default is {}. +# errorOutput - Expected output sent to stderr. This attribute +# is optional; default is {}. +# returnCodes - Expected return codes. This attribute is +# optional; default is {0 2}. +# setup - Code to run before $script (above). This +# attribute is optional; default is {}. +# cleanup - Code to run after $script (above). This +# attribute is optional; default is {}. +# match - specifies type of matching to do on result, +# output, errorOutput; this must be one of: exact, +# glob, regexp. default is exact. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# +# Results: +# 0 if the command ran successfully; 1 otherwise. +# +# Side effects: +# None. +# - set constraintList [array names ::tcltest::skippedBecause] - if {[llength $constraintList] > 0} { - puts $::tcltest::outputChannel \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts $::tcltest::outputChannel \ - "\t$::tcltest::skippedBecause($constraint)\t$constraint" - unset ::tcltest::skippedBecause($constraint) - } - } +proc tcltest::test {name description args} { + DebugPuts 3 "Test $name $args" - # report the names of test files in ::tcltest::createdNewFiles, and - # reset the array to be empty. + incr tcltest::testLevel - set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts $::tcltest::outputChannel "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts $::tcltest::outputChannel \ - "\t$testFile:\t$::tcltest::createdNewFiles($testFile)" - unset ::tcltest::createdNewFiles($testFile) + # Pre-define everything to null except output and errorOutput. We + # determine whether or not to trap output based on whether or not these + # variables (output & errorOutput) are defined. + foreach item {constraints setup cleanup body result returnCodes match} { + set $item {} + } + + # Set the default match mode + set match exact + + # Set the default match values for return codes (0 is the standard expected + # return value if everything went well; 2 represents 'return' being used in + # the test script). + set returnCodes [list 0 2] + + # The old test format can't have a 3rd argument (constraints or script) + # that starts with '-'. + if {[llength $args] == 0} { + puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}" + incr tcltest::testLevel -1 + return 1 + } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} { + + if {[llength $args] == 1} { + set list [substArguments [lindex $args 0]] + foreach {element value} $list { + set testAttributes($element) $value + } + foreach item {constraints match setup body cleanup \ + result returnCodes output errorOutput} { + if {[info exists testAttributes([subst -$item])]} { + set testAttributes([subst -$item]) \ + [uplevel concat $testAttributes([subst -$item])] + } } + } else { + array set testAttributes $args } - # reset filesMade, filesExisted, and numTests + set validFlags {-setup -cleanup -body -result -returnCodes -match \ + -output -errorOutput -constraints} - set ::tcltest::filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set ::tcltest::numTests($index) 0 + foreach flag [array names testAttributes] { + if {[lsearch -exact $validFlags $flag] == -1} { + puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test" + incr tcltest::testLevel -1 + return 1 + } } - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && ![info exists tcl_interactive]} { - exit + # store whatever the user gave us + foreach item [array names testAttributes] { + set [string trimleft $item "-"] $testAttributes($item) } - } else { - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed + # Check the values supplied for -match + if {[lsearch {regexp glob exact} $match] == -1} { + puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}" + incr tcltest::testLevel -1 + return 1 + } - incr ::tcltest::numTestFiles - if {($::tcltest::currentFailure) && \ - ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} { - lappend ::tcltest::failFiles $testFileName + # Replace symbolic valies supplied for -returnCodes + regsub -nocase normal $returnCodes 0 returnCodes + regsub -nocase error $returnCodes 1 returnCodes + regsub -nocase return $returnCodes 2 returnCodes + regsub -nocase break $returnCodes 3 returnCodes + regsub -nocase continue $returnCodes 4 returnCodes + } else { + # This is parsing for the old test command format; it is here for + # backward compatibility. + set result [lindex $args end] + if {[llength $args] == 2} { + set body [lindex $args 0] + } elseif {[llength $args] == 3} { + set constraints [lindex $args 0] + set body [lindex $args 1] + } else { + puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}" + incr tcltest::testLevel -1 + return 1 } - set ::tcltest::currentFailure false + } - # restore the environment to the state it was in before this package - # was loaded + set setupFailure 0 + set cleanupFailure 0 - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists ::tcltest::originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { - if {$::env($index) != $::tcltest::originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $::tcltest::originalEnv($index) - } - } + # Run the setup script + if {[catch {uplevel $setup} setupMsg]} { + set setupFailure 1 + } + + # run the test script + set command [list tcltest::runTest $name $description $body \ + $result $constraints] + if {!$setupFailure} { + if {[info exists output] || [info exists errorOutput]} { + set testResult [uplevel tcltest::testEval [list $command] 0] + } else { + set testResult [uplevel tcltest::testEval [list $command] 1] } - foreach index [array names ::tcltest::originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $::tcltest::originalEnv($index) + } else { + set testResult setupFailure + } + + # Run the cleanup code + if {[catch {uplevel $cleanup} cleanupMsg]} { + set cleanupFailure 1 + } + + # If testResult is an empty list, then the test was skipped + if {$testResult != {}} { + set coreFailure 0 + set coreMsg "" + # check for a core file first - if one was created by the test, then + # the test failed + if {$tcltest::preserveCore} { + set currentTclPlatform [array get tcl_platform] + if {[file exists [file join [tcltest::workingDirectory] core]]} { + # There's only a test failure if there is a core file and (1) + # there previously wasn't one or (2) the new one is different + # from the old one. + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [tcltest::workingDirectory] core]]} { + set coreFailure 1 + } + } else { + set coreFailure 1 + } + + if {($tcltest::preserveCore > 1) && ($coreFailure)} { + append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]" + catch {file rename -force \ + [file join [tcltest::workingDirectory] core] \ + [file join $tcltest::temporaryDirectory \ + core-$name]} msg + if {[string length $msg] > 0} { + append coreMsg "\nError: Problem renaming core file: $msg" + } + } } + array set tcl_platform $currentTclPlatform } - if {[llength $newEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements changed:\t$changedEnv" + + set actualAnswer [lindex $testResult 0] + set code [lindex $testResult end] + + # If expected output/error strings exist, we have to compare + # them. If the comparison fails, then so did the test. + set outputFailure 0 + set errorFailure 0 + if {[info exists output]} { + set outputFailure [expr ![compareStrings $tcltest::outData \ + $output $match]] + } + if {[info exists errorOutput]} { + set errorFailure [expr ![compareStrings $tcltest::errData \ + $errorOutput $match]] } - if {[llength $removedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements removed:\t$removedEnv" + + set testFailed 1 + set codeFailure 0 + set scriptFailure 0 + + # check if the return code matched the expected return code + if {[lsearch -exact $returnCodes $code] == -1} { + set codeFailure 1 + } + + # check if the answer matched the expected answer + if {[compareStrings $actualAnswer $result $match] == 0} { + set scriptFailure 1 } - set changedTclPlatform {} - foreach index [array names ::tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $::tcltest::originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $::tcltest::originalTclPlatform($index) + # if we didn't experience any failures, then we passed + if {!($setupFailure || $cleanupFailure || $coreFailure || \ + $outputFailure || $errorFailure || $codeFailure || \ + $scriptFailure)} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Passed) + if {[tcltest::isVerbose pass]} { + puts [outputChannel] "++++ $name PASSED" + } } + set testFailed 0 } - if {[llength $changedTclPlatform] > 0} { - puts $::tcltest::outputChannel \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "produced core file! \ - Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" - flush $::tcltest::outputChannel - catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" + if {$testFailed} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Failed) + } + set tcltest::currentFailure true + if {![tcltest::isVerbose body]} { + set body "" + } + puts [outputChannel] "\n==== $name [string trim $description] FAILED" + if {$body != ""} { + puts [outputChannel] "==== Contents of test case:" + puts [outputChannel] $body + } + if {$setupFailure} { + puts [outputChannel] "---- Test setup failed:\n$setupMsg" + } + if {$scriptFailure} { + puts [outputChannel] "---- Result was:\n$actualAnswer" + puts [outputChannel] "---- Result should have been ($match matching):\n$result" + } + if {$codeFailure} { + switch -- $code { + 0 { set msg "Test completed normally" } + 1 { set msg "Test generated error" } + 2 { set msg "Test generated return exception" } + 3 { set msg "Test generated break exception" } + 4 { set msg "Test generated continue exception" } + default { set msg "Test generated exception" } } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists ::tcltest::coreModificationTime]} { - if {$::tcltest::coreModificationTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "A core file was created!" + puts [outputChannel] "---- $msg; Return code was: $code" + puts [outputChannel] "---- Return code should have been one of: $returnCodes" + if {[tcltest::isVerbose error]} { + if {[info exists ::errorInfo]} { + puts [outputChannel] "---- errorInfo: $::errorInfo" + puts [outputChannel] "---- errorCode: $::errorCode" } - } else { - puts $::tcltest::outputChannel "A core file was created!" - } + } + } + if {$outputFailure} { + puts [outputChannel] "---- Output was:\n$tcltest::outData" + puts [outputChannel] "---- Output should have been ($match matching):\n$output" + } + if {$errorFailure} { + puts [outputChannel] "---- Error output was:\n$tcltest::errData" + puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput" + } + if {$cleanupFailure} { + puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" } + if {$coreFailure} { + puts [outputChannel] "---- Core file produced while running test! $coreMsg" + } + puts [outputChannel] "==== $name FAILED\n" + } } + + incr tcltest::testLevel -1 + return 0 } -# ::tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { - proc ::tcltest::cleanupTestsHook {} {} -} -# test -- +# runTest -- # +# This is the defnition of the version 1.0 test routine for tcltest. It is +# provided here for backward compatibility. It is also used as the 'backbone' +# of the test procedure, as in, this is where all the work really gets done. +# # This procedure runs a test and prints an error message if the test fails. -# If ::tcltest::verbose has been set, it also prints a message even if the +# If tcltest::verbose has been set, it also prints a message even if the # test succeeds. The test will be skipped if it doesn't match the -# ::tcltest::match variable, if it matches an element in -# ::tcltest::skip, or if one of the elements of "constraints" turns +# tcltest::match variable, if it matches an element in +# tcltest::skip, or if one of the elements of "constraints" turns # out not to be true. # # Arguments: @@ -1364,81 +2429,93 @@ if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { # help humans understand what it does. # constraints - A list of one or more keywords, each of # which must be the name of an element in -# the array "::tcltest::testConstraints". If any of these +# the array "tcltest::testConstraints". If any of these # elements is zero, the test is skipped. # This argument may be omitted. # script - Script to run to carry out the test. It must # return a result that can be checked for # correctness. # expectedAnswer - Expected result from script. +# +# Behavior depends on the value of testLevel; if testLevel is 1 (top level), +# then events are logged and we track the number of tests run/skipped and why. +# Otherwise, we don't track this information. +# +# Results: +# empty list if test is skipped; otherwise returns list containing +# actual returned value from the test and the return code. +# +# Side Effects: +# none. +# -proc ::tcltest::test {name description script expectedAnswer args} { - - DebugPuts 3 "Running $name ($description)" - - incr ::tcltest::numTests(Total) +proc tcltest::runTest {name description script expectedAnswer constraints} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Total) + } + # skip the test if it's name matches an element of skip - - foreach pattern $::tcltest::skip { + foreach pattern $tcltest::skip { if {[string match $pattern $name]} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip} + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip} + } return } } # skip the test if it's name doesn't match any element of match - - if {[llength $::tcltest::match] > 0} { + if {[llength $tcltest::match] > 0} { set ok 0 - foreach pattern $::tcltest::match { + foreach pattern $tcltest::match { if {[string match $pattern $name]} { set ok 1 break } } if {!$ok} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch} + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch} + } return } } - set i [llength $args] - if {$i == 0} { - set constraints {} + DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints" + + if {$constraints == {}} { # If we're limited to the listed constraints and there aren't any # listed, then we shouldn't run the test. - if {$::tcltest::limitConstraints} { - ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint - incr ::tcltest::numTests(Skipped) + if {$tcltest::limitConstraints} { + tcltest::AddToSkippedBecause userSpecifiedLimitConstraint + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + } return } - } elseif {$i == 1} { - - # "constraints" argument exists; shuffle arguments down, then + } else { + # "constraints" argument exists; # make sure that the constraints are satisfied. - set constraints $script - set script $expectedAnswer - set expectedAnswer [lindex $args 0] set doTest 0 if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 expr $constraints]} } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { # something like {a || b} should be turned into - # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$::tcltest::testConstraints(&)} c + # $tcltest::testConstraints(a) || $tcltest::testConstraints(b). + regsub -all {[.\w]+} $constraints \ + {$tcltest::testConstraints(&)} c catch {set doTest [eval expr $c]} } else { # just simple constraints such as {unixOnly fonts}. set doTest 1 foreach constraint $constraints { - if {(![info exists ::tcltest::testConstraints($constraint)]) \ - || (!$::tcltest::testConstraints($constraint))} { + if {(![info exists tcltest::testConstraints($constraint)]) \ + || (!$tcltest::testConstraints($constraint))} { set doTest 0 # store the constraint that kept the test from running @@ -1447,28 +2524,30 @@ proc ::tcltest::test {name description script expectedAnswer args} { } } } + if {$doTest == 0} { - if {[string first s $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints" + if {[tcltest::isVerbose skip]} { + puts [outputChannel] "++++ $name SKIPPED: $constraints" + } + + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + tcltest::AddToSkippedBecause $constraints } - - incr ::tcltest::numTests(Skipped) - ::tcltest::AddToSkippedBecause $constraints return } - } else { - error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" - } + } # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with tcl_platform. + # tcl_platform environment because some of the tests mess with + # tcl_platform. - if {$::tcltest::preserveCore} { + if {$tcltest::preserveCore} { set currentTclPlatform [array get tcl_platform] - array set tcl_platform $::tcltest::originalTclPlatform - if {[file exists [file join $::tcltest::workingDirectory core]]} { + array set tcl_platform $tcltest::originalTclPlatform + if {[file exists [file join [tcltest::workingDirectory] core]]} { set coreModTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + [tcltest::workingDirectory] core]] } array set tcl_platform $currentTclPlatform } @@ -1480,107 +2559,288 @@ proc ::tcltest::test {name description script expectedAnswer args} { memory tag $name } + if {[tcltest::isVerbose start]} { + puts [outputChannel] "---- $name start" + flush [outputChannel] + } + set code [catch {uplevel $script} actualAnswer] - if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} { - incr ::tcltest::numTests(Passed) - if {[string first p $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name PASSED" + + return [list $actualAnswer $code] +} + +##################################################################### + +# tcltest::cleanupTestsHook -- +# +# This hook allows a harness that builds upon tcltest to specify +# additional things that should be done at cleanup. +# + +if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} { + proc tcltest::cleanupTestsHook {} {} +} + +# tcltest::cleanupTests -- +# +# Remove files and dirs created using the makeFile and makeDirectory +# commands since the last time this proc was invoked. +# +# Print the names of the files created without the makeFile command +# since the tests were invoked. +# +# Print the number tests (total, passed, failed, and skipped) since the +# tests were invoked. +# +# Restore original environment (as reported by special variable env). +# +# Arguments: +# calledFromAllFile - if 0, behave as if we are running a single test file +# within an entire suite of tests. if we aren't running a single test +# file, then don't report status. check for new files created during the +# test run and report on them. if 1, report collated status from all the +# test file runs. +# +# Results: +# None. +# +# Side Effects: +# None +# + +proc tcltest::cleanupTests {{calledFromAllFile 0}} { + + set testFileName [file tail [info script]] + + # Call the cleanup hook + tcltest::cleanupTestsHook + + # Remove files and directories created by the :tcltest::makeFile and + # tcltest::makeDirectory procedures. + # Record the names of files in tcltest::workingDirectory that were not + # pre-existing, and associate them with the test file that created them. + + if {!$calledFromAllFile} { + foreach file $tcltest::filesMade { + if {[file exists $file]} { + catch {file delete -force $file} + } + } + set currentFiles {} + foreach file [glob -nocomplain \ + [file join $tcltest::temporaryDirectory *]] { + lappend currentFiles [file tail $file] + } + set newFiles {} + foreach file $currentFiles { + if {[lsearch -exact $tcltest::filesExisted $file] == -1} { + lappend newFiles $file + } + } + set tcltest::filesExisted $currentFiles + if {[llength $newFiles] > 0} { + set tcltest::createdNewFiles($testFileName) $newFiles + } + } + + if {$calledFromAllFile || $tcltest::testSingleFile} { + + # print stats + + puts -nonewline [outputChannel] "$testFileName:" + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + puts -nonewline [outputChannel] \ + "\t$index\t$tcltest::numTests($index)" + } + puts [outputChannel] "" + + # print number test files sourced + # print names of files that ran tests which failed + + if {$calledFromAllFile} { + puts [outputChannel] \ + "Sourced $tcltest::numTestFiles Test Files." + set tcltest::numTestFiles 0 + if {[llength $tcltest::failFiles] > 0} { + puts [outputChannel] \ + "Files with failing tests: $tcltest::failFiles" + set tcltest::failFiles {} + } + } + + # if any tests were skipped, print the constraints that kept them + # from running. + + set constraintList [array names tcltest::skippedBecause] + if {[llength $constraintList] > 0} { + puts [outputChannel] \ + "Number of tests skipped for each constraint:" + foreach constraint [lsort $constraintList] { + puts [outputChannel] \ + "\t$tcltest::skippedBecause($constraint)\t$constraint" + unset tcltest::skippedBecause($constraint) + } + } + + # report the names of test files in tcltest::createdNewFiles, and + # reset the array to be empty. + + set testFilesThatTurded [lsort [array names tcltest::createdNewFiles]] + if {[llength $testFilesThatTurded] > 0} { + puts [outputChannel] "Warning: files left behind:" + foreach testFile $testFilesThatTurded { + puts [outputChannel] \ + "\t$testFile:\t$tcltest::createdNewFiles($testFile)" + unset tcltest::createdNewFiles($testFile) + } + } + + # reset filesMade, filesExisted, and numTests + + set tcltest::filesMade {} + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + set tcltest::numTests($index) 0 + } + + # exit only if running Tk in non-interactive mode + + global tk_version tcl_interactive + if {[info exists tk_version] && ![info exists tcl_interactive]} { + exit } } else { - incr ::tcltest::numTests(Failed) - set ::tcltest::currentFailure true - if {[string first b $::tcltest::verbose] == -1} { - set script "" - } - puts $::tcltest::outputChannel "\n==== $name $description FAILED" - if {$script != ""} { - puts $::tcltest::outputChannel "==== Contents of test case:" - puts $::tcltest::outputChannel $script - } - if {$code != 0} { - if {$code == 1} { - puts $::tcltest::outputChannel "==== Test generated error:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 2} { - puts $::tcltest::outputChannel "==== Test generated return exception; result was:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 3} { - puts $::tcltest::outputChannel "==== Test generated break exception" - } elseif {$code == 4} { - puts $::tcltest::outputChannel "==== Test generated continue exception" + + # if we're deferring stat-reporting until all files are sourced, + # then add current file to failFile list if any tests in this file + # failed + + incr tcltest::numTestFiles + if {($tcltest::currentFailure) && \ + ([lsearch -exact $tcltest::failFiles $testFileName] == -1)} { + lappend tcltest::failFiles $testFileName + } + set tcltest::currentFailure false + + # restore the environment to the state it was in before this package + # was loaded + + set newEnv {} + set changedEnv {} + set removedEnv {} + foreach index [array names ::env] { + if {![info exists tcltest::originalEnv($index)]} { + lappend newEnv $index + unset ::env($index) } else { - puts $::tcltest::outputChannel "==== Test generated exception $code; message was:" - puts $::tcltest::outputChannel $actualAnswer + if {$::env($index) != $tcltest::originalEnv($index)} { + lappend changedEnv $index + set ::env($index) $tcltest::originalEnv($index) + } } - } else { - puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer" } - puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer" - puts $::tcltest::outputChannel "==== $name FAILED\n" - } - if {$::tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "==== $name produced core file! \ + foreach index [array names tcltest::originalEnv] { + if {![info exists ::env($index)]} { + lappend removedEnv $index + set ::env($index) $tcltest::originalEnv($index) + } + } + if {[llength $newEnv] > 0} { + puts [outputChannel] \ + "env array elements created:\t$newEnv" + } + if {[llength $changedEnv] > 0} { + puts [outputChannel] \ + "env array elements changed:\t$changedEnv" + } + if {[llength $removedEnv] > 0} { + puts [outputChannel] \ + "env array elements removed:\t$removedEnv" + } + + set changedTclPlatform {} + foreach index [array names tcltest::originalTclPlatform] { + if {$::tcl_platform($index) != \ + $tcltest::originalTclPlatform($index)} { + lappend changedTclPlatform $index + set ::tcl_platform($index) \ + $tcltest::originalTclPlatform($index) + } + } + if {[llength $changedTclPlatform] > 0} { + puts [outputChannel] \ + "tcl_platform array elements changed:\t$changedTclPlatform" + } + + if {[file exists [file join [tcltest::workingDirectory] core]]} { + if {$tcltest::preserveCore > 1} { + puts "rename core file (> 1)" + puts [outputChannel] "produced core file! \ Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" + [file join $tcltest::temporaryDirectory core-$name]" catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg + [file join [tcltest::workingDirectory] core] \ + [file join $tcltest::temporaryDirectory \ + core-$name]} msg if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" + tcltest::PrintError "Problem renaming file: $msg" } } else { # Print a message if there is a core file and (1) there # previously wasn't one or (2) the new one is different from # the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "==== $name produced core file!" + if {[info exists tcltest::coreModificationTime]} { + if {$tcltest::coreModificationTime != [file mtime \ + [file join [tcltest::workingDirectory] core]]} { + puts [outputChannel] "A core file was created!" } } else { - puts $::tcltest::outputChannel "==== $name produced core file!" + puts [outputChannel] "A core file was created!" } } } - array set tcl_platform $currentTclPlatform } + flush [outputChannel] + flush [errorChannel] + return } -# ::tcltest::getMatchingFiles +##################################################################### + +# Procs that determine which tests/test files to run + +# tcltest::getMatchingFiles # # Looks at the patterns given to match and skip files # and uses them to put together a list of the tests that will be run. # # Arguments: -# none +# directory to search # # Results: # The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. +# be used in 'all.tcl' files. It is used in runAllTests. +# +# Side Effects: +# None -proc ::tcltest::getMatchingFiles {args} { - set matchingFiles {} - if {[llength $args]} { - set searchDirectory $args - } else { - set searchDirectory [list $::tcltest::testsDirectory] +proc tcltest::getMatchingFiles { {searchDirectory ""} } { + if {[llength [info level 0]] == 1} { + set searchDirectory [tcltest::testsDirectory] } + set matchingFiles {} + # Find the matching files in the list of directories and then remove the # ones that match the skip pattern foreach directory $searchDirectory { set matchFileList {} - foreach match $::tcltest::matchFiles { + foreach match $tcltest::matchFiles { set matchFileList [concat $matchFileList \ [glob -nocomplain [file join $directory $match]]] } - if {[string compare {} $::tcltest::skipFiles]} { + if {[string compare {} $tcltest::skipFiles]} { set skipFileList {} - foreach skip $::tcltest::skipFiles { + foreach skip $tcltest::skipFiles { set skipFileList [concat $skipFileList \ [glob -nocomplain [file join $directory $skip]]] } @@ -1597,35 +2857,213 @@ proc ::tcltest::getMatchingFiles {args} { } } if {[string equal $matchingFiles {}]} { - ::tcltest::PrintError "No test files remain after applying \ + tcltest::PrintError "No test files remain after applying \ your match and skip patterns!" } return $matchingFiles } -# The following two procs are used in the io tests. - -proc ::tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} +# tcltest::getMatchingDirectories -- +# +# Looks at the patterns given to match and skip directories and uses them +# to put together a list of the test directories that we should attempt +# to run. (Only subdirectories containing an "all.tcl" file are put into +# the list.) +# +# Arguments: +# root directory from which to search +# +# Results: +# The constructed list is returned to the user. This is used in the +# primary all.tcl file. Lower-level all.tcl files should use the +# tcltest::testAllFiles proc instead. +# +# Side Effects: +# None. + +proc tcltest::getMatchingDirectories {rootdir} { + set matchingDirs {} + set matchDirList {} + # Find the matching directories in tcltest::testsDirectory and then + # remove the ones that match the skip pattern + foreach match $tcltest::matchDirectories { + foreach file [glob -nocomplain [file join $rootdir $match]] { + if {([file isdirectory $file]) && ($file != $rootdir)} { + set matchDirList [concat $matchDirList \ + [tcltest::getMatchingDirectories $file]] + if {[file exists [file join $file all.tcl]]} { + set matchDirList [concat $matchDirList $file] + } + } + } } - return $result + if {$tcltest::skipDirectories != {}} { + set skipDirs {} + foreach skip $tcltest::skipDirectories { + set skipDirs [concat $skipDirs \ + [glob -nocomplain [file join $tcltest::testsDirectory \ + $skip]]] + } + foreach dir $matchDirList { + # Only include directories that don't match the skip pattern + if {[lsearch -exact $skipDirs $dir] == -1} { + lappend matchingDirs $dir + } + } + } else { + set matchingDirs [concat $matchingDirs $matchDirList] + } + if {$matchingDirs == {}} { + DebugPuts 1 "No test directories remain after applying match and skip patterns!" + } + return $matchingDirs } -proc ::tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} +# tcltest::runAllTests -- +# +# prints output and sources test files according to the match and skip +# patterns provided. after sourcing test files, it goes on to source +# all.tcl files in matching test subdirectories. +# +# Arguments: +# shell being tested +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::runAllTests { {shell ""} } { + global argv + + if {[llength [info level 0]] == 1} { + set shell [tcltest::interpreter] } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p + + set tcltest::testSingleFile false + + puts [outputChannel] "Tests running in interp: $shell" + puts [outputChannel] "Tests located in: $tcltest::testsDirectory" + puts [outputChannel] "Tests running in: [tcltest::workingDirectory]" + puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory" + if {[tcltest::singleProcess]} { + puts [outputChannel] "Test files sourced into current interpreter" + } else { + puts [outputChannel] "Test files run in separate interpreters" + } + if {[llength $tcltest::skip] > 0} { + puts [outputChannel] "Skipping tests that match: $tcltest::skip" + } + if {[llength $tcltest::match] > 0} { + puts [outputChannel] "Only running tests that match: $tcltest::match" + } + + if {[llength $tcltest::skipFiles] > 0} { + puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles" + } + if {[llength $tcltest::matchFiles] > 0} { + puts [outputChannel] "Only running test files that match: $tcltest::matchFiles" + } + + set timeCmd {clock format [clock seconds]} + puts [outputChannel] "Tests began at [eval $timeCmd]" + + # Run each of the specified tests + foreach file [lsort [tcltest::getMatchingFiles]] { + set tail [file tail $file] + puts [outputChannel] $tail + + if {$tcltest::singleProcess} { + incr tcltest::numTestFiles + uplevel [list source $file] + } else { + # Change to the tests directory so the value of the following + # variable is set correctly when we spawn the child test processes + cd $tcltest::testsDirectory + set cmd [concat [list | $shell $file] [split $argv]] + if {[catch { + incr tcltest::numTestFiles + set pipeFd [open $cmd "r"] + while {[gets $pipeFd line] >= 0} { + if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + incr tcltest::numTests($index) [set $index] + } + if {$Failed > 0} { + lappend tcltest::failFiles $testFile + } + } elseif {[regexp {^Number of tests skipped for each constraint:|^\t(\d+)\t(.+)$} $line match skipped constraint]} { + if {$match != "Number of tests skipped for each constraint:"} { + tcltest::AddToSkippedBecause $constraint $skipped + } + } else { + puts [outputChannel] $line + } + } + close $pipeFd + } msg]} { + # Print results to tcltest::outputChannel. + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported later + lappend testFileFailures $file + } } } - return $leak + + # cleanup + puts [outputChannel] "\nTests ended at [eval $timeCmd]" + tcltest::cleanupTests 1 + if {[info exists testFileFailures]} { + puts [outputChannel] "\nTest files exiting with errors: \n" + foreach file $testFileFailures { + puts " [file tail $file]\n" + } + } + + # Checking for subdirectories in which to run tests + foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] { + set dir [file tail $directory] + puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + puts [outputChannel] "$dir test began at [eval $timeCmd]\n" + + uplevel "source [file join $directory all.tcl]" + + set endTime [eval $timeCmd] + puts [outputChannel] "\n$dir test ended at $endTime" + puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + } + return +} + +##################################################################### + +# Test utility procs - not used in tcltest, but may be useful for testing. + +# tcltest::loadTestedCommands -- +# +# Uses the specified script to load the commands to test. Allowed to +# be empty, as the tested commands could have been compiled into the +# interpreter. +# +# Arguments +# none +# +# Results +# none +# +# Side Effects: +# none. + +proc tcltest::loadTestedCommands {} { + if {$tcltest::loadScript == {}} { + return + } + + return [uplevel $tcltest::loadScript] } -# ::tcltest::saveState -- +# tcltest::saveState -- # # Save information regarding what procs and variables exist. # @@ -1633,58 +3071,71 @@ proc ::tcltest::leakfiles {old} { # none # # Results: -# Modifies the variable ::tcltest::saveState +# Modifies the variable tcltest::saveState +# +# Side effects: +# None. -proc ::tcltest::saveState {} { - uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState" +proc tcltest::saveState {} { + uplevel {set tcltest::saveState [list [info procs] [info vars]]} + DebugPuts 2 "tcltest::saveState: $tcltest::saveState" + return } -# ::tcltest::restoreState -- +# tcltest::restoreState -- # # Remove procs and variables that didn't exist before the call to -# ::tcltest::saveState. +# tcltest::saveState. # # Arguments: # none # # Results: # Removes procs and variables from your environment if they don't exist -# in the ::tcltest::saveState variable. +# in the tcltest::saveState variable. +# +# Side effects: +# None. -proc ::tcltest::restoreState {} { +proc tcltest::restoreState {} { foreach p [info procs] { - if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \ - (![string equal ::tcltest::$p [namespace origin $p]])} { + if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \ + (![string match "*tcltest::$p" [namespace origin $p]])} { - DebugPuts 2 "::tcltest::restoreState: Removing proc $p" + DebugPuts 2 "tcltest::restoreState: Removing proc $p" rename $p {} } } - foreach p [uplevel #0 {info vars}] { - if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { - DebugPuts 2 "::tcltest::restoreState: Removing variable $p" - uplevel #0 "catch {unset $p}" + foreach p [uplevel {info vars}] { + if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} { + DebugPuts 2 "tcltest::restoreState: Removing variable $p" + uplevel "catch {unset $p}" } } + return } -# ::tcltest::normalizeMsg -- +# tcltest::normalizeMsg -- # # Removes "extra" newlines from a string. # # Arguments: # msg String to be modified # +# Results: +# string with extra newlines removed +# +# Side effects: +# None. -proc ::tcltest::normalizeMsg {msg} { +proc tcltest::normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg regsub -all "\n\n" $msg "\n" msg regsub -all "\n\}" $msg "\}" msg return $msg } -# makeFile -- +# tcltest::makeFile -- # # Create a new file with the name <name>, and write <contents> to it. # @@ -1692,12 +3143,28 @@ proc ::tcltest::normalizeMsg {msg} { # cleanupTests was called, add it to the $filesMade list, so it will # be removed by the next call to cleanupTests. # -proc ::tcltest::makeFile {contents name} { +# Arguments: +# contents content of the new file +# name name of the new file +# directory directory name for new file +# +# Results: +# absolute path to the file created +# +# Side effects: +# None. + +proc tcltest::makeFile {contents name {directory ""}} { global tcl_platform + + if {[llength [info level 0]] == 3} { + set directory [tcltest::temporaryDirectory] + } - DebugPuts 3 "::tcltest::makeFile: putting $contents into $name" + set fullName [file join $directory $name] + + DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" - set fullName [file join $::tcltest::temporaryDirectory $name] set fd [open $fullName w] fconfigure $fd -translation lf @@ -1709,26 +3176,36 @@ proc ::tcltest::makeFile {contents name} { } close $fd - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName + if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { + lappend tcltest::filesMade $fullName } return $fullName } -# ::tcltest::removeFile -- +# tcltest::removeFile -- # # Removes the named file from the filesystem # # Arguments: -# name file to be removed +# name file to be removed +# directory directory from which to remove file # +# Results: +# return value from [file delete] +# +# Side effects: +# None. -proc ::tcltest::removeFile {name} { - DebugPuts 3 "::tcltest::removeFile: removing $name" - file delete [file join $::tcltest::temporaryDirectory $name] +proc tcltest::removeFile {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeFile: removing $fullName" + return [file delete $fullName] } -# makeDirectory -- +# tcltest::makeDirectory -- # # Create a new dir with the name <name>. # @@ -1736,75 +3213,85 @@ proc ::tcltest::removeFile {name} { # cleanupTests was called, add it to the $directoriesMade list, so it will # be removed by the next call to cleanupTests. # -proc ::tcltest::makeDirectory {name} { - file mkdir $name +# Arguments: +# name name of the new directory +# directory directory in which to create new dir +# +# Results: +# absolute path to the directory created +# +# Side effects: +# None. - set fullName [file join [pwd] $name] - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName +proc tcltest::makeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::makeDirectory: creating $fullName" + file mkdir $fullName + if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { + lappend tcltest::filesMade $fullName + } + return $fullName } -# ::tcltest::removeDirectory -- +# tcltest::removeDirectory -- # # Removes a named directory from the file system. # # Arguments: -# name Name of the directory to remove +# name Name of the directory to remove +# directory Directory from which to remove # +# Results: +# return value from [file delete] +# +# Side effects: +# None -proc ::tcltest::removeDirectory {name} { - file delete -force $name -} - -proc ::tcltest::viewFile {name} { - global tcl_platform - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ($::tcltest::testConstraints(unixExecs) == 0)} { - set f [open [file join $::tcltest::temporaryDirectory $name]] - set data [read -nonewline $f] - close $f - return $data - } else { - exec cat [file join $::tcltest::temporaryDirectory $name] +proc tcltest::removeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" + return [file delete -force $fullName] } -# grep -- +# tcltest::viewFile -- # -# Evaluate a given expression against each element of a list and return all -# elements for which the expression evaluates to true. For the purposes of -# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the -# value of the current element within the expression. This is equivalent to -# the perl grep command where CURRENT_ELEMENT would be the name for the special -# variable $_. +# reads the content of a file and returns it # -# Examples of usage would be: -# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] -# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] +# Arguments: +# name of the file to read +# directory in which file is located # -# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is -# assumed to be the final argument to the expression provided. -# -# Example: -# grep {regexp a} $someList +# Results: +# content of the named file # -proc ::tcltest::grep { expression searchList } { - foreach element $searchList { - if {[regsub -all CURRENT_ELEMENT $expression $element \ - newExpression] == 0} { - set newExpression "$expression {$element}" - } - if {[eval $newExpression] == 1} { - lappend returnList $element - } +# Side effects: +# None. + +proc tcltest::viewFile {name {directory ""}} { + global tcl_platform + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } - if {[info exists returnList]} { - return $returnList + set fullName [file join $directory $name] + if {([string equal $tcl_platform(platform) "macintosh"]) || \ + ([tcltest::testConstraint unixExecs] == 0)} { + set f [open $fullName] + set data [read -nonewline $f] + close $f + return $data + } else { + return [exec cat $fullName] } return } +# tcltest::bytestring -- # # Construct a string that consists of the requested sequence of bytes, # as opposed to a string of properly formed UTF-8 characters. @@ -1818,30 +3305,112 @@ proc ::tcltest::grep { expression searchList } { # Generally, it's a bad idea to examine the bytes in a Tcl string or to # construct improperly formed strings in this manner, because it involves # exposing that Tcl uses UTF-8 internally. +# +# Arguments: +# string being converted +# +# Results: +# result fom encoding +# +# Side effects: +# None + +proc tcltest::bytestring {string} { + return [encoding convertfrom identity $string] +} + +# tcltest::openfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. -proc ::tcltest::bytestring {string} { - encoding convertfrom identity $string +proc tcltest::openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +# tcltest::leakfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak } # # Internationalization / ISO support procs -- dl # -proc ::tcltest::set_iso8859_1_locale {} { + +# tcltest::set_iso8859_1_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::set_iso8859_1_locale {} { if {[info commands testlocale] != ""} { - set ::tcltest::previousLocale [testlocale ctype] - testlocale ctype $::tcltest::isoLocale + set tcltest::previousLocale [testlocale ctype] + testlocale ctype $tcltest::isoLocale } return } -proc ::tcltest::restore_locale {} { +# tcltest::restore_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::restore_locale {} { if {[info commands testlocale] != ""} { - testlocale ctype $::tcltest::previousLocale + testlocale ctype $tcltest::previousLocale } return } -# threadReap -- +# tcltest::threadReap -- # # Kill all threads except for the main thread. # Do nothing if testthread is not defined. @@ -1851,7 +3420,12 @@ proc ::tcltest::restore_locale {} { # # Results: # Returns the number of existing threads. -proc ::tcltest::threadReap {} { +# +# Side Effects: +# none. +# + +proc tcltest::threadReap {} { if {[info commands testthread] != {}} { # testthread built into tcltest @@ -1859,7 +3433,7 @@ proc ::tcltest::threadReap {} { testthread errorproc ThreadNullError while {[llength [testthread names]] > 1} { foreach tid [testthread names] { - if {$tid != $::tcltest::mainThread} { + if {$tid != $tcltest::mainThread} { catch {testthread send -async $tid {testthread exit}} } } @@ -1877,7 +3451,7 @@ proc ::tcltest::threadReap {} { thread::errorproc ThreadNullError while {[llength [thread::names]] > 1} { foreach tid [thread::names] { - if {$tid != $::tcltest::mainThread} { + if {$tid != $tcltest::mainThread} { catch {thread::send -async $tid {thread::exit}} } } @@ -1891,6 +3465,7 @@ proc ::tcltest::threadReap {} { } else { return 1 } + return 0 } # Initialize the constraints and set up command line arguments @@ -1898,8 +3473,18 @@ namespace eval tcltest { # Ensure that we have a minimal auto_path so we don't pick up extra junk. set ::auto_path [list [info library]] - ::tcltest::initConstraints - if {[namespace children ::tcltest] == {}} { - ::tcltest::processCmdLineArgs + tcltest::initConstraints + if {[namespace children [namespace current]] == {}} { + tcltest::processCmdLineArgs + } + + # Save the names of files that already exist in + # the output directory. + foreach file [glob -nocomplain \ + [file join $tcltest::temporaryDirectory *]] { + lappend tcltest::filesExisted [file tail $file] } } + +package provide tcltest 2.0 + diff --git a/library/tcltest/tcltest2.tcl b/library/tcltest/tcltest2.tcl deleted file mode 100755 index c05732d..0000000 --- a/library/tcltest/tcltest2.tcl +++ /dev/null @@ -1,3490 +0,0 @@ -# tcltest.tcl -- -# -# This file contains support code for the Tcl test suite. It -# defines the tcltest namespace and finds and defines the output -# directory, constraints available, output and error channels, etc. used -# by Tcl tests. See the tcltest man page for more details. -# -# This design was based on the Tcl testing approach designed and -# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. -# -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions -# All rights reserved. -# -# RCS: @(#) $Id: tcltest2.tcl,v 1.4 2000/10/19 18:00:58 jenn Exp $ - -# create the "tcltest" namespace for all testing variables and procedures - -namespace eval tcltest { - - # Export the public tcltest procs - set procList [list test cleanupTests saveState restoreState \ - normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring threadReap debug testConstraint \ - limitConstraints loadTestedCommands normalizePath verbose match \ - skip matchFiles skipFiles preserveCore loadScript loadFile \ - mainThread workingDirectory singleProcess interpreter runAllTests \ - outputChannel outputFile errorChannel \ - errorFile temporaryDirectory testsDirectory matchDirectories \ - skipDirectories ] - foreach proc $procList { - namespace export $proc - } - - # tcltest::verbose defaults to {body} - if {![info exists verbose]} { - variable verbose {body} - } - - # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory and - # matchDirectories, which defaults to all directories. - - if {![info exists match]} { - variable match {} - } - if {![info exists skip]} { - variable skip {} - } - if {![info exists matchFiles]} { - variable matchFiles {*.test} - } - if {![info exists skipFiles]} { - variable skipFiles {} - } - if {![info exists matchDirectories]} { - variable matchDirectories {*} - } - if {![info exists skipDirectories]} { - variable skipDirectories {} - } - - # By default, don't save core files - if {![info exists preserveCore]} { - variable preserveCore 0 - } - - # output goes to stdout by default - if {![info exists outputChannel]} { - variable outputChannel stdout - } - if {![info exists outputFile]} { - variable outputFile stdout - } - - # errors go to stderr by default - if {![info exists errorChannel]} { - variable errorChannel stderr - } - if {![info exists errorFile]} { - variable errorFile stderr - } - - # debug output doesn't get printed by default; debug level 1 spits - # up only the tests that were skipped because they didn't match or were - # specifically skipped. A debug level of 2 would spit up the tcltest - # variables and flags provided; a debug level of 3 causes some additional - # output regarding operations of the test harness. The tcltest package - # currently implements only up to debug level 3. - if {![info exists debug]} { - variable debug 0 - } - - # Save any arguments that we might want to pass through to other programs. - # This is used by the -args flag. - if {![info exists parameters]} { - variable parameters {} - } - - # Count the number of files tested (0 if runAllTests wasn't called). - # runAllTests will set testSingleFile to false, so stats will - # not be printed until runAllTests calls the cleanupTests proc. - # The currentFailure var stores the boolean value of whether the - # current test file has had any failures. The failFiles list - # stores the names of test files that had failures. - - if {![info exists numTestFiles]} { - variable numTestFiles 0 - } - if {![info exists testSingleFile]} { - variable testSingleFile true - } - if {![info exists currentFailure]} { - variable currentFailure false - } - if {![info exists failFiles]} { - variable failFiles {} - } - - # Tests should remove all files they create. The test suite will - # check the current working dir for files created by the tests. - # tcltest::filesMade keeps track of such files created using the - # tcltest::makeFile and tcltest::makeDirectory procedures. - # tcltest::filesExisted stores the names of pre-existing files. - - if {![info exists filesMade]} { - variable filesMade {} - } - if {![info exists filesExisted]} { - variable filesExisted {} - } - - # tcltest::numTests will store test files as indices and the list - # of files (that should not have been) left behind by the test files. - - if {![info exists createdNewFiles]} { - variable createdNewFiles - array set tcltest::createdNewFiles {} - } - - # initialize tcltest::numTests array to keep track fo the number of - # tests that pass, fail, and are skipped. - - if {![info exists numTests]} { - variable numTests - array set tcltest::numTests \ - [list Total 0 Passed 0 Skipped 0 Failed 0] - } - - # initialize tcltest::skippedBecause array to keep track of - # constraints that kept tests from running; a constraint name of - # "userSpecifiedSkip" means that the test appeared on the list of tests - # that matched the -skip value given to the flag; "userSpecifiedNonMatch" - # means that the test didn't match the argument given to the -match flag; - # both of these constraints are counted only if tcltest::debug is set to - # true. - - if {![info exists skippedBecause]} { - variable skippedBecause - array set tcltest::skippedBecause {} - } - - # initialize the tcltest::testConstraints array to keep track of valid - # predefined constraints (see the explanation for the - # tcltest::initConstraints proc for more details). - - if {![info exists testConstraints]} { - variable testConstraints - array set tcltest::testConstraints {} - } - - if {![info exists constraintsSpecified]} { - variable constraintsSpecified {} - } - - # Don't run only the constrained tests by default - - if {![info exists limitConstraints]} { - variable limitConstraints false - } - - # A test application has to know how to load the tested commands into - # the interpreter. - - if {![info exists loadScript]} { - variable loadScript {} - } - - # and the filename of the script file, if it exists - if {![info exists loadFile]} { - variable loadFile {} - } - - # tests that use threads need to know which is the main thread - - if {![info exists mainThread]} { - variable mainThread 1 - if {[info commands thread::id] != {}} { - set mainThread [thread::id] - } elseif {[info commands testthread] != {}} { - set mainThread [testthread id] - } - } - - # save the original environment so that it can be restored later - - if {![info exists originalEnv]} { - variable originalEnv - array set tcltest::originalEnv [array get ::env] - } - - # Set tcltest::workingDirectory to [pwd]. The default output directory - # for Tcl tests is the working directory. - - if {![info exists workingDirectory]} { - variable workingDirectory [pwd] - } - if {![info exists temporaryDirectory]} { - variable temporaryDirectory $workingDirectory - } - - # Tests should not rely on the current working directory. - # Files that are part of the test suite should be accessed relative to - # tcltest::testsDirectory. - - if {![info exists testsDirectory]} { - set oldpwd [pwd] - catch {cd [file join [file dirname [info script]] .. .. tests]} - variable testsDirectory [pwd] - cd $oldpwd - unset oldpwd - } - - # Default is to run each test file in a separate process - if {![info exists singleProcess]} { - variable singleProcess 0 - } - - # the variables and procs that existed when tcltest::saveState was - # called are stored in a variable of the same name - if {![info exists saveState]} { - variable saveState {} - } - - # Internationalization support -- used in tcltest::set_iso8859_1_locale - # and tcltest::restore_locale. Those commands are used in cmdIL.test. - if {![info exists previousLocale]} { - variable previousLocale - } - - if {![info exists isoLocale]} { - variable isoLocale fr - switch -- $tcl_platform(platform) { - "unix" { - - # Try some 'known' values for some platforms: - - switch -exact -- $tcl_platform(os) { - "FreeBSD" { - set tcltest::isoLocale fr_FR.ISO_8859-1 - } - HP-UX { - set tcltest::isoLocale fr_FR.iso88591 - } - Linux - - IRIX { - set tcltest::isoLocale fr - } - default { - - # Works on SunOS 4 and Solaris, and maybe others... - # define it to something else on your system - #if you want to test those. - - set tcltest::isoLocale iso_8859_1 - } - } - } - "windows" { - set tcltest::isoLocale French - } - } - } - - # Set the location of the execuatble - if {![info exists tcltest]} { - variable tcltest [info nameofexecutable] - } - - # save the platform information so it can be restored later - if {![info exists originalTclPlatform]} { - variable originalTclPlatform [array get tcl_platform] - } - - # If a core file exists, save its modification time. - if {![info exists coreModificationTime]} { - if {[file exists [file join $tcltest::workingDirectory core]]} { - variable coreModificationTime [file mtime [file join \ - $tcltest::workingDirectory core]] - } - } - - # stdout and stderr buffers for use when we want to store them - if {![info exists outData]} { - variable outData {} - } - if {![info exists errData]} { - variable errData {} - } - - # keep track of test level for nested test commands - variable testLevel 0 -} - -##################################################################### - -# tcltest::Debug* -- -# -# Internal helper procedures to write out debug information -# dependent on the chosen level. A test shell may overide -# them, f.e. to redirect the output into a different -# channel, or even into a GUI. - -# tcltest::DebugPuts -- -# -# Prints the specified string if the current debug level is -# higher than the provided level argument. -# -# Arguments: -# level The lowest debug level triggering the output -# string The string to print out. -# -# Results: -# Prints the string. Nothing else is allowed. -# -# Side Effects: -# None. -# - -proc tcltest::DebugPuts {level string} { - variable debug - if {$debug >= $level} { - puts $string - } - return -} - -# tcltest::DebugPArray -- -# -# Prints the contents of the specified array if the current -# debug level is higher than the provided level argument -# -# Arguments: -# level The lowest debug level triggering the output -# arrayvar The name of the array to print out. -# -# Results: -# Prints the contents of the array. Nothing else is allowed. -# -# Side Effects: -# None. -# - -proc tcltest::DebugPArray {level arrayvar} { - variable debug - - if {$debug >= $level} { - catch {upvar $arrayvar $arrayvar} - parray $arrayvar - } - return -} - -# tcltest::DebugDo -- -# -# Executes the script if the current debug level is greater than -# the provided level argument -# -# Arguments: -# level The lowest debug level triggering the execution. -# script The tcl script executed upon a debug level high enough. -# -# Results: -# Arbitrary side effects, dependent on the executed script. -# -# Side Effects: -# None. -# - -proc tcltest::DebugDo {level script} { - variable debug - - if {$debug >= $level} { - uplevel $script - } - return -} - -##################################################################### - -# tcltest::CheckDirectory -- -# -# This procedure checks whether the specified path is a readable -# and/or writable directory. If one of the conditions is not -# satisfied an error is printed and the application aborted. The -# procedure assumes that the caller already checked the existence -# of the path. -# -# Arguments -# rw Information what attributes to check. Allowed values: -# r, w, rw, wr. If 'r' is part of the value the directory -# must be readable. 'w' associates to 'writable'. -# dir The directory to check. -# errMsg The string to prepend to the actual error message before -# printing it. -# -# Results -# none -# -# Side Effects: -# None. -# - -proc tcltest::CheckDirectory {rw dir errMsg} { - # Allowed values for 'rw': r, w, rw, wr - - if {![file isdir $dir]} { - set msg "$errMsg \"$dir\" is not a directory" - error $msg - } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - set msg "$errMsg \"$dir\" is not writeable" - error $msg - } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - set msg "$errMsg \"$dir\" is not readable" - error $msg - } - return -} - -# tcltest::normalizePath -- -# -# This procedure resolves any symlinks in the path thus creating a -# path without internal redirection. It assumes that the incoming -# path is absolute. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# -# Results -# The path is modified in place. -# -# Side Effects: -# None. -# - -proc tcltest::normalizePath {pathVar} { - upvar $pathVar path - - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd - return $path -} - - -# tcltest::MakeAbsolutePath -- -# -# This procedure checks whether the incoming path is absolute or not. -# Makes it absolute if it was not. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# prefix is optional, contains the path to use to make the other an -# absolute one. The current working directory is used if it was -# not specified. -# -# Results -# The path is modified in place. -# -# Side Effects: -# None. -# - -proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { - upvar $pathVar path - - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { - set prefix [pwd] - } - - set path [file join $prefix $path] - } - return $path -} - -##################################################################### - -# tcltest::<variableName> -# -# Accessor functions for tcltest variables that can be modified externally. -# These are vars that could otherwise be modified using command line -# arguments to tcltest. - -# tcltest::verbose -- -# -# Set or return the verbosity level (tcltest::verbose) for tests. This -# determines what gets printed to the screen and when, with regard to the -# running of the tests. The proc does not check for invalid values. It -# assumes that a string that doesn't match its predefined keywords -# is a string containing letter-specified verbosity levels. -# -# Arguments: -# A string containing any combination of 'pbste' or a list of keywords -# (listed in parens) -# p = print output whenever a test passes (pass) -# b = print the body of the test when it fails (body) -# s = print when a test is skipped (skip) -# t = print when a test starts (start) -# e = print errorInfo and errorCode when a test encounters an error -# (error) -# -# Results: -# content of tcltest::verbose - this is always the character combination -# (pbste) instead of the list form. -# -# Side effects: -# None. - -proc tcltest::verbose { {level ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::verbose - } - if {[llength $level] > 1} { - set tcltest::verbose $level - } else { - if {[regexp {pass|body|skip|start|error} $level]} { - set tcltest::verbose $level - } else { - set levelList [split $level {}] - set tcltest::verbose [string map {p pass b body s skip t start e - error} $levelList] - } - } - return $tcltest::verbose -} - -# tcltest::isVerbose -- -# -# Returns true if argument is one of the verbosity levels currently being -# used; returns false otherwise. -# -# Arguments: -# level -# -# Results: -# boolean 1 (true) or 0 (false), depending on whether or not the level -# provided is one of the ones stored in tcltest::verbose. -# -# Side effects: -# None. - -proc tcltest::isVerbose {level} { - if {[lsearch -exact [tcltest::verbose] $level] == -1} { - return 0 - } - return 1 -} - - - -# tcltest::match -- -# -# Set or return the match patterns (tcltest::match) that determine which -# tests are run. -# -# Arguments: -# List containing match patterns (glob format) -# -# Results: -# content of tcltest::match -# -# Side effects: -# none - -proc tcltest::match { {matchList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::match - } - set tcltest::match $matchList -} - -# tcltest::skip -- -# -# Set or return the skip patterns (tcltest::skip) that determine which -# tests are skipped. -# -# Arguments: -# List containing skip patterns (glob format) -# -# Results: -# content of tcltest::skip -# -# Side effects: -# None. - -proc tcltest::skip { {skipList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skip - } - set tcltest::skip $skipList -} - -# tcltest::matchFiles -- -# -# set or return the match patterns for file sourcing -# -# Arguments: -# list containing match file list (glob format) -# -# Results: -# content of tcltest::matchFiles -# -# Side effects: -# None. - -proc tcltest::matchFiles { {matchFileList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::matchFiles - } - set tcltest::matchFiles $matchFileList -} - -# tcltest::skipFiles -- -# -# set or return the skip patterns for file sourcing -# -# Arguments: -# list containing the skip file list (glob format) -# -# Results: -# content of tcltest::skipFiles -# -# Side effects: -# None. - -proc tcltest::skipFiles { {skipFileList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skipFiles - } - set tcltest::skipFiles $skipFileList -} - - -# tcltest::matchDirectories -- -# -# set or return the list of directories for matching (glob pattern list) -# -# Arguments: -# list of glob patterns matching subdirectories of -# tcltest::testsDirectory -# -# Results: -# content of tcltest::matchDirectories -# -# Side effects: -# None. - -proc tcltest::matchDirectories { {dirlist ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::matchDirectories - } - set tcltest::matchDirectories $dirlist -} - -# tcltest::skipDirectories -- -# -# set or return the list of directories to skip (glob pattern list) -# -# Arguments: -# list of glob patterns matching directories to skip; these directories -# are subdirectories of tcltest::testsDirectory -# -# Results: -# content of tcltest::skipDirectories -# -# Side effects: -# None. - -proc tcltest::skipDirectories { {dirlist ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skipDirectories - } - set tcltest::skipDirectories $dirlist -} - -# tcltest::preserveCore -- -# -# set or return the core preservation level. This proc does not do any -# error checking for invalid values. -# -# Arguments: -# core level: -# '0' = don't do anything with core files (default) -# '1' = notify the user if core files are created -# '2' = save any core files produced during testing to -# tcltest::temporaryDirectory -# -# Results: -# content of tcltest::preserveCore -# -# Side effects: -# None. - -proc tcltest::preserveCore { {coreLevel ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::preserveCore - } - set tcltest::preserveCore $coreLevel -} - -# tcltest::outputChannel -- -# -# set or return the output file descriptor based on the supplied file -# name (where tcltest puts all of its output) -# -# Arguments: -# output file descriptor -# -# Results: -# file descriptor corresponding to supplied file name (or currently set -# file descriptor, if no new filename was supplied) - this is the content -# of tcltest::outputChannel -# -# Side effects: -# None. - -proc tcltest::outputChannel { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::outputChannel - } - if {($filename == "stderr") || ($filename == "stdout")} { - set tcltest::outputChannel $filename - } else { - set tcltest::outputChannel [open $filename w] - } - return $tcltest::outputChannel -} - -# tcltest::outputFile -- -# -# set or return the output file name (where tcltest puts all of its -# output); calls tcltest::outputChannel to set the corresponding file -# descriptor -# -# Arguments: -# output file name -# -# Results: -# file name corresponding to supplied file name (or currently set -# file name, if no new filename was supplied) - this is the content -# of tcltest::outputFile -# -# Side effects: -# if the file name supplied is relative, it will be made absolute with -# respect to the predefined temporaryDirectory - -proc tcltest::outputFile { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::outputFile - } - if {($filename != "stderr") && ($filename != "stdout")} { - MakeAbsolutePath filename $tcltest::temporaryDirectory - } - tcltest::outputChannel $filename - set tcltest::outputFile $filename -} - -# tcltest::errorChannel -- -# -# set or return the error file descriptor based on the supplied file name -# (where tcltest sends all its errors) -# -# Arguments: -# error file name -# -# Results: -# file descriptor corresponding to the supplied file name (or currently -# set file descriptor, if no new filename was supplied) - this is the -# content of tcltest::errorChannel -# -# Side effects: -# opens the descriptor in w mode unless the filename is set to stderr or -# stdout - -proc tcltest::errorChannel { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::errorChannel - } - if {($filename == "stderr") || ($filename == "stdout")} { - set tcltest::errorChannel $filename - } else { - set tcltest::errorChannel [open $filename w] - } - return $tcltest::errorChannel -} - -# tcltest::errorFile -- -# -# set or return the error file name; calls tcltest::errorChannel to set -# the corresponding file descriptor -# -# Arguments: -# error file name -# -# Results: -# content of tcltest::errorFile -# -# Side effects: -# if the file name supplied is relative, it will be made absolute with -# respect to the predefined temporaryDirectory - -proc tcltest::errorFile { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::errorFile - } - if {($filename != "stderr") && ($filename != "stdout")} { - MakeAbsolutePath filename $tcltest::temporaryDirectory - } - set tcltest::errorFile $filename - errorChannel $tcltest::errorFile - return $tcltest::errorFile -} - -# tcltest::debug -- -# -# set or return the debug level for tcltest; this proc does not check for -# invalid values -# -# Arguments: -# debug level: -# '0' = no debug output (default) -# '1' = skipped tests -# '2' = tcltest variables and supplied flags -# '3' = harness operations -# -# Results: -# content of tcltest::debug -# -# Side effects: -# None. - -proc tcltest::debug { {debugLevel ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::debug - } - set tcltest::debug $debugLevel -} - -# tcltest::testConstraint -- -# -# sets a test constraint to a value; to do multiple constraints, call -# this proc multiple times. also returns the value of the named -# constraint if no value was supplied. -# -# Arguments: -# constraint - name of the constraint -# value - new value for constraint (should be boolean) - if not supplied, -# this is a query -# -# Results: -# content of tcltest::testConstraints($constraint) -# -# Side effects: -# appends the constraint name to tcltest::constraintsSpecified - -proc tcltest::testConstraint {constraint {value ""}} { - DebugPuts 3 "entering testConstraint $constraint $value" - if {[llength [info level 0]] == 2} { - return $tcltest::testConstraints($constraint) - } - lappend tcltest::constraintsSpecified $constraint - set tcltest::testConstraints($constraint) $value -} - -# tcltest::constraintsSpecified -- -# -# returns a list of all the constraint names specified using -# testConstraint -# -# Arguments: -# None. -# -# Results: -# list of the constraint names in tcltest::constraintsSpecified -# -# Side effects: -# None. - -proc tcltest::constraintsSpecified {} { - return $tcltest::constraintsSpecified -} - -# tcltest::constraintList -- -# -# returns a list of all the constraint names -# -# Arguments: -# None. -# -# Results: -# list of the constraint names in tcltest::testConstraints -# -# Side effects: -# None. - -proc tcltest::constraintList {} { - return [array names tcltest::testConstraints] -} - -# tcltest::limitConstraints -- -# -# sets the limited constraints to tcltest::limitConstraints -# -# Arguments: -# list of constraint names -# -# Results: -# content of tcltest::limitConstraints -# -# Side effects: -# None. - -proc tcltest::limitConstraints { {constraintList ""} } { - DebugPuts 3 "entering limitConstraints $constraintList" - if {[llength [info level 0]] == 1} { - return $tcltest::limitConstraints - } - set tcltest::limitConstraints $constraintList - foreach elt [tcltest::constraintList] { - if {[lsearch -exact [tcltest::constraintsSpecified] $elt] == -1} { - tcltest::testConstraint $elt 0 - } - } - return $tcltest::limitConstraints -} - -# tcltest::loadScript -- -# -# sets the load script -# -# Arguments: -# script to be set -# -# Results: -# contents of tcltest::loadScript -# -# Side effects: -# None. - -proc tcltest::loadScript { {script ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::loadScript - } - set tcltest::loadScript $script -} - -# tcltest::loadFile -- -# -# set the load file (containing the load script); -# put the content of the load file into loadScript -# -# Arguments: -# script's file name -# -# Results: -# content of tcltest::loadFile -# -# Side effects: -# None. - -proc tcltest::loadFile { {scriptFile ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::loadFile - } - MakeAbsolutePath scriptFile $tcltest::temporaryDirectory - set tmp [open $scriptFile r] - tcltest::loadScript [read $tmp] - close $tmp - set tcltest::loadFile $scriptFile -} - -# tcltest::workingDirectory -- -# -# set workingDirectory to the given path. -# If the path is relative, make it absolute. -# change directory to the stated working directory, if resetting the -# value -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::workingDirectory -# -# Side effects: -# None. - -proc tcltest::workingDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::workingDirectory - } - set tcltest::workingDirectory $dir - MakeAbsolutePath tcltest::workingDirectory - cd $tcltest::workingDirectory - return $tcltest::workingDirectory -} - -# tcltest::temporaryDirectory -- -# -# Set tcltest::temporaryDirectory to the given path. -# If the path is relative, make it absolute. If the file exists but -# is not a dir, then return an error. -# -# If tcltest::temporaryDirectory does not already exist, create it. -# If you cannot create it, then return an error (the file mkdir isn't -# caught and will propagate). -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::temporaryDirectory -# -# Side effects: -# None. - -proc tcltest::temporaryDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::temporaryDirectory - } - set tcltest::temporaryDirectory $dir - - MakeAbsolutePath tcltest::temporaryDirectory - set tmpDirError "bad argument for temporary directory: " - - if {[file exists $tcltest::temporaryDirectory]} { - tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError - } else { - file mkdir $tcltest::temporaryDirectory - } - - normalizePath tcltest::temporaryDirectory -} - -# tcltest::testsDirectory -- -# -# Set tcltest::testsDirectory to the given path. -# If the path is relative, make it absolute. If the file exists but -# is not a dir, then return an error. -# -# If tcltest::testsDirectory does not already exist, return an error. -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::testsDirectory -# -# Side effects: -# None. - -proc tcltest::testsDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::testsDirectory - } - - set tcltest::testsDirectory $dir - - MakeAbsolutePath tcltest::testsDirectory - set testDirError "bad argument for tests directory: " - - if {[file exists $tcltest::testsDirectory]} { - tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError - } else { - set msg "$testDirError \"$tcltest::testsDirectory\" does not exist" - error $msg - } - - normalizePath tcltest::testsDirectory -} - -# tcltest::singleProcess -- -# -# sets tcltest::singleProcess to the value provided. -# -# Arguments: -# value for singleProcess: -# 1 = source each test file into the current process -# 0 = run each test file in its own process -# -# Results: -# content of tcltest::singleProcess -# -# Side effects: -# None. - -proc tcltest::singleProcess { {value ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::singleProcess - } - set tcltest::singleProcess $value -} - -# tcltest::interpreter -- -# -# the interpreter name stored in tcltest::tcltest -# -# Arguments: -# executable name -# -# Results: -# content of tcltest::tcltest -# -# Side effects: -# None. - -proc tcltest::interpreter { {interp ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::tcltest - } - set tcltest::tcltest $interp -} - -# tcltest::mainThread -- -# -# sets or returns the thread id stored in tcltest::mainThread -# -# Arguments: -# thread id -# -# Results: -# content of tcltest::mainThread -# -# Side effects: -# None. - -proc tcltest::mainThread { {threadid ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::mainThread - } - set tcltest::mainThread $threadid -} - -##################################################################### - -# tcltest::AddToSkippedBecause -- -# -# Increments the variable used to track how many tests were skipped -# because of a particular constraint. -# -# Arguments: -# constraint The name of the constraint to be modified -# -# Results: -# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't -# previously exist - otherwise, it just increments it. -# -# Side effects: -# None. - -proc tcltest::AddToSkippedBecause { constraint {value 1}} { - # add the constraint to the list of constraints that kept tests - # from running - - if {[info exists tcltest::skippedBecause($constraint)]} { - incr tcltest::skippedBecause($constraint) $value - } else { - set tcltest::skippedBecause($constraint) $value - } - return -} - -# tcltest::PrintError -- -# -# Prints errors to tcltest::errorChannel and then flushes that -# channel, making sure that all messages are < 80 characters per line. -# -# Arguments: -# errorMsg String containing the error to be printed -# -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::PrintError {errorMsg} { - set InitialMessage "Error: " - set InitialMsgLen [string length $InitialMessage] - puts -nonewline [errorChannel] $InitialMessage - - # Keep track of where the end of the string is. - set endingIndex [string length $errorMsg] - - if {$endingIndex < 80} { - puts [errorChannel] $errorMsg - } else { - # Print up to 80 characters on the first line, including the - # InitialMessage. - set beginningIndex [string last " " [string range $errorMsg 0 \ - [expr {80 - $InitialMsgLen}]]] - puts [errorChannel] [string range $errorMsg 0 $beginningIndex] - - while {$beginningIndex != "end"} { - puts -nonewline [errorChannel] \ - [string repeat " " $InitialMsgLen] - if {[expr {$endingIndex - $beginningIndex}] < 72} { - puts [errorChannel] [string trim \ - [string range $errorMsg $beginningIndex end]] - set beginningIndex end - } else { - set newEndingIndex [expr [string last " " [string range \ - $errorMsg $beginningIndex \ - [expr {$beginningIndex + 72}]]] + $beginningIndex] - if {($newEndingIndex <= 0) \ - || ($newEndingIndex <= $beginningIndex)} { - set newEndingIndex end - } - puts [errorChannel] [string trim \ - [string range $errorMsg \ - $beginningIndex $newEndingIndex]] - set beginningIndex $newEndingIndex - } - } - } - flush [errorChannel] - return -} - -if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { - proc tcltest::initConstraintsHook {} {} -} - -# tcltest::safeFetch -- -# -# The following trace procedure makes it so that we can safely refer to -# non-existent members of the tcltest::testConstraints array without -# causing an error. Instead, reading a non-existent member will return -# 0. This is necessary because tests are allowed to use constraint "X" -# without ensuring that tcltest::testConstraints("X") is defined. -# -# Arguments: -# n1 - name of the array (tcltest::testConstraints) -# n2 - array key value (constraint name) -# op - operation performed on tcltest::testConstraints (generally r) -# -# Results: -# none -# -# Side effects: -# sets tcltest::testConstraints($n2) to 0 if it's referenced but never -# before used - -proc tcltest::safeFetch {n1 n2 op} { - DebugPuts 3 "entering safeFetch $n1 $n2 $op" - if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { - tcltest::testConstraint $n2 0 - } -} - -# tcltest::initConstraints -- -# -# Check constraint information that will determine which tests -# to run. To do this, create an array tcltest::testConstraints. Each -# element has a 0 or 1 value. If the element is "true" then tests -# with that constraint will be run, otherwise tests with that constraint -# will be skipped. See the tcltest man page for the list of built-in -# constraints defined in this procedure. -# -# Arguments: -# none -# -# Results: -# The tcltest::testConstraints array is reset to have an index for -# each built-in test constraint. -# -# Side Effects: -# None. -# - -proc tcltest::initConstraints {} { - global tcl_platform tcl_interactive tk_version - - # Safely refer to non-existent members of the tcltest::testConstraints - # array without causing an error. - trace variable tcltest::testConstraints r tcltest::safeFetch - - tcltest::initConstraintsHook - - tcltest::testConstraint singleTestInterp [singleProcess] - - # All the 'pc' constraints are here for backward compatibility and are not - # documented. They have been replaced with equivalent 'win' constraints. - - tcltest::testConstraint unixOnly \ - [string equal $tcl_platform(platform) "unix"] - tcltest::testConstraint macOnly \ - [string equal $tcl_platform(platform) "macintosh"] - tcltest::testConstraint pcOnly \ - [string equal $tcl_platform(platform) "windows"] - tcltest::testConstraint winOnly \ - [string equal $tcl_platform(platform) "windows"] - - tcltest::testConstraint unix [tcltest::testConstraint unixOnly] - tcltest::testConstraint mac [tcltest::testConstraint macOnly] - tcltest::testConstraint pc [tcltest::testConstraint pcOnly] - tcltest::testConstraint win [tcltest::testConstraint winOnly] - - tcltest::testConstraint unixOrPc \ - [expr {[tcltest::testConstraint unix] \ - || [tcltest::testConstraint pc]}] - tcltest::testConstraint macOrPc \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint pc]}] - tcltest::testConstraint unixOrWin \ - [expr {[tcltest::testConstraint unix] \ - || [tcltest::testConstraint win]}] - tcltest::testConstraint macOrWin \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint win]}] - tcltest::testConstraint macOrUnix \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint unix]}] - - tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"] - tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"] - tcltest::testConstraint 98 [string equal $tcl_platform(os) "Windows 98"] - - # The following Constraints switches are used to mark tests that should - # work, but have been temporarily disabled on certain platforms because - # they don't and we haven't gotten around to fixing the underlying - # problem. - - tcltest::testConstraint tempNotPc \ - [expr {![tcltest::testConstraint pc]}] - tcltest::testConstraint tempNotWin \ - [expr {![tcltest::testConstraint win]}] - tcltest::testConstraint tempNotMac \ - [expr {![tcltest::testConstraint mac]}] - tcltest::testConstraint tempNotUnix \ - [expr {![tcltest::testConstraint unix]}] - - # The following Constraints switches are used to mark tests that crash on - # certain platforms, so that they can be reactivated again when the - # underlying problem is fixed. - - tcltest::testConstraint pcCrash \ - [expr {![tcltest::testConstraint pc]}] - tcltest::testConstraint winCrash \ - [expr {![tcltest::testConstraint win]}] - tcltest::testConstraint macCrash \ - [expr {![tcltest::testConstraint mac]}] - tcltest::testConstraint unixCrash \ - [expr {![tcltest::testConstraint unix]}] - - # Skip empty tests - - tcltest::testConstraint emptyTest 0 - - # By default, tests that expose known bugs are skipped. - - tcltest::testConstraint knownBug 0 - - # By default, non-portable tests are skipped. - - tcltest::testConstraint nonPortable 0 - - # Some tests require user interaction. - - tcltest::testConstraint userInteraction 0 - - # Some tests must be skipped if the interpreter is not in interactive mode - - if {[info exists tcl_interactive]} { - tcltest::testConstraint interactive $::tcl_interactive - } else { - tcltest::testConstraint interactive 0 - } - - # Some tests can only be run if the installation came from a CD image - # instead of a web image - # Some tests must be skipped if you are running as root on Unix. - # Other tests can only be run if you are running as root on Unix. - - tcltest::testConstraint root 0 - tcltest::testConstraint notRoot 1 - set user {} - if {[string equal $tcl_platform(platform) "unix"]} { - catch {set user [exec whoami]} - if {[string equal $user ""]} { - catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} - } - if {([string equal $user "root"]) || ([string equal $user ""])} { - tcltest::testConstraint root 1 - tcltest::testConstraint notRoot 0 - } - } - - # Set nonBlockFiles constraint: 1 means this platform supports - # ting files into nonblocking mode. - - if {[catch {set f [open defs r]}]} { - tcltest::testConstraint nonBlockFiles 1 - } else { - if {[catch {fconfigure $f -blocking off}] == 0} { - tcltest::testConstraint nonBlockFiles 1 - } else { - tcltest::testConstraint nonBlockFiles 0 - } - close $f - } - - # Set asyncPipeClose constraint: 1 means this platform supports - # async flush and async close on a pipe. - # - # Test for SCO Unix - cannot run async flushing tests because a - # potential problem with select is apparently interfering. - # (Mark Diekhans). - - if {[string equal $tcl_platform(platform) "unix"]} { - if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - tcltest::testConstraint asyncPipeClose 0 - } else { - tcltest::testConstraint asyncPipeClose 1 - } - } else { - tcltest::testConstraint asyncPipeClose 1 - } - - # Test to see if we have a broken version of sprintf with respect - # to the "e" format of floating-point numbers. - - tcltest::testConstraint eformat 1 - if {![string equal "[format %g 5e-5]" "5e-05"]} { - tcltest::testConstraint eformat 0 - } - - # Test to see if execed commands such as cat, echo, rm and so forth are - # present on this machine. - - tcltest::testConstraint unixExecs 1 - if {[string equal $tcl_platform(platform) "macintosh"]} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([string equal $tcl_platform(platform) "windows"])} { - if {[catch {exec cat defs}] == 1} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec echo hello}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec sh -c echo hello}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec wc defs}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {[tcltest::testConstraint unixExecs] == 1} { - exec echo hello > removeMe - if {[catch {exec rm removeMe}] == 1} { - tcltest::testConstraint unixExecs 0 - } - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec sleep 1}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec fgrep unixExecs defs}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec ps}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec echo abc > removeMe}] == 0) && \ - ([catch {exec chmod 644 removeMe}] == 1) && \ - ([catch {exec rm removeMe}] == 0)} { - tcltest::testConstraint unixExecs 0 - } else { - catch {exec rm -f removeMe} - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec mkdir removeMe}] == 1)} { - tcltest::testConstraint unixExecs 0 - } else { - catch {exec rm -r removeMe} - } - } - - # Locate tcltest executable - - if {![info exists tk_version]} { - set tcltest::tcltest [info nameofexecutable] - - if {$tcltest::tcltest == "{}"} { - set tcltest::tcltest {} - } - } - - tcltest::testConstraint stdio 0 - catch { - catch {file delete -force tmp} - set f [open tmp w] - puts $f { - exit - } - close $f - - set f [open "|[list $tcltest tmp]" r] - close $f - - tcltest::testConstraint stdio 1 - } - catch {file delete -force tmp} - - # Deliberately call socket with the wrong number of arguments. The error - # message you get will indicate whether sockets are available on this - # system. - - catch {socket} msg - tcltest::testConstraint socket \ - [expr {$msg != "sockets are not available on this system"}] - - # Check for internationalization - - if {[info commands testlocale] == ""} { - # No testlocale command, no tests... - tcltest::testConstraint hasIsoLocale 0 - } else { - tcltest::testConstraint hasIsoLocale \ - [string length [tcltest::set_iso8859_1_locale]] - tcltest::restore_locale - } -} - -##################################################################### - -# Handle command line arguments (from argv) and default arg settings -# (in TCLTEST_OPTIONS). - -# tcltest::PrintUsageInfoHook -# -# Hook used for customization of display of usage information. -# - -if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} { - proc tcltest::PrintUsageInfoHook {} {} -} - -# tcltest::PrintUsageInfo -# -# Prints out the usage information for package tcltest. This can be -# customized with the redefinition of tcltest::PrintUsageInfoHook. -# -# Arguments: -# none -# -# Results: -# none -# -# Side Effects: -# none - -proc tcltest::PrintUsageInfo {} { - puts [format "Usage: [file tail [info nameofexecutable]] \ - script ?-help? ?flag value? ... \n\ - Available flags (and valid input values) are: \n\ - -help \t Display this usage information. \n\ - -verbose level \t Takes any combination of the values \n\ - \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\ - \t display all passed tests if 'p' is \n\ - \t specified, all skipped tests if 's' \n\ - \t is specified, the bodies of \n\ - \t failed tests if 'b' is specified, \n\ - \t and when tests start if 't' is specified. \n\ - \t ErrorInfo is displayed if 'e' is specified. \n\ - \t The default value is 'b'. \n\ - -constraints list\t Do not skip the listed constraints\n\ - -limitconstraints bool\t Only run tests with the constraints\n\ - \t listed in -constraints.\n\ - -match pattern \t Run all tests within the specified \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -skip pattern \t Skip all tests within the set of \n\ - \t specified tests (via -match) and \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -file pattern \t Run tests in all test files that \n\ - \t match the glob pattern given. \n\ - -notfile pattern\t Skip all test files that match the \n\ - \t glob pattern given. \n\ - -relateddir pattern\t Run tests in directories that match \n\ - \t the glob pattern given. \n\ - -asidefromdir pattern\t Skip tests in directories that match \n\ - \t the glob pattern given.\n\ - -preservecore level \t If 2, save any core files produced \n\ - \t during testing in the directory \n\ - \t specified by -tmpdir. If 1, notify the\n\ - \t user if core files are created. The default \n\ - \t is $tcltest::preserveCore. \n\ - -tmpdir directory\t Save temporary files in the specified\n\ - \t directory. The default value is \n\ - \t $tcltest::temporaryDirectory. \n\ - -testdir directories\t Search tests in the specified\n\ - \t directories. The default value is \n\ - \t $tcltest::testsDirectory. \n\ - -outfile file \t Send output from test runs to the \n\ - \t specified file. The default is \n\ - \t stdout. \n\ - -errfile file \t Send errors from test runs to the \n\ - \t specified file. The default is \n\ - \t stderr. \n\ - -loadfile file \t Read the script to load the tested \n\ - \t commands from the specified file. \n\ - -load script \t Specifies the script to load the tested \n\ - \t commands. \n\ - -debug level \t Internal debug flag."] - tcltest::PrintUsageInfoHook - return -} - -# tcltest::processCmdLineArgsFlagsHook -- -# -# This hook is used to add to the list of command line arguments that are -# processed by tcltest::ProcessFlags. It is called at the beginning of -# ProcessFlags. -# - -if {[namespace inscope tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { - proc tcltest::processCmdLineArgsAddFlagsHook {} {} -} - -# tcltest::processCmdLineArgsHook -- -# -# This hook is used to actually process the flags added by -# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of -# ProcessFlags. -# -# Arguments: -# flags The flags that have been pulled out of argv -# - -if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} { - proc tcltest::processCmdLineArgsHook {flag} {} -} - -# tcltest::ProcessFlags -- -# -# process command line arguments supplied in the flagArray - this is -# called by processCmdLineArgs -# modifies tcltest variables according to the content of the flagArray. -# -# Arguments: -# flagArray - array containing name/value pairs of flags -# -# Results: -# sets tcltest variables according to their values as defined by -# flagArray -# -# Side effects: -# None. - -proc tcltest::ProcessFlags {flagArray} { - # Process -help first - if {[lsearch -exact $flagArray {-help}] != -1} { - tcltest::PrintUsageInfo - exit 1 - } - - catch {array set flag $flagArray} - - # -help is not listed since it has already been processed - lappend defaultFlags -verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints -testdir \ - -load -loadfile -asidefromdir \ - -relateddir -singleproc - set defaultFlags [concat $defaultFlags \ - [tcltest::processCmdLineArgsAddFlagsHook ]] - - # Set tcltest::verbose to the arg of the -verbose flag, if given - if {[info exists flag(-verbose)]} { - tcltest::verbose $flag(-verbose) - } - - # Set tcltest::match to the arg of the -match flag, if given. - if {[info exists flag(-match)]} { - tcltest::match $flag(-match) - } - - # Set tcltest::skip to the arg of the -skip flag, if given - if {[info exists flag(-skip)]} { - tcltest::skip $flag(-skip) - } - - # Handle the -file and -notfile flags - if {[info exists flag(-file)]} { - tcltest::matchFiles $flag(-file) - } - if {[info exists flag(-notfile)]} { - tcltest::skipFiles $flag(-notfile) - } - - # Handle -relateddir and -asidefromdir flags - if {[info exists flag(-relateddir)]} { - tcltest::matchDirectories $flag(-relateddir) - } - if {[info exists flag(-asidefromdir)]} { - tcltest::skipDirectories $flag(-asidefromdir) - } - - # Use the -constraints flag, if given, to turn on constraints that are - # turned off by default: userInteractive knownBug nonPortable. This - # code fragment must be run after constraints are initialized. - - if {[info exists flag(-constraints)]} { - foreach elt $flag(-constraints) { - tcltest::testConstraint $elt 1 - } - } - - # Use the -limitconstraints flag, if given, to tell the harness to limit - # tests run to those that were specified using the -constraints flag. If - # the -constraints flag was not specified, print out an error and exit. - if {[info exists flag(-limitconstraints)]} { - if {![info exists flag(-constraints)]} { - set msg "-limitconstraints flag can only be used with -constraints" - error $msg - } - tcltest::limitConstraints $flag(-limitconstraints) - } - - # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if - # given. - - if {[info exists flag(-tmpdir)]} { - tcltest::temporaryDirectory $flag(-tmpdir) - } - - # Set the tcltest::testsDirectory to the arg of -testdir, if - # given. - - if {[info exists flag(-testdir)]} { - tcltest::testsDirectory $flag(-testdir) - } - - # If an alternate error or output files are specified, change the - # default channels. - - if {[info exists flag(-outfile)]} { - tcltest::outputFile $flag(-outfile) - } - - if {[info exists flag(-errfile)]} { - tcltest::errorFile $flag(-errfile) - } - - # If a load script was specified, either directly or through - # a file, remember it for later usage. - - if {[info exists flag(-load)] && \ - ([lsearch -exact $flagArray -load] > \ - [lsearch -exact $flagArray -loadfile])} { - tcltest::loadScript $flag(-load) - } - - if {[info exists flag(-loadfile)] && \ - ([lsearch -exact $flagArray -loadfile] > \ - [lsearch -exact $flagArray -load]) } { - tcltest::loadFile $flag(-loadfile) - } - - # If the user specifies debug testing, print out extra information during - # the run. - if {[info exists flag(-debug)]} { - tcltest::debug $flag(-debug) - } - - # Handle -preservecore - if {[info exists flag(-preservecore)]} { - tcltest::preserveCore $flag(-preservecore) - } - - # Handle -singleproc flag - if {[info exists flag(-singleproc)]} { - tcltest::singleProcess $flag(-singleproc) - } - - # Call the hook - tcltest::processCmdLineArgsHook [array get flag] - return -} - -# tcltest::processCmdLineArgs -- -# -# Use command line args to set tcltest namespace variables. -# -# This procedure must be run after constraints are initialized, because -# some constraints can be overridden. -# -# Set variables based on the contents of the environment variable -# TCLTEST_OPTIONS first, then override with command-line options, if -# specified. -# -# Arguments: -# none -# -# Results: -# Sets the above-named variables in the tcltest namespace. -# -# Side Effects: -# None. -# - -proc tcltest::processCmdLineArgs {} { - global argv - - # If the TCLTEST_OPTIONS environment variable exists, parse it first, then - # the argv list. The command line argument parsing will be a two-pass - # affair from now on, so that TCLTEST_OPTIONS contain the default options. - # These can be overridden by the command line flags. - - if {[info exists ::env(TCLTEST_OPTIONS)]} { - tcltest::ProcessFlags $::env(TCLTEST_OPTIONS) - } - - # The "argv" var doesn't exist in some cases, so use {}. - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv - } - - tcltest::ProcessFlags $flagArray - - # Spit out everything you know if we're at a debug level 2 or greater - DebugPuts 2 "Flags passed into tcltest:" - if {[info exists ::env(TCLTEST_OPTIONS)]} { - DebugPuts 2 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" - } - if {[info exists argv]} { - DebugPuts 2 " argv: $argv" - } - DebugPuts 2 "tcltest::debug = [tcltest::debug]" - DebugPuts 2 "tcltest::testsDirectory = [tcltest::testsDirectory]" - DebugPuts 2 "tcltest::workingDirectory = [tcltest::workingDirectory]" - DebugPuts 2 "tcltest::temporaryDirectory = [tcltest::temporaryDirectory]" - DebugPuts 2 "tcltest::outputChannel = [outputChannel]" - DebugPuts 2 "tcltest::errorChannel = [errorChannel]" - DebugPuts 2 "Original environment (tcltest::originalEnv):" - DebugPArray 2 tcltest::originalEnv - DebugPuts 2 "Constraints:" - DebugPArray 2 tcltest::testConstraints - return -} - -##################################################################### - -# Code to run the tests goes here. - -# tcltest::testPuts -- -# -# Used to redefine puts in test environment. -# Stores whatever goes out on stdout in tcltest::outData and stderr in -# tcltest::errData before sending it on to the regular puts. -# -# Arguments: -# same as standard puts -# -# Results: -# none -# -# Side effects: -# Intercepts puts; data that would otherwise go to stdout, stderr, or -# file channels specified in tcltest::outputChannel and errorChannel does -# not get sent to the normal puts function. - -proc tcltest::testPuts {args} { - set len [llength $args] - if {$len == 1} { - # Only the string to be printed is specified - append tcltest::outData "[lindex $args 0]\n" - return -# return [tcltest::normalPuts [lindex $args 0]] - } elseif {$len == 2} { - # Either -nonewline or channelId has been specified - if {[regexp {^-nonewline} [lindex $args 0]]} { - append tcltest::outData "[lindex $args end]" - return -# return [tcltest::normalPuts -nonewline [lindex $args end]] - } else { - set channel [lindex $args 0] - } - } elseif {$len == 3} { - if {[lindex $args 0] == "-nonewline"} { - # Both -nonewline and channelId are specified, unless it's an - # error. -nonewline is supposed to be argv[0]. - set channel [lindex $args 1] - } - } - - if {[info exists channel]} { - if {($channel == [outputChannel]) || ($channel == "stdout")} { - append tcltest::outData "[lindex $args end]\n" - } elseif {($channel == [errorChannel]) || ($channel == "stderr")} { - append tcltest::errData "[lindex $args end]\n" - } - return - # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]] - } - - # If we haven't returned by now, we don't know how to handle the input. - # Let puts handle it. - return [eval tcltest::normalPuts $args] -} - -# tcltest::testEval -- -# -# Evaluate the script in the test environment. If ignoreOutput is -# false, store data sent to stderr and stdout in tcltest::outData and -# tcltest::errData. Otherwise, ignore this output altogether. -# -# Arguments: -# script Script to evaluate -# ?ignoreOutput? Indicates whether or not to ignore output sent to -# stdout & stderr -# -# Results: -# result from running the script -# -# Side effects: -# Empties the contents of tcltest::outData and tcltest::errData before -# running a test if ignoreOutput is set to 0. - -proc tcltest::testEval {script {ignoreOutput 1}} { - DebugPuts 3 "testEval called" - if {!$ignoreOutput} { - set tcltest::outData {} - set tcltest::errData {} - uplevel rename ::puts tcltest::normalPuts - uplevel rename tcltest::testPuts ::puts - } - set result [uplevel $script] - if {!$ignoreOutput} { - uplevel rename ::puts tcltest::testPuts - uplevel rename tcltest::normalPuts ::puts - } - return $result -} - -# compareStrings -- -# -# compares the expected answer to the actual answer, depending on the -# mode provided. Mode determines whether a regexp, exact, or glob -# comparison is done. -# -# Arguments: -# actual - string containing the actual result -# expected - pattern to be matched against -# mode - type of comparison to be done -# -# Results: -# result of the match -# -# Side effects: -# None. - -proc tcltest::compareStrings {actual expected mode} { - switch -- $mode { - exact { - set retval [string equal $actual $expected] - } - glob { - set retval [string match $expected $actual] - } - regexp { - set retval [regexp -- $expected $actual] - } - } - return $retval -} - - -# -# tcltest::substArguments list -# -# This helper function takes in a list of words, then perform a -# substitution on the list as though each word in the list is a -# separate argument to the Tcl function. For example, if this -# function is invoked as: -# -# substArguments {$a {$a}} -# -# Then it is as though the function is invoked as: -# -# substArguments $a {$a} -# -# This code is adapted from Paul Duffin's function "SplitIntoWords". -# The original function can be found on: -# -# http://purl.org/thecliff/tcl/wiki/858.html -# -# Results: -# a list containing the result of the substitution -# -# Exceptions: -# An error may occur if the list containing unbalanced quote or -# unknown variable. -# -# Side Effects: -# None. -# - -proc tcltest::substArguments {argList} { - - # We need to split the argList up into tokens but cannot use - # list operations as they throw away some significant - # quoting, and [split] ignores braces as it should. - # Therefore what we do is gradually build up a string out of - # whitespace seperated strings. We cannot use [split] to - # split the argList into whitespace seperated strings as it - # throws away the whitespace which maybe important so we - # have to do it all by hand. - - set result {} - set token "" - - while {[string length $argList]} { - # Look for the next word containing a quote: " { } - if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ - $argList all]} { - # Get the text leading up to this word, but not - # including this word, from the argList. - set text [string range $argList 0 \ - [expr {[lindex $all 0] - 1}]] - # Get the word with the quote - set word [string range $argList \ - [lindex $all 0] [lindex $all 1]] - - # Remove all text up to and including the word from the - # argList. - set argList [string range $argList \ - [expr {[lindex $all 1] + 1}] end] - } else { - # Take everything up to the end of the argList. - set text $argList - set word {} - set argList {} - } - - if {$token != {}} { - # If we saw a word with quote before, then there is a - # multi-word token starting with that word. In this case, - # add the text and the current word to this token. - append token $text $word - } else { - # Add the text to the result. There is no need to parse - # the text because it couldn't be a part of any multi-word - # token. Then start a new multi-word token with the word - # because we need to pass this token to the Tcl parser to - # check for balancing quotes - append result $text - set token $word - } - - if { [catch {llength $token} length] == 0 && $length == 1} { - # The token is a valid list so add it to the result. - # lappend result [string trim $token] - append result \{$token\} - set token {} - } - } - - # If the last token has not been added to the list then there - # is a problem. - if { [string length $token] } { - error "incomplete token \"$token\"" - } - - return $result -} - - -# tcltest::test -- -# -# This procedure runs a test and prints an error message if the test fails. -# If tcltest::verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# tcltest::match variable, if it matches an element in -# tcltest::skip, or if one of the elements of "constraints" turns -# out not to be true. -# -# If testLevel is 1, then this is a top level test, and we record pass/fail -# information; otherwise, this information is not logged and is not added to -# running totals. -# -# Attributes: -# Only description is a required attribute. All others are optional. -# Default values are indicated. -# -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "tcltest::testConstraints". If any -# of these elements is zero, the test is -# skipped. This attribute is optional; default is {} -# body - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. This attribute is optional; -# default is {} -# result - Expected result from script. This attribute is -# optional; default is {}. -# output - Expected output sent to stdout. This attribute -# is optional; default is {}. -# errorOutput - Expected output sent to stderr. This attribute -# is optional; default is {}. -# returnCodes - Expected return codes. This attribute is -# optional; default is {0 2}. -# setup - Code to run before $script (above). This -# attribute is optional; default is {}. -# cleanup - Code to run after $script (above). This -# attribute is optional; default is {}. -# match - specifies type of matching to do on result, -# output, errorOutput; this must be one of: exact, -# glob, regexp. default is exact. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# -# Results: -# 0 if the command ran successfully; 1 otherwise. -# -# Side effects: -# None. -# - -proc tcltest::test {name description args} { - DebugPuts 3 "Test $name $args" - - incr tcltest::testLevel - - # Pre-define everything to null except output and errorOutput. We - # determine whether or not to trap output based on whether or not these - # variables (output & errorOutput) are defined. - foreach item {constraints setup cleanup body result returnCodes match} { - set $item {} - } - - # Set the default match mode - set match exact - - # Set the default match values for return codes (0 is the standard expected - # return value if everything went well; 2 represents 'return' being used in - # the test script). - set returnCodes [list 0 2] - - # The old test format can't have a 3rd argument (constraints or script) - # that starts with '-'. - if {[llength $args] == 0} { - puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}" - incr tcltest::testLevel -1 - return 1 - } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} { - - if {[llength $args] == 1} { - set list [substArguments [lindex $args 0]] - foreach {element value} $list { - set testAttributes($element) $value - } - foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { - if {[info exists testAttributes([subst -$item])]} { - set testAttributes([subst -$item]) \ - [uplevel concat $testAttributes([subst -$item])] - } - } - } else { - array set testAttributes $args - } - - set validFlags {-setup -cleanup -body -result -returnCodes -match \ - -output -errorOutput -constraints} - - foreach flag [array names testAttributes] { - if {[lsearch -exact $validFlags $flag] == -1} { - puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test" - incr tcltest::testLevel -1 - return 1 - } - } - - # store whatever the user gave us - foreach item [array names testAttributes] { - set [string trimleft $item "-"] $testAttributes($item) - } - - # Check the values supplied for -match - if {[lsearch {regexp glob exact} $match] == -1} { - puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}" - incr tcltest::testLevel -1 - return 1 - } - - # Replace symbolic valies supplied for -returnCodes - regsub -nocase normal $returnCodes 0 returnCodes - regsub -nocase error $returnCodes 1 returnCodes - regsub -nocase return $returnCodes 2 returnCodes - regsub -nocase break $returnCodes 3 returnCodes - regsub -nocase continue $returnCodes 4 returnCodes - } else { - # This is parsing for the old test command format; it is here for - # backward compatibility. - set result [lindex $args end] - if {[llength $args] == 2} { - set body [lindex $args 0] - } elseif {[llength $args] == 3} { - set constraints [lindex $args 0] - set body [lindex $args 1] - } else { - puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}" - incr tcltest::testLevel -1 - return 1 - } - } - - set setupFailure 0 - set cleanupFailure 0 - - # Run the setup script - if {[catch {uplevel $setup} setupMsg]} { - set setupFailure 1 - } - - # run the test script - set command [list tcltest::runTest $name $description $body \ - $result $constraints] - if {!$setupFailure} { - if {[info exists output] || [info exists errorOutput]} { - set testResult [uplevel tcltest::testEval [list $command] 0] - } else { - set testResult [uplevel tcltest::testEval [list $command] 1] - } - } else { - set testResult setupFailure - } - - # Run the cleanup code - if {[catch {uplevel $cleanup} cleanupMsg]} { - set cleanupFailure 1 - } - - # If testResult is an empty list, then the test was skipped - if {$testResult != {}} { - set coreFailure 0 - set coreMsg "" - # check for a core file first - if one was created by the test, then - # the test failed - if {$tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - if {[file exists [file join [tcltest::workingDirectory] core]]} { - # There's only a test failure if there is a core file and (1) - # there previously wasn't one or (2) the new one is different - # from the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join [tcltest::workingDirectory] core]]} { - set coreFailure 1 - } - } else { - set coreFailure 1 - } - - if {($tcltest::preserveCore > 1) && ($coreFailure)} { - append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]" - catch {file rename -force \ - [file join [tcltest::workingDirectory] core] \ - [file join $tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - append coreMsg "\nError: Problem renaming core file: $msg" - } - } - } - array set tcl_platform $currentTclPlatform - } - - set actualAnswer [lindex $testResult 0] - set code [lindex $testResult end] - - # If expected output/error strings exist, we have to compare - # them. If the comparison fails, then so did the test. - set outputFailure 0 - set errorFailure 0 - if {[info exists output]} { - set outputFailure [expr ![compareStrings $tcltest::outData \ - $output $match]] - } - if {[info exists errorOutput]} { - set errorFailure [expr ![compareStrings $tcltest::errData \ - $errorOutput $match]] - } - - set testFailed 1 - set codeFailure 0 - set scriptFailure 0 - - # check if the return code matched the expected return code - if {[lsearch -exact $returnCodes $code] == -1} { - set codeFailure 1 - } - - # check if the answer matched the expected answer - if {[compareStrings $actualAnswer $result $match] == 0} { - set scriptFailure 1 - } - - # if we didn't experience any failures, then we passed - if {!($setupFailure || $cleanupFailure || $coreFailure || \ - $outputFailure || $errorFailure || $codeFailure || \ - $scriptFailure)} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Passed) - if {[tcltest::isVerbose pass]} { - puts [outputChannel] "++++ $name PASSED" - } - } - set testFailed 0 - } - - if {$testFailed} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Failed) - } - set tcltest::currentFailure true - if {![tcltest::isVerbose body]} { - set body "" - } - puts [outputChannel] "\n==== $name [string trim $description] FAILED" - if {$body != ""} { - puts [outputChannel] "==== Contents of test case:" - puts [outputChannel] $body - } - if {$setupFailure} { - puts [outputChannel] "---- Test setup failed:\n$setupMsg" - } - if {$scriptFailure} { - puts [outputChannel] "---- Result was:\n$actualAnswer" - puts [outputChannel] "---- Result should have been ($match matching):\n$result" - } - if {$codeFailure} { - switch -- $code { - 0 { set msg "Test completed normally" } - 1 { set msg "Test generated error" } - 2 { set msg "Test generated return exception" } - 3 { set msg "Test generated break exception" } - 4 { set msg "Test generated continue exception" } - default { set msg "Test generated exception" } - } - puts [outputChannel] "---- $msg; Return code was: $code" - puts [outputChannel] "---- Return code should have been one of: $returnCodes" - if {[tcltest::isVerbose error]} { - if {[info exists ::errorInfo]} { - puts [outputChannel] "---- errorInfo: $::errorInfo" - puts [outputChannel] "---- errorCode: $::errorCode" - } - } - } - if {$outputFailure} { - puts [outputChannel] "---- Output was:\n$tcltest::outData" - puts [outputChannel] "---- Output should have been ($match matching):\n$output" - } - if {$errorFailure} { - puts [outputChannel] "---- Error output was:\n$tcltest::errData" - puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput" - } - if {$cleanupFailure} { - puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" - } - if {$coreFailure} { - puts [outputChannel] "---- Core file produced while running test! $coreMsg" - } - puts [outputChannel] "==== $name FAILED\n" - - } - } - - incr tcltest::testLevel -1 - return 0 -} - - -# runTest -- -# -# This is the defnition of the version 1.0 test routine for tcltest. It is -# provided here for backward compatibility. It is also used as the 'backbone' -# of the test procedure, as in, this is where all the work really gets done. -# -# This procedure runs a test and prints an error message if the test fails. -# If tcltest::verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# tcltest::match variable, if it matches an element in -# tcltest::skip, or if one of the elements of "constraints" turns -# out not to be true. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "tcltest::testConstraints". If any of these -# elements is zero, the test is skipped. -# This argument may be omitted. -# script - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. -# expectedAnswer - Expected result from script. -# -# Behavior depends on the value of testLevel; if testLevel is 1 (top level), -# then events are logged and we track the number of tests run/skipped and why. -# Otherwise, we don't track this information. -# -# Results: -# empty list if test is skipped; otherwise returns list containing -# actual returned value from the test and the return code. -# -# Side Effects: -# none. -# - -proc tcltest::runTest {name description script expectedAnswer constraints} { - - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Total) - } - - # skip the test if it's name matches an element of skip - foreach pattern $tcltest::skip { - if {[string match $pattern $name]} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip} - } - return - } - } - - # skip the test if it's name doesn't match any element of match - if {[llength $tcltest::match] > 0} { - set ok 0 - foreach pattern $tcltest::match { - if {[string match $pattern $name]} { - set ok 1 - break - } - } - if {!$ok} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch} - } - return - } - } - - DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints" - - if {$constraints == {}} { - # If we're limited to the listed constraints and there aren't any - # listed, then we shouldn't run the test. - if {$tcltest::limitConstraints} { - tcltest::AddToSkippedBecause userSpecifiedLimitConstraint - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - } - return - } - } else { - # "constraints" argument exists; - # make sure that the constraints are satisfied. - - set doTest 0 - if {[string match {*[$\[]*} $constraints] != 0} { - # full expression, e.g. {$foo > [info tclversion]} - catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { - # something like {a || b} should be turned into - # $tcltest::testConstraints(a) || $tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$tcltest::testConstraints(&)} c - catch {set doTest [eval expr $c]} - } else { - # just simple constraints such as {unixOnly fonts}. - set doTest 1 - foreach constraint $constraints { - if {(![info exists tcltest::testConstraints($constraint)]) \ - || (!$tcltest::testConstraints($constraint))} { - set doTest 0 - - # store the constraint that kept the test from running - set constraints $constraint - break - } - } - } - - if {$doTest == 0} { - if {[tcltest::isVerbose skip]} { - puts [outputChannel] "++++ $name SKIPPED: $constraints" - } - - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - tcltest::AddToSkippedBecause $constraints - } - return - } - } - - # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with - # tcl_platform. - - if {$tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - array set tcl_platform $tcltest::originalTclPlatform - if {[file exists [file join [tcltest::workingDirectory] core]]} { - set coreModTime [file mtime [file join \ - [tcltest::workingDirectory] core]] - } - array set tcl_platform $currentTclPlatform - } - - # If there is no "memory" command (because memory debugging isn't - # enabled), then don't attempt to use the command. - - if {[info commands memory] != {}} { - memory tag $name - } - - if {[tcltest::isVerbose start]} { - puts [outputChannel] "---- $name start" - flush [outputChannel] - } - - set code [catch {uplevel $script} actualAnswer] - - return [list $actualAnswer $code] -} - -##################################################################### - -# tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} { - proc tcltest::cleanupTestsHook {} {} -} - -# tcltest::cleanupTests -- -# -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. -# -# Print the names of the files created without the makeFile command -# since the tests were invoked. -# -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). -# -# Arguments: -# calledFromAllFile - if 0, behave as if we are running a single test file -# within an entire suite of tests. if we aren't running a single test -# file, then don't report status. check for new files created during the -# test run and report on them. if 1, report collated status from all the -# test file runs. -# -# Results: -# None. -# -# Side Effects: -# None -# - -proc tcltest::cleanupTests {{calledFromAllFile 0}} { - - set testFileName [file tail [info script]] - - # Call the cleanup hook - tcltest::cleanupTestsHook - - # Remove files and directories created by the :tcltest::makeFile and - # tcltest::makeDirectory procedures. - # Record the names of files in tcltest::workingDirectory that were not - # pre-existing, and associate them with the test file that created them. - - if {!$calledFromAllFile} { - foreach file $tcltest::filesMade { - if {[file exists $file]} { - catch {file delete -force $file} - } - } - set currentFiles {} - foreach file [glob -nocomplain \ - [file join $tcltest::temporaryDirectory *]] { - lappend currentFiles [file tail $file] - } - set newFiles {} - foreach file $currentFiles { - if {[lsearch -exact $tcltest::filesExisted $file] == -1} { - lappend newFiles $file - } - } - set tcltest::filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set tcltest::createdNewFiles($testFileName) $newFiles - } - } - - if {$calledFromAllFile || $tcltest::testSingleFile} { - - # print stats - - puts -nonewline [outputChannel] "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline [outputChannel] \ - "\t$index\t$tcltest::numTests($index)" - } - puts [outputChannel] "" - - # print number test files sourced - # print names of files that ran tests which failed - - if {$calledFromAllFile} { - puts [outputChannel] \ - "Sourced $tcltest::numTestFiles Test Files." - set tcltest::numTestFiles 0 - if {[llength $tcltest::failFiles] > 0} { - puts [outputChannel] \ - "Files with failing tests: $tcltest::failFiles" - set tcltest::failFiles {} - } - } - - # if any tests were skipped, print the constraints that kept them - # from running. - - set constraintList [array names tcltest::skippedBecause] - if {[llength $constraintList] > 0} { - puts [outputChannel] \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts [outputChannel] \ - "\t$tcltest::skippedBecause($constraint)\t$constraint" - unset tcltest::skippedBecause($constraint) - } - } - - # report the names of test files in tcltest::createdNewFiles, and - # reset the array to be empty. - - set testFilesThatTurded [lsort [array names tcltest::createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts [outputChannel] "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts [outputChannel] \ - "\t$testFile:\t$tcltest::createdNewFiles($testFile)" - unset tcltest::createdNewFiles($testFile) - } - } - - # reset filesMade, filesExisted, and numTests - - set tcltest::filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set tcltest::numTests($index) 0 - } - - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && ![info exists tcl_interactive]} { - exit - } - } else { - - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed - - incr tcltest::numTestFiles - if {($tcltest::currentFailure) && \ - ([lsearch -exact $tcltest::failFiles $testFileName] == -1)} { - lappend tcltest::failFiles $testFileName - } - set tcltest::currentFailure false - - # restore the environment to the state it was in before this package - # was loaded - - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists tcltest::originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { - if {$::env($index) != $tcltest::originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $tcltest::originalEnv($index) - } - } - } - foreach index [array names tcltest::originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $tcltest::originalEnv($index) - } - } - if {[llength $newEnv] > 0} { - puts [outputChannel] \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts [outputChannel] \ - "env array elements changed:\t$changedEnv" - } - if {[llength $removedEnv] > 0} { - puts [outputChannel] \ - "env array elements removed:\t$removedEnv" - } - - set changedTclPlatform {} - foreach index [array names tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $tcltest::originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $tcltest::originalTclPlatform($index) - } - } - if {[llength $changedTclPlatform] > 0} { - puts [outputChannel] \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } - - if {[file exists [file join [tcltest::workingDirectory] core]]} { - if {$tcltest::preserveCore > 1} { - puts "rename core file (> 1)" - puts [outputChannel] "produced core file! \ - Moving file to: \ - [file join $tcltest::temporaryDirectory core-$name]" - catch {file rename -force \ - [file join [tcltest::workingDirectory] core] \ - [file join $tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - tcltest::PrintError "Problem renaming file: $msg" - } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists tcltest::coreModificationTime]} { - if {$tcltest::coreModificationTime != [file mtime \ - [file join [tcltest::workingDirectory] core]]} { - puts [outputChannel] "A core file was created!" - } - } else { - puts [outputChannel] "A core file was created!" - } - } - } - } - flush [outputChannel] - flush [errorChannel] - return -} - -##################################################################### - -# Procs that determine which tests/test files to run - -# tcltest::getMatchingFiles -# -# Looks at the patterns given to match and skip files -# and uses them to put together a list of the tests that will be run. -# -# Arguments: -# directory to search -# -# Results: -# The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. It is used in runAllTests. -# -# Side Effects: -# None - -proc tcltest::getMatchingFiles { {searchDirectory ""} } { - if {[llength [info level 0]] == 1} { - set searchDirectory [tcltest::testsDirectory] - } - set matchingFiles {} - - # Find the matching files in the list of directories and then remove the - # ones that match the skip pattern - foreach directory $searchDirectory { - set matchFileList {} - foreach match $tcltest::matchFiles { - set matchFileList [concat $matchFileList \ - [glob -nocomplain [file join $directory $match]]] - } - if {[string compare {} $tcltest::skipFiles]} { - set skipFileList {} - foreach skip $tcltest::skipFiles { - set skipFileList [concat $skipFileList \ - [glob -nocomplain [file join $directory $skip]]] - } - foreach file $matchFileList { - # Only include files that don't match the skip pattern and - # aren't SCCS lock files. - if {([lsearch -exact $skipFileList $file] == -1) && \ - (![string match l.*.test [file tail $file]])} { - lappend matchingFiles $file - } - } - } else { - set matchingFiles [concat $matchingFiles $matchFileList] - } - } - if {[string equal $matchingFiles {}]} { - tcltest::PrintError "No test files remain after applying \ - your match and skip patterns!" - } - return $matchingFiles -} - -# tcltest::getMatchingDirectories -- -# -# Looks at the patterns given to match and skip directories and uses them -# to put together a list of the test directories that we should attempt -# to run. (Only subdirectories containing an "all.tcl" file are put into -# the list.) -# -# Arguments: -# root directory from which to search -# -# Results: -# The constructed list is returned to the user. This is used in the -# primary all.tcl file. Lower-level all.tcl files should use the -# tcltest::testAllFiles proc instead. -# -# Side Effects: -# None. - -proc tcltest::getMatchingDirectories {rootdir} { - set matchingDirs {} - set matchDirList {} - # Find the matching directories in tcltest::testsDirectory and then - # remove the ones that match the skip pattern - foreach match $tcltest::matchDirectories { - foreach file [glob -nocomplain [file join $rootdir $match]] { - if {([file isdirectory $file]) && ($file != $rootdir)} { - set matchDirList [concat $matchDirList \ - [tcltest::getMatchingDirectories $file]] - if {[file exists [file join $file all.tcl]]} { - set matchDirList [concat $matchDirList $file] - } - } - } - } - if {$tcltest::skipDirectories != {}} { - set skipDirs {} - foreach skip $tcltest::skipDirectories { - set skipDirs [concat $skipDirs \ - [glob -nocomplain [file join $tcltest::testsDirectory \ - $skip]]] - } - foreach dir $matchDirList { - # Only include directories that don't match the skip pattern - if {[lsearch -exact $skipDirs $dir] == -1} { - lappend matchingDirs $dir - } - } - } else { - set matchingDirs [concat $matchingDirs $matchDirList] - } - if {$matchingDirs == {}} { - DebugPuts 1 "No test directories remain after applying match and skip patterns!" - } - return $matchingDirs -} - -# tcltest::runAllTests -- -# -# prints output and sources test files according to the match and skip -# patterns provided. after sourcing test files, it goes on to source -# all.tcl files in matching test subdirectories. -# -# Arguments: -# shell being tested -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::runAllTests { {shell ""} } { - global argv - - if {[llength [info level 0]] == 1} { - set shell [tcltest::interpreter] - } - - set tcltest::testSingleFile false - - puts [outputChannel] "Tests running in interp: $shell" - puts [outputChannel] "Tests located in: $tcltest::testsDirectory" - puts [outputChannel] "Tests running in: [tcltest::workingDirectory]" - puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory" - if {[tcltest::singleProcess]} { - puts [outputChannel] "Test files sourced into current interpreter" - } else { - puts [outputChannel] "Test files run in separate interpreters" - } - if {[llength $tcltest::skip] > 0} { - puts [outputChannel] "Skipping tests that match: $tcltest::skip" - } - if {[llength $tcltest::match] > 0} { - puts [outputChannel] "Only running tests that match: $tcltest::match" - } - - if {[llength $tcltest::skipFiles] > 0} { - puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles" - } - if {[llength $tcltest::matchFiles] > 0} { - puts [outputChannel] "Only running test files that match: $tcltest::matchFiles" - } - - set timeCmd {clock format [clock seconds]} - puts [outputChannel] "Tests began at [eval $timeCmd]" - - # Run each of the specified tests - foreach file [lsort [tcltest::getMatchingFiles]] { - set tail [file tail $file] - puts [outputChannel] $tail - - if {$tcltest::singleProcess} { - incr tcltest::numTestFiles - uplevel [list source $file] - } else { - # Change to the tests directory so the value of the following - # variable is set correctly when we spawn the child test processes - cd $tcltest::testsDirectory - set cmd [concat [list | $shell $file] [split $argv]] - if {[catch { - incr tcltest::numTestFiles - set pipeFd [open $cmd "r"] - while {[gets $pipeFd line] >= 0} { - if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - incr tcltest::numTests($index) [set $index] - } - if {$Failed > 0} { - lappend tcltest::failFiles $testFile - } - } elseif {[regexp {^Number of tests skipped for each constraint:|^\t(\d+)\t(.+)$} $line match skipped constraint]} { - if {$match != "Number of tests skipped for each constraint:"} { - tcltest::AddToSkippedBecause $constraint $skipped - } - } else { - puts [outputChannel] $line - } - } - close $pipeFd - } msg]} { - # Print results to tcltest::outputChannel. - puts [outputChannel] "Test file error: $msg" - # append the name of the test to a list to be reported later - lappend testFileFailures $file - } - } - } - - # cleanup - puts [outputChannel] "\nTests ended at [eval $timeCmd]" - tcltest::cleanupTests 1 - if {[info exists testFileFailures]} { - puts [outputChannel] "\nTest files exiting with errors: \n" - foreach file $testFileFailures { - puts " [file tail $file]\n" - } - } - - # Checking for subdirectories in which to run tests - foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] { - set dir [file tail $directory] - puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - puts [outputChannel] "$dir test began at [eval $timeCmd]\n" - - uplevel "source [file join $directory all.tcl]" - - set endTime [eval $timeCmd] - puts [outputChannel] "\n$dir test ended at $endTime" - puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - } - return -} - -##################################################################### - -# Test utility procs - not used in tcltest, but may be useful for testing. - -# tcltest::loadTestedCommands -- -# -# Uses the specified script to load the commands to test. Allowed to -# be empty, as the tested commands could have been compiled into the -# interpreter. -# -# Arguments -# none -# -# Results -# none -# -# Side Effects: -# none. - -proc tcltest::loadTestedCommands {} { - if {$tcltest::loadScript == {}} { - return - } - - return [uplevel $tcltest::loadScript] -} - -# tcltest::saveState -- -# -# Save information regarding what procs and variables exist. -# -# Arguments: -# none -# -# Results: -# Modifies the variable tcltest::saveState -# -# Side effects: -# None. - -proc tcltest::saveState {} { - uplevel {set tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "tcltest::saveState: $tcltest::saveState" - return -} - -# tcltest::restoreState -- -# -# Remove procs and variables that didn't exist before the call to -# tcltest::saveState. -# -# Arguments: -# none -# -# Results: -# Removes procs and variables from your environment if they don't exist -# in the tcltest::saveState variable. -# -# Side effects: -# None. - -proc tcltest::restoreState {} { - foreach p [info procs] { - if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \ - (![string match "*tcltest::$p" [namespace origin $p]])} { - - DebugPuts 2 "tcltest::restoreState: Removing proc $p" - rename $p {} - } - } - foreach p [uplevel {info vars}] { - if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} { - DebugPuts 2 "tcltest::restoreState: Removing variable $p" - uplevel "catch {unset $p}" - } - } - return -} - -# tcltest::normalizeMsg -- -# -# Removes "extra" newlines from a string. -# -# Arguments: -# msg String to be modified -# -# Results: -# string with extra newlines removed -# -# Side effects: -# None. - -proc tcltest::normalizeMsg {msg} { - regsub "\n$" [string tolower $msg] "" msg - regsub -all "\n\n" $msg "\n" msg - regsub -all "\n\}" $msg "\}" msg - return $msg -} - -# tcltest::makeFile -- -# -# Create a new file with the name <name>, and write <contents> to it. -# -# If this file hasn't been created via makeFile since the last time -# cleanupTests was called, add it to the $filesMade list, so it will -# be removed by the next call to cleanupTests. -# -# Arguments: -# contents content of the new file -# name name of the new file -# directory directory name for new file -# -# Results: -# absolute path to the file created -# -# Side effects: -# None. - -proc tcltest::makeFile {contents name {directory ""}} { - global tcl_platform - - if {[llength [info level 0]] == 3} { - set directory [tcltest::temporaryDirectory] - } - - set fullName [file join $directory $name] - - DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" - - set fd [open $fullName w] - - fconfigure $fd -translation lf - - if {[string equal [string index $contents end] "\n"]} { - puts -nonewline $fd $contents - } else { - puts $fd $contents - } - close $fd - - if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { - lappend tcltest::filesMade $fullName - } - return $fullName -} - -# tcltest::removeFile -- -# -# Removes the named file from the filesystem -# -# Arguments: -# name file to be removed -# directory directory from which to remove file -# -# Results: -# return value from [file delete] -# -# Side effects: -# None. - -proc tcltest::removeFile {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::removeFile: removing $fullName" - return [file delete $fullName] -} - -# tcltest::makeDirectory -- -# -# Create a new dir with the name <name>. -# -# If this dir hasn't been created via makeDirectory since the last time -# cleanupTests was called, add it to the $directoriesMade list, so it will -# be removed by the next call to cleanupTests. -# -# Arguments: -# name name of the new directory -# directory directory in which to create new dir -# -# Results: -# absolute path to the directory created -# -# Side effects: -# None. - -proc tcltest::makeDirectory {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::makeDirectory: creating $fullName" - file mkdir $fullName - if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { - lappend tcltest::filesMade $fullName - } - return $fullName -} - -# tcltest::removeDirectory -- -# -# Removes a named directory from the file system. -# -# Arguments: -# name Name of the directory to remove -# directory Directory from which to remove -# -# Results: -# return value from [file delete] -# -# Side effects: -# None - -proc tcltest::removeDirectory {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" - return [file delete -force $fullName] -} - -# tcltest::viewFile -- -# -# reads the content of a file and returns it -# -# Arguments: -# name of the file to read -# directory in which file is located -# -# Results: -# content of the named file -# -# Side effects: -# None. - -proc tcltest::viewFile {name {directory ""}} { - global tcl_platform - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ([tcltest::testConstraint unixExecs] == 0)} { - set f [open $fullName] - set data [read -nonewline $f] - close $f - return $data - } else { - return [exec cat $fullName] - } - return -} - -# tcltest::bytestring -- -# -# Construct a string that consists of the requested sequence of bytes, -# as opposed to a string of properly formed UTF-8 characters. -# This allows the tester to -# 1. Create denormalized or improperly formed strings to pass to C procedures -# that are supposed to accept strings with embedded NULL bytes. -# 2. Confirm that a string result has a certain pattern of bytes, for instance -# to confirm that "\xe0\0" in a Tcl script is stored internally in -# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". -# -# Generally, it's a bad idea to examine the bytes in a Tcl string or to -# construct improperly formed strings in this manner, because it involves -# exposing that Tcl uses UTF-8 internally. -# -# Arguments: -# string being converted -# -# Results: -# result fom encoding -# -# Side effects: -# None - -proc tcltest::bytestring {string} { - return [encoding convertfrom identity $string] -} - -# tcltest::openfiles -- -# -# used in io tests, uses testchannel -# -# Arguments: -# None. -# -# Results: -# ??? -# -# Side effects: -# None. - -proc tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} - } - return $result -} - -# tcltest::leakfiles -- -# -# used in io tests, uses testchannel -# -# Arguments: -# None. -# -# Results: -# ??? -# -# Side effects: -# None. - -proc tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} - } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p - } - } - return $leak -} - -# -# Internationalization / ISO support procs -- dl -# - -# tcltest::set_iso8859_1_locale -- -# -# used in cmdIL.test, uses testlocale -# -# Arguments: -# None. -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::set_iso8859_1_locale {} { - if {[info commands testlocale] != ""} { - set tcltest::previousLocale [testlocale ctype] - testlocale ctype $tcltest::isoLocale - } - return -} - -# tcltest::restore_locale -- -# -# used in cmdIL.test, uses testlocale -# -# Arguments: -# None. -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::restore_locale {} { - if {[info commands testlocale] != ""} { - testlocale ctype $tcltest::previousLocale - } - return -} - -# tcltest::threadReap -- -# -# Kill all threads except for the main thread. -# Do nothing if testthread is not defined. -# -# Arguments: -# none. -# -# Results: -# Returns the number of existing threads. -# -# Side Effects: -# none. -# - -proc tcltest::threadReap {} { - if {[info commands testthread] != {}} { - - # testthread built into tcltest - - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != $tcltest::mainThread} { - catch {testthread send -async $tid {testthread exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - testthread errorproc ThreadError - return [llength [testthread names]] - } elseif {[info commands thread::id] != {}} { - - # Thread extension - - thread::errorproc ThreadNullError - while {[llength [thread::names]] > 1} { - foreach tid [thread::names] { - if {$tid != $tcltest::mainThread} { - catch {thread::send -async $tid {thread::exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - thread::errorproc ThreadError - return [llength [thread::names]] - } else { - return 1 - } - return 0 -} - -# Initialize the constraints and set up command line arguments -namespace eval tcltest { - # Ensure that we have a minimal auto_path so we don't pick up extra junk. - set ::auto_path [list [info library]] - - tcltest::initConstraints - if {[namespace children [namespace current]] == {}} { - tcltest::processCmdLineArgs - } - - # Save the names of files that already exist in - # the output directory. - foreach file [glob -nocomplain \ - [file join $tcltest::temporaryDirectory *]] { - lappend tcltest::filesExisted [file tail $file] - } -} - -package provide tcltest 2.0 - diff --git a/library/tcltest1.0/pkgIndex.tcl b/library/tcltest1.0/pkgIndex.tcl index e3746e2..da93644 100644 --- a/library/tcltest1.0/pkgIndex.tcl +++ b/library/tcltest1.0/pkgIndex.tcl @@ -8,5 +8,4 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded tcltest 1.0 [list source [file join $dir tcltest.tcl]] -package ifneeded tcltest 2.0 [list source [file join $dir tcltest2.tcl]] +package ifneeded tcltest 2.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl index 63639e3..80f80c7 100644 --- a/library/tcltest1.0/tcltest.tcl +++ b/library/tcltest1.0/tcltest.tcl @@ -1,7 +1,7 @@ # tcltest.tcl -- # # This file contains support code for the Tcl test suite. It -# defines the ::tcltest namespace and finds and defines the output +# defines the tcltest namespace and finds and defines the output # directory, constraints available, output and error channels, etc. used # by Tcl tests. See the tcltest man page for more details. # @@ -10,11 +10,10 @@ # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.27 2000/09/06 18:50:15 hobbs Exp $ - -package provide tcltest 1.0 +# RCS: @(#) $Id: tcltest.tcl,v 1.28 2000/10/24 22:30:32 jenn Exp $ # create the "tcltest" namespace for all testing variables and procedures @@ -23,19 +22,25 @@ namespace eval tcltest { # Export the public tcltest procs set procList [list test cleanupTests saveState restoreState \ normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring safeFetch threadReap getMatchingFiles \ - loadTestedCommands normalizePath] + viewFile bytestring threadReap debug testConstraint \ + limitConstraints loadTestedCommands normalizePath verbose match \ + skip matchFiles skipFiles preserveCore loadScript loadFile \ + mainThread workingDirectory singleProcess interpreter runAllTests \ + outputChannel outputFile errorChannel \ + errorFile temporaryDirectory testsDirectory matchDirectories \ + skipDirectories ] foreach proc $procList { namespace export $proc } - # ::tcltest::verbose defaults to "b" + # tcltest::verbose defaults to {body} if {![info exists verbose]} { - variable verbose "b" + variable verbose {body} } # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory + # matchFiles, which defaults to all .test files in the testsDirectory and + # matchDirectories, which defaults to all directories. if {![info exists match]} { variable match {} @@ -49,6 +54,12 @@ namespace eval tcltest { if {![info exists skipFiles]} { variable skipFiles {} } + if {![info exists matchDirectories]} { + variable matchDirectories {*} + } + if {![info exists skipDirectories]} { + variable skipDirectories {} + } # By default, don't save core files if {![info exists preserveCore]} { @@ -59,11 +70,17 @@ namespace eval tcltest { if {![info exists outputChannel]} { variable outputChannel stdout } + if {![info exists outputFile]} { + variable outputFile stdout + } # errors go to stderr by default if {![info exists errorChannel]} { variable errorChannel stderr } + if {![info exists errorFile]} { + variable errorFile stderr + } # debug output doesn't get printed by default; debug level 1 spits # up only the tests that were skipped because they didn't match or were @@ -81,9 +98,9 @@ namespace eval tcltest { variable parameters {} } - # Count the number of files tested (0 if all.tcl wasn't called). - # The all.tcl file will set testSingleFile to false, so stats will - # not be printed until all.tcl calls the cleanupTests proc. + # Count the number of files tested (0 if runAllTests wasn't called). + # runAllTests will set testSingleFile to false, so stats will + # not be printed until runAllTests calls the cleanupTests proc. # The currentFailure var stores the boolean value of whether the # current test file has had any failures. The failFiles list # stores the names of test files that had failures. @@ -103,9 +120,9 @@ namespace eval tcltest { # Tests should remove all files they create. The test suite will # check the current working dir for files created by the tests. - # ::tcltest::filesMade keeps track of such files created using the - # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. - # ::tcltest::filesExisted stores the names of pre-existing files. + # tcltest::filesMade keeps track of such files created using the + # tcltest::makeFile and tcltest::makeDirectory procedures. + # tcltest::filesExisted stores the names of pre-existing files. if {![info exists filesMade]} { variable filesMade {} @@ -114,43 +131,47 @@ namespace eval tcltest { variable filesExisted {} } - # ::tcltest::numTests will store test files as indices and the list + # tcltest::numTests will store test files as indices and the list # of files (that should not have been) left behind by the test files. if {![info exists createdNewFiles]} { variable createdNewFiles - array set ::tcltest::createdNewFiles {} + array set tcltest::createdNewFiles {} } - # initialize ::tcltest::numTests array to keep track fo the number of + # initialize tcltest::numTests array to keep track fo the number of # tests that pass, fail, and are skipped. if {![info exists numTests]} { variable numTests - array set ::tcltest::numTests \ + array set tcltest::numTests \ [list Total 0 Passed 0 Skipped 0 Failed 0] } - # initialize ::tcltest::skippedBecause array to keep track of + # initialize tcltest::skippedBecause array to keep track of # constraints that kept tests from running; a constraint name of # "userSpecifiedSkip" means that the test appeared on the list of tests # that matched the -skip value given to the flag; "userSpecifiedNonMatch" # means that the test didn't match the argument given to the -match flag; - # both of these constraints are counted only if ::tcltest::debug is set to + # both of these constraints are counted only if tcltest::debug is set to # true. if {![info exists skippedBecause]} { variable skippedBecause - array set ::tcltest::skippedBecause {} + array set tcltest::skippedBecause {} } - # initialize the ::tcltest::testConstraints array to keep track of valid + # initialize the tcltest::testConstraints array to keep track of valid # predefined constraints (see the explanation for the - # ::tcltest::initConstraints proc for more details). + # tcltest::initConstraints proc for more details). if {![info exists testConstraints]} { variable testConstraints - array set ::tcltest::testConstraints {} + array set tcltest::testConstraints {} + } + + if {![info exists constraintsSpecified]} { + variable constraintsSpecified {} } # Don't run only the constrained tests by default @@ -166,6 +187,11 @@ namespace eval tcltest { variable loadScript {} } + # and the filename of the script file, if it exists + if {![info exists loadFile]} { + variable loadFile {} + } + # tests that use threads need to know which is the main thread if {![info exists mainThread]} { @@ -181,10 +207,10 @@ namespace eval tcltest { if {![info exists originalEnv]} { variable originalEnv - array set ::tcltest::originalEnv [array get ::env] + array set tcltest::originalEnv [array get ::env] } - # Set ::tcltest::workingDirectory to [pwd]. The default output directory + # Set tcltest::workingDirectory to [pwd]. The default output directory # for Tcl tests is the working directory. if {![info exists workingDirectory]} { @@ -196,7 +222,7 @@ namespace eval tcltest { # Tests should not rely on the current working directory. # Files that are part of the test suite should be accessed relative to - # ::tcltest::testsDirectory. + # tcltest::testsDirectory. if {![info exists testsDirectory]} { set oldpwd [pwd] @@ -206,30 +232,40 @@ namespace eval tcltest { unset oldpwd } - # the variables and procs that existed when ::tcltest::saveState was + # Default is to run each test file in a separate process + if {![info exists singleProcess]} { + variable singleProcess 0 + } + + # the variables and procs that existed when tcltest::saveState was # called are stored in a variable of the same name if {![info exists saveState]} { variable saveState {} } - # Internationalization support + # Internationalization support -- used in tcltest::set_iso8859_1_locale + # and tcltest::restore_locale. Those commands are used in cmdIL.test. + if {![info exists previousLocale]} { + variable previousLocale + } + if {![info exists isoLocale]} { variable isoLocale fr - switch $tcl_platform(platform) { + switch -- $tcl_platform(platform) { "unix" { # Try some 'known' values for some platforms: switch -exact -- $tcl_platform(os) { "FreeBSD" { - set ::tcltest::isoLocale fr_FR.ISO_8859-1 + set tcltest::isoLocale fr_FR.ISO_8859-1 } HP-UX { - set ::tcltest::isoLocale fr_FR.iso88591 + set tcltest::isoLocale fr_FR.iso88591 } Linux - IRIX { - set ::tcltest::isoLocale fr + set tcltest::isoLocale fr } default { @@ -237,12 +273,12 @@ namespace eval tcltest { # define it to something else on your system #if you want to test those. - set ::tcltest::isoLocale iso_8859_1 + set tcltest::isoLocale iso_8859_1 } } } "windows" { - set ::tcltest::isoLocale French + set tcltest::isoLocale French } } } @@ -250,7 +286,7 @@ namespace eval tcltest { # Set the location of the execuatble if {![info exists tcltest]} { variable tcltest [info nameofexecutable] - } + } # save the platform information so it can be restored later if {![info exists originalTclPlatform]} { @@ -259,29 +295,34 @@ namespace eval tcltest { # If a core file exists, save its modification time. if {![info exists coreModificationTime]} { - if {[file exists [file join $::tcltest::workingDirectory core]]} { + if {[file exists [file join $tcltest::workingDirectory core]]} { variable coreModificationTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + $tcltest::workingDirectory core]] } } - # Tcl version numbers - if {![info exists version]} { - variable version 8.4 + # stdout and stderr buffers for use when we want to store them + if {![info exists outData]} { + variable outData {} } - if {![info exists patchLevel]} { - variable patchLevel 8.4a2 + if {![info exists errData]} { + variable errData {} } + + # keep track of test level for nested test commands + variable testLevel 0 } -# ::tcltest::Debug* -- +##################################################################### + +# tcltest::Debug* -- # # Internal helper procedures to write out debug information # dependent on the chosen level. A test shell may overide # them, f.e. to redirect the output into a different # channel, or even into a GUI. -# ::tcltest::DebugPuts -- +# tcltest::DebugPuts -- # # Prints the specified string if the current debug level is # higher than the provided level argument. @@ -293,15 +334,19 @@ namespace eval tcltest { # Results: # Prints the string. Nothing else is allowed. # +# Side Effects: +# None. +# -proc ::tcltest::DebugPuts {level string} { +proc tcltest::DebugPuts {level string} { variable debug if {$debug >= $level} { puts $string } + return } -# ::tcltest::DebugPArray -- +# tcltest::DebugPArray -- # # Prints the contents of the specified array if the current # debug level is higher than the provided level argument @@ -313,17 +358,21 @@ proc ::tcltest::DebugPuts {level string} { # Results: # Prints the contents of the array. Nothing else is allowed. # +# Side Effects: +# None. +# -proc ::tcltest::DebugPArray {level arrayvar} { +proc tcltest::DebugPArray {level arrayvar} { variable debug if {$debug >= $level} { catch {upvar $arrayvar $arrayvar} parray $arrayvar } + return } -# ::tcltest::DebugDo -- +# tcltest::DebugDo -- # # Executes the script if the current debug level is greater than # the provided level argument @@ -335,16 +384,779 @@ proc ::tcltest::DebugPArray {level arrayvar} { # Results: # Arbitrary side effects, dependent on the executed script. # +# Side Effects: +# None. +# -proc ::tcltest::DebugDo {level script} { +proc tcltest::DebugDo {level script} { variable debug if {$debug >= $level} { uplevel $script } + return +} + +##################################################################### + +# tcltest::CheckDirectory -- +# +# This procedure checks whether the specified path is a readable +# and/or writable directory. If one of the conditions is not +# satisfied an error is printed and the application aborted. The +# procedure assumes that the caller already checked the existence +# of the path. +# +# Arguments +# rw Information what attributes to check. Allowed values: +# r, w, rw, wr. If 'r' is part of the value the directory +# must be readable. 'w' associates to 'writable'. +# dir The directory to check. +# errMsg The string to prepend to the actual error message before +# printing it. +# +# Results +# none +# +# Side Effects: +# None. +# + +proc tcltest::CheckDirectory {rw dir errMsg} { + # Allowed values for 'rw': r, w, rw, wr + + if {![file isdir $dir]} { + set msg "$errMsg \"$dir\" is not a directory" + error $msg + } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { + set msg "$errMsg \"$dir\" is not writeable" + error $msg + } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { + set msg "$errMsg \"$dir\" is not readable" + error $msg + } + return +} + +# tcltest::normalizePath -- +# +# This procedure resolves any symlinks in the path thus creating a +# path without internal redirection. It assumes that the incoming +# path is absolute. +# +# Arguments +# pathVar contains the name of the variable containing the path to modify. +# +# Results +# The path is modified in place. +# +# Side Effects: +# None. +# + +proc tcltest::normalizePath {pathVar} { + upvar $pathVar path + + set oldpwd [pwd] + catch {cd $path} + set path [pwd] + cd $oldpwd + return $path +} + + +# tcltest::MakeAbsolutePath -- +# +# This procedure checks whether the incoming path is absolute or not. +# Makes it absolute if it was not. +# +# Arguments +# pathVar contains the name of the variable containing the path to modify. +# prefix is optional, contains the path to use to make the other an +# absolute one. The current working directory is used if it was +# not specified. +# +# Results +# The path is modified in place. +# +# Side Effects: +# None. +# + +proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { + upvar $pathVar path + + if {![string equal [file pathtype $path] "absolute"]} { + if {$prefix == {}} { + set prefix [pwd] + } + + set path [file join $prefix $path] + } + return $path +} + +##################################################################### + +# tcltest::<variableName> +# +# Accessor functions for tcltest variables that can be modified externally. +# These are vars that could otherwise be modified using command line +# arguments to tcltest. + +# tcltest::verbose -- +# +# Set or return the verbosity level (tcltest::verbose) for tests. This +# determines what gets printed to the screen and when, with regard to the +# running of the tests. The proc does not check for invalid values. It +# assumes that a string that doesn't match its predefined keywords +# is a string containing letter-specified verbosity levels. +# +# Arguments: +# A string containing any combination of 'pbste' or a list of keywords +# (listed in parens) +# p = print output whenever a test passes (pass) +# b = print the body of the test when it fails (body) +# s = print when a test is skipped (skip) +# t = print when a test starts (start) +# e = print errorInfo and errorCode when a test encounters an error +# (error) +# +# Results: +# content of tcltest::verbose - this is always the character combination +# (pbste) instead of the list form. +# +# Side effects: +# None. + +proc tcltest::verbose { {level ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::verbose + } + if {[llength $level] > 1} { + set tcltest::verbose $level + } else { + if {[regexp {pass|body|skip|start|error} $level]} { + set tcltest::verbose $level + } else { + set levelList [split $level {}] + set tcltest::verbose [string map {p pass b body s skip t start e + error} $levelList] + } + } + return $tcltest::verbose +} + +# tcltest::isVerbose -- +# +# Returns true if argument is one of the verbosity levels currently being +# used; returns false otherwise. +# +# Arguments: +# level +# +# Results: +# boolean 1 (true) or 0 (false), depending on whether or not the level +# provided is one of the ones stored in tcltest::verbose. +# +# Side effects: +# None. + +proc tcltest::isVerbose {level} { + if {[lsearch -exact [tcltest::verbose] $level] == -1} { + return 0 + } + return 1 +} + + + +# tcltest::match -- +# +# Set or return the match patterns (tcltest::match) that determine which +# tests are run. +# +# Arguments: +# List containing match patterns (glob format) +# +# Results: +# content of tcltest::match +# +# Side effects: +# none + +proc tcltest::match { {matchList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::match + } + set tcltest::match $matchList +} + +# tcltest::skip -- +# +# Set or return the skip patterns (tcltest::skip) that determine which +# tests are skipped. +# +# Arguments: +# List containing skip patterns (glob format) +# +# Results: +# content of tcltest::skip +# +# Side effects: +# None. + +proc tcltest::skip { {skipList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skip + } + set tcltest::skip $skipList +} + +# tcltest::matchFiles -- +# +# set or return the match patterns for file sourcing +# +# Arguments: +# list containing match file list (glob format) +# +# Results: +# content of tcltest::matchFiles +# +# Side effects: +# None. + +proc tcltest::matchFiles { {matchFileList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::matchFiles + } + set tcltest::matchFiles $matchFileList +} + +# tcltest::skipFiles -- +# +# set or return the skip patterns for file sourcing +# +# Arguments: +# list containing the skip file list (glob format) +# +# Results: +# content of tcltest::skipFiles +# +# Side effects: +# None. + +proc tcltest::skipFiles { {skipFileList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skipFiles + } + set tcltest::skipFiles $skipFileList +} + + +# tcltest::matchDirectories -- +# +# set or return the list of directories for matching (glob pattern list) +# +# Arguments: +# list of glob patterns matching subdirectories of +# tcltest::testsDirectory +# +# Results: +# content of tcltest::matchDirectories +# +# Side effects: +# None. + +proc tcltest::matchDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::matchDirectories + } + set tcltest::matchDirectories $dirlist +} + +# tcltest::skipDirectories -- +# +# set or return the list of directories to skip (glob pattern list) +# +# Arguments: +# list of glob patterns matching directories to skip; these directories +# are subdirectories of tcltest::testsDirectory +# +# Results: +# content of tcltest::skipDirectories +# +# Side effects: +# None. + +proc tcltest::skipDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skipDirectories + } + set tcltest::skipDirectories $dirlist +} + +# tcltest::preserveCore -- +# +# set or return the core preservation level. This proc does not do any +# error checking for invalid values. +# +# Arguments: +# core level: +# '0' = don't do anything with core files (default) +# '1' = notify the user if core files are created +# '2' = save any core files produced during testing to +# tcltest::temporaryDirectory +# +# Results: +# content of tcltest::preserveCore +# +# Side effects: +# None. + +proc tcltest::preserveCore { {coreLevel ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::preserveCore + } + set tcltest::preserveCore $coreLevel +} + +# tcltest::outputChannel -- +# +# set or return the output file descriptor based on the supplied file +# name (where tcltest puts all of its output) +# +# Arguments: +# output file descriptor +# +# Results: +# file descriptor corresponding to supplied file name (or currently set +# file descriptor, if no new filename was supplied) - this is the content +# of tcltest::outputChannel +# +# Side effects: +# None. + +proc tcltest::outputChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::outputChannel + } + if {($filename == "stderr") || ($filename == "stdout")} { + set tcltest::outputChannel $filename + } else { + set tcltest::outputChannel [open $filename w] + } + return $tcltest::outputChannel +} + +# tcltest::outputFile -- +# +# set or return the output file name (where tcltest puts all of its +# output); calls tcltest::outputChannel to set the corresponding file +# descriptor +# +# Arguments: +# output file name +# +# Results: +# file name corresponding to supplied file name (or currently set +# file name, if no new filename was supplied) - this is the content +# of tcltest::outputFile +# +# Side effects: +# if the file name supplied is relative, it will be made absolute with +# respect to the predefined temporaryDirectory + +proc tcltest::outputFile { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::outputFile + } + if {($filename != "stderr") && ($filename != "stdout")} { + MakeAbsolutePath filename $tcltest::temporaryDirectory + } + tcltest::outputChannel $filename + set tcltest::outputFile $filename +} + +# tcltest::errorChannel -- +# +# set or return the error file descriptor based on the supplied file name +# (where tcltest sends all its errors) +# +# Arguments: +# error file name +# +# Results: +# file descriptor corresponding to the supplied file name (or currently +# set file descriptor, if no new filename was supplied) - this is the +# content of tcltest::errorChannel +# +# Side effects: +# opens the descriptor in w mode unless the filename is set to stderr or +# stdout + +proc tcltest::errorChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::errorChannel + } + if {($filename == "stderr") || ($filename == "stdout")} { + set tcltest::errorChannel $filename + } else { + set tcltest::errorChannel [open $filename w] + } + return $tcltest::errorChannel +} + +# tcltest::errorFile -- +# +# set or return the error file name; calls tcltest::errorChannel to set +# the corresponding file descriptor +# +# Arguments: +# error file name +# +# Results: +# content of tcltest::errorFile +# +# Side effects: +# if the file name supplied is relative, it will be made absolute with +# respect to the predefined temporaryDirectory + +proc tcltest::errorFile { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::errorFile + } + if {($filename != "stderr") && ($filename != "stdout")} { + MakeAbsolutePath filename $tcltest::temporaryDirectory + } + set tcltest::errorFile $filename + errorChannel $tcltest::errorFile + return $tcltest::errorFile +} + +# tcltest::debug -- +# +# set or return the debug level for tcltest; this proc does not check for +# invalid values +# +# Arguments: +# debug level: +# '0' = no debug output (default) +# '1' = skipped tests +# '2' = tcltest variables and supplied flags +# '3' = harness operations +# +# Results: +# content of tcltest::debug +# +# Side effects: +# None. + +proc tcltest::debug { {debugLevel ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::debug + } + set tcltest::debug $debugLevel +} + +# tcltest::testConstraint -- +# +# sets a test constraint to a value; to do multiple constraints, call +# this proc multiple times. also returns the value of the named +# constraint if no value was supplied. +# +# Arguments: +# constraint - name of the constraint +# value - new value for constraint (should be boolean) - if not supplied, +# this is a query +# +# Results: +# content of tcltest::testConstraints($constraint) +# +# Side effects: +# appends the constraint name to tcltest::constraintsSpecified + +proc tcltest::testConstraint {constraint {value ""}} { + DebugPuts 3 "entering testConstraint $constraint $value" + if {[llength [info level 0]] == 2} { + return $tcltest::testConstraints($constraint) + } + lappend tcltest::constraintsSpecified $constraint + set tcltest::testConstraints($constraint) $value +} + +# tcltest::constraintsSpecified -- +# +# returns a list of all the constraint names specified using +# testConstraint +# +# Arguments: +# None. +# +# Results: +# list of the constraint names in tcltest::constraintsSpecified +# +# Side effects: +# None. + +proc tcltest::constraintsSpecified {} { + return $tcltest::constraintsSpecified +} + +# tcltest::constraintList -- +# +# returns a list of all the constraint names +# +# Arguments: +# None. +# +# Results: +# list of the constraint names in tcltest::testConstraints +# +# Side effects: +# None. + +proc tcltest::constraintList {} { + return [array names tcltest::testConstraints] +} + +# tcltest::limitConstraints -- +# +# sets the limited constraints to tcltest::limitConstraints +# +# Arguments: +# list of constraint names +# +# Results: +# content of tcltest::limitConstraints +# +# Side effects: +# None. + +proc tcltest::limitConstraints { {constraintList ""} } { + DebugPuts 3 "entering limitConstraints $constraintList" + if {[llength [info level 0]] == 1} { + return $tcltest::limitConstraints + } + set tcltest::limitConstraints $constraintList + foreach elt [tcltest::constraintList] { + if {[lsearch -exact [tcltest::constraintsSpecified] $elt] == -1} { + tcltest::testConstraint $elt 0 + } + } + return $tcltest::limitConstraints +} + +# tcltest::loadScript -- +# +# sets the load script +# +# Arguments: +# script to be set +# +# Results: +# contents of tcltest::loadScript +# +# Side effects: +# None. + +proc tcltest::loadScript { {script ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::loadScript + } + set tcltest::loadScript $script +} + +# tcltest::loadFile -- +# +# set the load file (containing the load script); +# put the content of the load file into loadScript +# +# Arguments: +# script's file name +# +# Results: +# content of tcltest::loadFile +# +# Side effects: +# None. + +proc tcltest::loadFile { {scriptFile ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::loadFile + } + MakeAbsolutePath scriptFile $tcltest::temporaryDirectory + set tmp [open $scriptFile r] + tcltest::loadScript [read $tmp] + close $tmp + set tcltest::loadFile $scriptFile +} + +# tcltest::workingDirectory -- +# +# set workingDirectory to the given path. +# If the path is relative, make it absolute. +# change directory to the stated working directory, if resetting the +# value +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::workingDirectory +# +# Side effects: +# None. + +proc tcltest::workingDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::workingDirectory + } + set tcltest::workingDirectory $dir + MakeAbsolutePath tcltest::workingDirectory + cd $tcltest::workingDirectory + return $tcltest::workingDirectory +} + +# tcltest::temporaryDirectory -- +# +# Set tcltest::temporaryDirectory to the given path. +# If the path is relative, make it absolute. If the file exists but +# is not a dir, then return an error. +# +# If tcltest::temporaryDirectory does not already exist, create it. +# If you cannot create it, then return an error (the file mkdir isn't +# caught and will propagate). +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::temporaryDirectory +# +# Side effects: +# None. + +proc tcltest::temporaryDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::temporaryDirectory + } + set tcltest::temporaryDirectory $dir + + MakeAbsolutePath tcltest::temporaryDirectory + set tmpDirError "bad argument for temporary directory: " + + if {[file exists $tcltest::temporaryDirectory]} { + tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError + } else { + file mkdir $tcltest::temporaryDirectory + } + + normalizePath tcltest::temporaryDirectory +} + +# tcltest::testsDirectory -- +# +# Set tcltest::testsDirectory to the given path. +# If the path is relative, make it absolute. If the file exists but +# is not a dir, then return an error. +# +# If tcltest::testsDirectory does not already exist, return an error. +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::testsDirectory +# +# Side effects: +# None. + +proc tcltest::testsDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::testsDirectory + } + + set tcltest::testsDirectory $dir + + MakeAbsolutePath tcltest::testsDirectory + set testDirError "bad argument for tests directory: " + + if {[file exists $tcltest::testsDirectory]} { + tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError + } else { + set msg "$testDirError \"$tcltest::testsDirectory\" does not exist" + error $msg + } + + normalizePath tcltest::testsDirectory +} + +# tcltest::singleProcess -- +# +# sets tcltest::singleProcess to the value provided. +# +# Arguments: +# value for singleProcess: +# 1 = source each test file into the current process +# 0 = run each test file in its own process +# +# Results: +# content of tcltest::singleProcess +# +# Side effects: +# None. + +proc tcltest::singleProcess { {value ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::singleProcess + } + set tcltest::singleProcess $value +} + +# tcltest::interpreter -- +# +# the interpreter name stored in tcltest::tcltest +# +# Arguments: +# executable name +# +# Results: +# content of tcltest::tcltest +# +# Side effects: +# None. + +proc tcltest::interpreter { {interp ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::tcltest + } + set tcltest::tcltest $interp +} + +# tcltest::mainThread -- +# +# sets or returns the thread id stored in tcltest::mainThread +# +# Arguments: +# thread id +# +# Results: +# content of tcltest::mainThread +# +# Side effects: +# None. + +proc tcltest::mainThread { {threadid ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::mainThread + } + set tcltest::mainThread $threadid } -# ::tcltest::AddToSkippedBecause -- +##################################################################### + +# tcltest::AddToSkippedBecause -- # # Increments the variable used to track how many tests were skipped # because of a particular constraint. @@ -353,52 +1165,61 @@ proc ::tcltest::DebugDo {level script} { # constraint The name of the constraint to be modified # # Results: -# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't +# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't # previously exist - otherwise, it just increments it. +# +# Side effects: +# None. -proc ::tcltest::AddToSkippedBecause { constraint } { +proc tcltest::AddToSkippedBecause { constraint {value 1}} { # add the constraint to the list of constraints that kept tests # from running - if {[info exists ::tcltest::skippedBecause($constraint)]} { - incr ::tcltest::skippedBecause($constraint) + if {[info exists tcltest::skippedBecause($constraint)]} { + incr tcltest::skippedBecause($constraint) $value } else { - set ::tcltest::skippedBecause($constraint) 1 + set tcltest::skippedBecause($constraint) $value } return } -# ::tcltest::PrintError -- +# tcltest::PrintError -- # -# Prints errors to ::tcltest::errorChannel and then flushes that +# Prints errors to tcltest::errorChannel and then flushes that # channel, making sure that all messages are < 80 characters per line. # # Arguments: # errorMsg String containing the error to be printed # +# +# Results: +# None. +# +# Side effects: +# None. -proc ::tcltest::PrintError {errorMsg} { +proc tcltest::PrintError {errorMsg} { set InitialMessage "Error: " set InitialMsgLen [string length $InitialMessage] - puts -nonewline $::tcltest::errorChannel $InitialMessage + puts -nonewline [errorChannel] $InitialMessage # Keep track of where the end of the string is. set endingIndex [string length $errorMsg] if {$endingIndex < 80} { - puts $::tcltest::errorChannel $errorMsg + puts [errorChannel] $errorMsg } else { # Print up to 80 characters on the first line, including the # InitialMessage. set beginningIndex [string last " " [string range $errorMsg 0 \ [expr {80 - $InitialMsgLen}]]] - puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] + puts [errorChannel] [string range $errorMsg 0 $beginningIndex] while {$beginningIndex != "end"} { - puts -nonewline $::tcltest::errorChannel \ + puts -nonewline [errorChannel] \ [string repeat " " $InitialMsgLen] if {[expr {$endingIndex - $beginningIndex}] < 72} { - puts $::tcltest::errorChannel [string trim \ + puts [errorChannel] [string trim \ [string range $errorMsg $beginningIndex end]] set beginningIndex end } else { @@ -409,25 +1230,52 @@ proc ::tcltest::PrintError {errorMsg} { || ($newEndingIndex <= $beginningIndex)} { set newEndingIndex end } - puts $::tcltest::errorChannel [string trim \ + puts [errorChannel] [string trim \ [string range $errorMsg \ - $beginningIndex $newEndingIndex]] + $beginningIndex $newEndingIndex]] set beginningIndex $newEndingIndex } } } - flush $::tcltest::errorChannel + flush [errorChannel] return } -if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { - proc ::tcltest::initConstraintsHook {} {} +if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { + proc tcltest::initConstraintsHook {} {} +} + +# tcltest::safeFetch -- +# +# The following trace procedure makes it so that we can safely refer to +# non-existent members of the tcltest::testConstraints array without +# causing an error. Instead, reading a non-existent member will return +# 0. This is necessary because tests are allowed to use constraint "X" +# without ensuring that tcltest::testConstraints("X") is defined. +# +# Arguments: +# n1 - name of the array (tcltest::testConstraints) +# n2 - array key value (constraint name) +# op - operation performed on tcltest::testConstraints (generally r) +# +# Results: +# none +# +# Side effects: +# sets tcltest::testConstraints($n2) to 0 if it's referenced but never +# before used + +proc tcltest::safeFetch {n1 n2 op} { + DebugPuts 3 "entering safeFetch $n1 $n2 $op" + if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { + tcltest::testConstraint $n2 0 + } } -# ::tcltest::initConstraints -- +# tcltest::initConstraints -- # -# Check Constraintsuration information that will determine which tests -# to run. To do this, create an array ::tcltest::testConstraints. Each +# Check constraint information that will determine which tests +# to run. To do this, create an array tcltest::testConstraints. Each # element has a 0 or 1 value. If the element is "true" then tests # with that constraint will be run, otherwise tests with that constraint # will be skipped. See the tcltest man page for the list of built-in @@ -437,101 +1285,110 @@ if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { # none # # Results: -# The ::tcltest::testConstraints array is reset to have an index for +# The tcltest::testConstraints array is reset to have an index for # each built-in test constraint. +# +# Side Effects: +# None. +# -proc ::tcltest::initConstraints {} { +proc tcltest::initConstraints {} { global tcl_platform tcl_interactive tk_version - # The following trace procedure makes it so that we can safely refer to - # non-existent members of the ::tcltest::testConstraints array without - # causing an error. Instead, reading a non-existent member will return 0. - # This is necessary because tests are allowed to use constraint "X" without - # ensuring that ::tcltest::testConstraints("X") is defined. + # Safely refer to non-existent members of the tcltest::testConstraints + # array without causing an error. + trace variable tcltest::testConstraints r tcltest::safeFetch - trace variable ::tcltest::testConstraints r ::tcltest::safeFetch + tcltest::initConstraintsHook - proc ::tcltest::safeFetch {n1 n2 op} { - if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} { - set ::tcltest::testConstraints($n2) 0 - } - } + tcltest::testConstraint singleTestInterp [singleProcess] - ::tcltest::initConstraintsHook + # All the 'pc' constraints are here for backward compatibility and are not + # documented. They have been replaced with equivalent 'win' constraints. - set ::tcltest::testConstraints(unixOnly) \ + tcltest::testConstraint unixOnly \ [string equal $tcl_platform(platform) "unix"] - set ::tcltest::testConstraints(macOnly) \ + tcltest::testConstraint macOnly \ [string equal $tcl_platform(platform) "macintosh"] - set ::tcltest::testConstraints(pcOnly) \ + tcltest::testConstraint pcOnly \ + [string equal $tcl_platform(platform) "windows"] + tcltest::testConstraint winOnly \ [string equal $tcl_platform(platform) "windows"] - set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly) - set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly) - set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly) - - set ::tcltest::testConstraints(unixOrPc) \ - [expr {$::tcltest::testConstraints(unix) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrPc) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrUnix) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(unix)}] - - set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \ - "Windows NT"] - set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \ - "Windows 95"] - set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \ - "Windows 98"] + tcltest::testConstraint unix [tcltest::testConstraint unixOnly] + tcltest::testConstraint mac [tcltest::testConstraint macOnly] + tcltest::testConstraint pc [tcltest::testConstraint pcOnly] + tcltest::testConstraint win [tcltest::testConstraint winOnly] + + tcltest::testConstraint unixOrPc \ + [expr {[tcltest::testConstraint unix] \ + || [tcltest::testConstraint pc]}] + tcltest::testConstraint macOrPc \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint pc]}] + tcltest::testConstraint unixOrWin \ + [expr {[tcltest::testConstraint unix] \ + || [tcltest::testConstraint win]}] + tcltest::testConstraint macOrWin \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint win]}] + tcltest::testConstraint macOrUnix \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint unix]}] + + tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"] + tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"] + tcltest::testConstraint 98 [string equal $tcl_platform(os) "Windows 98"] # The following Constraints switches are used to mark tests that should # work, but have been temporarily disabled on certain platforms because # they don't and we haven't gotten around to fixing the underlying # problem. - set ::tcltest::testConstraints(tempNotPc) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(tempNotMac) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(tempNotUnix) \ - [expr {!$::tcltest::testConstraints(unix)}] + tcltest::testConstraint tempNotPc \ + [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint tempNotWin \ + [expr {![tcltest::testConstraint win]}] + tcltest::testConstraint tempNotMac \ + [expr {![tcltest::testConstraint mac]}] + tcltest::testConstraint tempNotUnix \ + [expr {![tcltest::testConstraint unix]}] # The following Constraints switches are used to mark tests that crash on # certain platforms, so that they can be reactivated again when the # underlying problem is fixed. - set ::tcltest::testConstraints(pcCrash) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macCrash) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(unixCrash) \ - [expr {!$::tcltest::testConstraints(unix)}] + tcltest::testConstraint pcCrash \ + [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint winCrash \ + [expr {![tcltest::testConstraint win]}] + tcltest::testConstraint macCrash \ + [expr {![tcltest::testConstraint mac]}] + tcltest::testConstraint unixCrash \ + [expr {![tcltest::testConstraint unix]}] # Skip empty tests - set ::tcltest::testConstraints(emptyTest) 0 + tcltest::testConstraint emptyTest 0 # By default, tests that expose known bugs are skipped. - set ::tcltest::testConstraints(knownBug) 0 + tcltest::testConstraint knownBug 0 # By default, non-portable tests are skipped. - set ::tcltest::testConstraints(nonPortable) 0 + tcltest::testConstraint nonPortable 0 # Some tests require user interaction. - set ::tcltest::testConstraints(userInteraction) 0 + tcltest::testConstraint userInteraction 0 # Some tests must be skipped if the interpreter is not in interactive mode if {[info exists tcl_interactive]} { - set ::tcltest::testConstraints(interactive) $::tcl_interactive + tcltest::testConstraint interactive $::tcl_interactive } else { - set ::tcltest::testConstraints(interactive) 0 + tcltest::testConstraint interactive 0 } # Some tests can only be run if the installation came from a CD image @@ -539,8 +1396,8 @@ proc ::tcltest::initConstraints {} { # Some tests must be skipped if you are running as root on Unix. # Other tests can only be run if you are running as root on Unix. - set ::tcltest::testConstraints(root) 0 - set ::tcltest::testConstraints(notRoot) 1 + tcltest::testConstraint root 0 + tcltest::testConstraint notRoot 1 set user {} if {[string equal $tcl_platform(platform) "unix"]} { catch {set user [exec whoami]} @@ -548,21 +1405,21 @@ proc ::tcltest::initConstraints {} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} } if {([string equal $user "root"]) || ([string equal $user ""])} { - set ::tcltest::testConstraints(root) 1 - set ::tcltest::testConstraints(notRoot) 0 + tcltest::testConstraint root 1 + tcltest::testConstraint notRoot 0 } } # Set nonBlockFiles constraint: 1 means this platform supports - # setting files into nonblocking mode. + # ting files into nonblocking mode. if {[catch {set f [open defs r]}]} { - set ::tcltest::testConstraints(nonBlockFiles) 1 + tcltest::testConstraint nonBlockFiles 1 } else { if {[catch {fconfigure $f -blocking off}] == 0} { - set ::tcltest::testConstraints(nonBlockFiles) 1 + tcltest::testConstraint nonBlockFiles 1 } else { - set ::tcltest::testConstraints(nonBlockFiles) 0 + tcltest::testConstraint nonBlockFiles 0 } close $f } @@ -576,75 +1433,75 @@ proc ::tcltest::initConstraints {} { if {[string equal $tcl_platform(platform) "unix"]} { if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - set ::tcltest::testConstraints(asyncPipeClose) 0 + tcltest::testConstraint asyncPipeClose 0 } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 + tcltest::testConstraint asyncPipeClose 1 } } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 + tcltest::testConstraint asyncPipeClose 1 } # Test to see if we have a broken version of sprintf with respect # to the "e" format of floating-point numbers. - set ::tcltest::testConstraints(eformat) 1 + tcltest::testConstraint eformat 1 if {![string equal "[format %g 5e-5]" "5e-05"]} { - set ::tcltest::testConstraints(eformat) 0 + tcltest::testConstraint eformat 0 } # Test to see if execed commands such as cat, echo, rm and so forth are # present on this machine. - set ::tcltest::testConstraints(unixExecs) 1 + tcltest::testConstraint unixExecs 1 if {[string equal $tcl_platform(platform) "macintosh"]} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([string equal $tcl_platform(platform) "windows"])} { if {[catch {exec cat defs}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec sh -c echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec wc defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {$::tcltest::testConstraints(unixExecs) == 1} { + if {[tcltest::testConstraint unixExecs] == 1} { exec echo hello > removeMe if {[catch {exec rm removeMe}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec sleep 1}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec fgrep unixExecs defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec ps}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec echo abc > removeMe}] == 0) && \ ([catch {exec chmod 644 removeMe}] == 1) && \ ([catch {exec rm removeMe}] == 0)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } else { catch {exec rm -f removeMe} } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec mkdir removeMe}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } else { catch {exec rm -r removeMe} } @@ -653,14 +1510,14 @@ proc ::tcltest::initConstraints {} { # Locate tcltest executable if {![info exists tk_version]} { - set tcltest [info nameofexecutable] + set tcltest::tcltest [info nameofexecutable] - if {$tcltest == "{}"} { - set tcltest {} + if {$tcltest::tcltest == "{}"} { + set tcltest::tcltest {} } } - set ::tcltest::testConstraints(stdio) 0 + tcltest::testConstraint stdio 0 catch { catch {file delete -force tmp} set f [open tmp w] @@ -672,7 +1529,7 @@ proc ::tcltest::initConstraints {} { set f [open "|[list $tcltest tmp]" r] close $f - set ::tcltest::testConstraints(stdio) 1 + tcltest::testConstraint stdio 1 } catch {file delete -force tmp} @@ -681,50 +1538,62 @@ proc ::tcltest::initConstraints {} { # system. catch {socket} msg - set ::tcltest::testConstraints(socket) \ + tcltest::testConstraint socket \ [expr {$msg != "sockets are not available on this system"}] # Check for internationalization if {[info commands testlocale] == ""} { # No testlocale command, no tests... - set ::tcltest::testConstraints(hasIsoLocale) 0 + tcltest::testConstraint hasIsoLocale 0 } else { - set ::tcltest::testConstraints(hasIsoLocale) \ - [string length [::tcltest::set_iso8859_1_locale]] - ::tcltest::restore_locale + tcltest::testConstraint hasIsoLocale \ + [string length [tcltest::set_iso8859_1_locale]] + tcltest::restore_locale } } -# ::tcltest::PrintUsageInfoHook +##################################################################### + +# Handle command line arguments (from argv) and default arg settings +# (in TCLTEST_OPTIONS). + +# tcltest::PrintUsageInfoHook # # Hook used for customization of display of usage information. # -if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} { - proc ::tcltest::PrintUsageInfoHook {} {} +if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} { + proc tcltest::PrintUsageInfoHook {} {} } -# ::tcltest::PrintUsageInfo +# tcltest::PrintUsageInfo # # Prints out the usage information for package tcltest. This can be -# customized with the redefinition of ::tcltest::PrintUsageInfoHook. +# customized with the redefinition of tcltest::PrintUsageInfoHook. # # Arguments: # none # +# Results: +# none +# +# Side Effects: +# none -proc ::tcltest::PrintUsageInfo {} { +proc tcltest::PrintUsageInfo {} { puts [format "Usage: [file tail [info nameofexecutable]] \ script ?-help? ?flag value? ... \n\ Available flags (and valid input values) are: \n\ -help \t Display this usage information. \n\ -verbose level \t Takes any combination of the values \n\ - \t 'p', 's' and 'b'. Test suite will \n\ + \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\ \t display all passed tests if 'p' is \n\ \t specified, all skipped tests if 's' \n\ - \t is specified, and the bodies of \n\ - \t failed tests if 'b' is specified. \n\ + \t is specified, the bodies of \n\ + \t failed tests if 'b' is specified, \n\ + \t and when tests start if 't' is specified. \n\ + \t ErrorInfo is displayed if 'e' is specified. \n\ \t The default value is 'b'. \n\ -constraints list\t Do not skip the listed constraints\n\ -limitconstraints bool\t Only run tests with the constraints\n\ @@ -740,17 +1609,21 @@ proc ::tcltest::PrintUsageInfo {} { \t match the glob pattern given. \n\ -notfile pattern\t Skip all test files that match the \n\ \t glob pattern given. \n\ + -relateddir pattern\t Run tests in directories that match \n\ + \t the glob pattern given. \n\ + -asidefromdir pattern\t Skip tests in directories that match \n\ + \t the glob pattern given.\n\ -preservecore level \t If 2, save any core files produced \n\ \t during testing in the directory \n\ \t specified by -tmpdir. If 1, notify the\n\ \t user if core files are created. The default \n\ - \t is $::tcltest::preserveCore. \n\ + \t is $tcltest::preserveCore. \n\ -tmpdir directory\t Save temporary files in the specified\n\ \t directory. The default value is \n\ - \t $::tcltest::temporaryDirectory. \n\ + \t $tcltest::temporaryDirectory. \n\ -testdir directories\t Search tests in the specified\n\ \t directories. The default value is \n\ - \t $::tcltest::testsDirectory. \n\ + \t $tcltest::testsDirectory. \n\ -outfile file \t Send output from test runs to the \n\ \t specified file. The default is \n\ \t stdout. \n\ @@ -762,207 +1635,98 @@ proc ::tcltest::PrintUsageInfo {} { -load script \t Specifies the script to load the tested \n\ \t commands. \n\ -debug level \t Internal debug flag."] - ::tcltest::PrintUsageInfoHook + tcltest::PrintUsageInfoHook return } -# ::tcltest::CheckDirectory -- -# -# This procedure checks whether the specified path is a readable -# and/or writable directory. If one of the conditions is not -# satisfied an error is printed and the application aborted. The -# procedure assumes that the caller already checked the existence -# of the path. -# -# Arguments -# rw Information what attributes to check. Allowed values: -# r, w, rw, wr. If 'r' is part of the value the directory -# must be readable. 'w' associates to 'writable'. -# dir The directory to check. -# errMsg The string to prepend to the actual error message before -# printing it. -# -# Results -# none -# - -proc ::tcltest::CheckDirectory {rw dir errMsg} { - # Allowed values for 'rw': r, w, rw, wr - - if {![file isdir $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not a directory" - exit 1 - } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not writeable" - exit 1 - } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not readable" - exit 1 - } -} - -# ::tcltest::normalizePath -- -# -# This procedure resolves any symlinks in the path thus creating a -# path without internal redirection. It assumes that the incoming -# path is absolute. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::normalizePath {pathVar} { - upvar $pathVar path - - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd -} - -# ::tcltest::MakeAbsolutePath -- -# -# This procedure checks whether the incoming path is absolute or not. -# Makes it absolute if it was not. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# prefix is optional, contains the path to use to make the other an -# absolute one. The current working directory is used if it was -# not specified. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} { - upvar $pathVar path - - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { - set prefix [pwd] - } - - set path [file join $prefix $path] - } -} - -# ::tcltest::processCmdLineArgsFlagsHook -- +# tcltest::processCmdLineArgsFlagsHook -- # # This hook is used to add to the list of command line arguments that are -# processed by ::tcltest::processCmdLineArgs. +# processed by tcltest::ProcessFlags. It is called at the beginning of +# ProcessFlags. # -if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { - proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} +if {[namespace inscope tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { + proc tcltest::processCmdLineArgsAddFlagsHook {} {} } -# ::tcltest::processCmdLineArgsHook -- +# tcltest::processCmdLineArgsHook -- # # This hook is used to actually process the flags added by -# ::tcltest::processCmdLineArgsAddFlagsHook. +# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of +# ProcessFlags. # # Arguments: # flags The flags that have been pulled out of argv # -if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} { - proc ::tcltest::processCmdLineArgsHook {flag} {} +if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} { + proc tcltest::processCmdLineArgsHook {flag} {} } -# ::tcltest::processCmdLineArgs -- +# tcltest::ProcessFlags -- # -# Use command line args to set the verbose, skip, and -# match, outputChannel, errorChannel, debug, and temporaryDirectory -# variables. -# -# This procedure must be run after constraints are initialized, because -# some constraints can be overridden. +# process command line arguments supplied in the flagArray - this is +# called by processCmdLineArgs +# modifies tcltest variables according to the content of the flagArray. # # Arguments: -# none +# flagArray - array containing name/value pairs of flags # # Results: -# Sets the above-named variables in the tcltest namespace. - -proc ::tcltest::processCmdLineArgs {} { - global argv - - # The "argv" var doesn't exist in some cases, so use {}. - - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv - } - - # Allow for 1-char abbreviations, where applicable (e.g., -match == -m). - # Note that -verbose cannot be abbreviated to -v in wish because it - # conflicts with the wish option -visual. +# sets tcltest variables according to their values as defined by +# flagArray +# +# Side effects: +# None. +proc tcltest::ProcessFlags {flagArray} { # Process -help first - if {([lsearch -exact $flagArray {-help}] != -1) || \ - ([lsearch -exact $flagArray {-h}] != -1)} { - ::tcltest::PrintUsageInfo - exit 1 - } - - if {[catch {array set flag $flagArray}]} { - ::tcltest::PrintError "odd number of arguments specified on command line: \ - $argv" - ::tcltest::PrintUsageInfo + if {[lsearch -exact $flagArray {-help}] != -1} { + tcltest::PrintUsageInfo exit 1 } + + catch {array set flag $flagArray} # -help is not listed since it has already been processed lappend defaultFlags -verbose -match -skip -constraints \ -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints -args -testdir \ - -load -loadfile + -preservecore -limitconstraints -testdir \ + -load -loadfile -asidefromdir \ + -relateddir -singleproc set defaultFlags [concat $defaultFlags \ - [ ::tcltest::processCmdLineArgsAddFlagsHook ]] - - foreach arg $defaultFlags { - set abbrev [string range $arg 0 1] - if {([info exists flag($abbrev)]) && \ - ([lsearch -exact $flagArray $arg] < [lsearch -exact \ - $flagArray $abbrev])} { - set flag($arg) $flag($abbrev) - } - } - - # Set ::tcltest::parameters to the arg of the -args flag, if given - if {[info exists flag(-args)]} { - set ::tcltest::parameters $flag(-args) - } - - # Set ::tcltest::verbose to the arg of the -verbose flag, if given + [tcltest::processCmdLineArgsAddFlagsHook ]] + # Set tcltest::verbose to the arg of the -verbose flag, if given if {[info exists flag(-verbose)]} { - set ::tcltest::verbose $flag(-verbose) + tcltest::verbose $flag(-verbose) } - # Set ::tcltest::match to the arg of the -match flag, if given. - + # Set tcltest::match to the arg of the -match flag, if given. if {[info exists flag(-match)]} { - set ::tcltest::match $flag(-match) + tcltest::match $flag(-match) } - # Set ::tcltest::skip to the arg of the -skip flag, if given - + # Set tcltest::skip to the arg of the -skip flag, if given if {[info exists flag(-skip)]} { - set ::tcltest::skip $flag(-skip) + tcltest::skip $flag(-skip) } # Handle the -file and -notfile flags if {[info exists flag(-file)]} { - set ::tcltest::matchFiles $flag(-file) + tcltest::matchFiles $flag(-file) } if {[info exists flag(-notfile)]} { - set ::tcltest::skipFiles $flag(-notfile) + tcltest::skipFiles $flag(-notfile) + } + + # Handle -relateddir and -asidefromdir flags + if {[info exists flag(-relateddir)]} { + tcltest::matchDirectories $flag(-relateddir) + } + if {[info exists flag(-asidefromdir)]} { + tcltest::skipDirectories $flag(-asidefromdir) } # Use the -constraints flag, if given, to turn on constraints that are @@ -971,7 +1735,7 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-constraints)]} { foreach elt $flag(-constraints) { - set ::tcltest::testConstraints($elt) 1 + tcltest::testConstraint $elt 1 } } @@ -980,87 +1744,35 @@ proc ::tcltest::processCmdLineArgs {} { # the -constraints flag was not specified, print out an error and exit. if {[info exists flag(-limitconstraints)]} { if {![info exists flag(-constraints)]} { - puts "You can only use the -limitconstraints flag with \ - -constraints" - exit 1 - } - set ::tcltest::limitConstraints $flag(-limitconstraints) - foreach elt [array names ::tcltest::testConstraints] { - if {[lsearch -exact $flag(-constraints) $elt] == -1} { - set ::tcltest::testConstraints($elt) 0 - } + set msg "-limitconstraints flag can only be used with -constraints" + error $msg } + tcltest::limitConstraints $flag(-limitconstraints) } - # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if + # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist, create it. - # If you cannot create it, then return an error. - set tmpDirError "" if {[info exists flag(-tmpdir)]} { - set ::tcltest::temporaryDirectory $flag(-tmpdir) - - MakeAbsolutePath ::tcltest::temporaryDirectory - set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: " - } - if {[file exists $::tcltest::temporaryDirectory]} { - ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError - } else { - file mkdir $::tcltest::temporaryDirectory + tcltest::temporaryDirectory $flag(-tmpdir) } - normalizePath ::tcltest::temporaryDirectory - - # Set the ::tcltest::testsDirectory to the arg of -testdir, if + # Set the tcltest::testsDirectory to the arg of -testdir, if # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist return an error. - set testDirError "" if {[info exists flag(-testdir)]} { - set ::tcltest::testsDirectory $flag(-testdir) - - MakeAbsolutePath ::tcltest::testsDirectory - set testDirError "bad argument \"$flag(-testdir)\" to -testdir: " - } - if {[file exists $::tcltest::testsDirectory]} { - ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError - } else { - ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \ - does not exist" - exit 1 - } - - normalizePath ::tcltest::testsDirectory - - # Save the names of files that already exist in - # the output directory. - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend ::tcltest::filesExisted [file tail $file] + tcltest::testsDirectory $flag(-testdir) } # If an alternate error or output files are specified, change the # default channels. if {[info exists flag(-outfile)]} { - set tmp $flag(-outfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::outputChannel [open $tmp w] + tcltest::outputFile $flag(-outfile) } if {[info exists flag(-errfile)]} { - set tmp $flag(-errfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::errorChannel [open $tmp w] + tcltest::errorFile $flag(-errfile) } # If a load script was specified, either directly or through @@ -1068,294 +1780,647 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-load)] && \ ([lsearch -exact $flagArray -load] > \ - [lsearch -exact $flagArray -loadfile])} { - set ::tcltest::loadScript $flag(-load) + [lsearch -exact $flagArray -loadfile])} { + tcltest::loadScript $flag(-load) } if {[info exists flag(-loadfile)] && \ ([lsearch -exact $flagArray -loadfile] > \ - [lsearch -exact $flagArray -load]) } { - set tmp $flag(-loadfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set tmp [open $tmp r] - set ::tcltest::loadScript [read $tmp] - close $tmp + [lsearch -exact $flagArray -load]) } { + tcltest::loadFile $flag(-loadfile) } # If the user specifies debug testing, print out extra information during # the run. if {[info exists flag(-debug)]} { - set ::tcltest::debug $flag(-debug) + tcltest::debug $flag(-debug) } # Handle -preservecore if {[info exists flag(-preservecore)]} { - set ::tcltest::preserveCore $flag(-preservecore) + tcltest::preserveCore $flag(-preservecore) + } + + # Handle -singleproc flag + if {[info exists flag(-singleproc)]} { + tcltest::singleProcess $flag(-singleproc) } # Call the hook - ::tcltest::processCmdLineArgsHook [array get flag] + tcltest::processCmdLineArgsHook [array get flag] + return +} - # Spit out everything you know if we're at a debug level 2 or greater +# tcltest::processCmdLineArgs -- +# +# Use command line args to set tcltest namespace variables. +# +# This procedure must be run after constraints are initialized, because +# some constraints can be overridden. +# +# Set variables based on the contents of the environment variable +# TCLTEST_OPTIONS first, then override with command-line options, if +# specified. +# +# Arguments: +# none +# +# Results: +# Sets the above-named variables in the tcltest namespace. +# +# Side Effects: +# None. +# + +proc tcltest::processCmdLineArgs {} { + global argv + + # If the TCLTEST_OPTIONS environment variable exists, parse it first, then + # the argv list. The command line argument parsing will be a two-pass + # affair from now on, so that TCLTEST_OPTIONS contain the default options. + # These can be overridden by the command line flags. + + if {[info exists ::env(TCLTEST_OPTIONS)]} { + tcltest::ProcessFlags $::env(TCLTEST_OPTIONS) + } + + # The "argv" var doesn't exist in some cases, so use {}. + if {(![info exists argv]) || ([llength $argv] < 1)} { + set flagArray {} + } else { + set flagArray $argv + } + + tcltest::ProcessFlags $flagArray - DebugPuts 2 "Flags passed into tcltest:" - DebugPArray 2 flag - DebugPuts 2 "::tcltest::debug = $::tcltest::debug" - DebugPuts 2 "::tcltest::testsDirectory = $::tcltest::testsDirectory" - DebugPuts 2 "::tcltest::workingDirectory = $::tcltest::workingDirectory" - DebugPuts 2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory" - DebugPuts 2 "::tcltest::outputChannel = $::tcltest::outputChannel" - DebugPuts 2 "::tcltest::errorChannel = $::tcltest::errorChannel" - DebugPuts 2 "Original environment (::tcltest::originalEnv):" - DebugPArray 2 ::tcltest::originalEnv + # Spit out everything you know if we're at a debug level 2 or greater + DebugPuts 2 "Flags passed into tcltest:" + if {[info exists ::env(TCLTEST_OPTIONS)]} { + DebugPuts 2 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" + } + if {[info exists argv]} { + DebugPuts 2 " argv: $argv" + } + DebugPuts 2 "tcltest::debug = [tcltest::debug]" + DebugPuts 2 "tcltest::testsDirectory = [tcltest::testsDirectory]" + DebugPuts 2 "tcltest::workingDirectory = [tcltest::workingDirectory]" + DebugPuts 2 "tcltest::temporaryDirectory = [tcltest::temporaryDirectory]" + DebugPuts 2 "tcltest::outputChannel = [outputChannel]" + DebugPuts 2 "tcltest::errorChannel = [errorChannel]" + DebugPuts 2 "Original environment (tcltest::originalEnv):" + DebugPArray 2 tcltest::originalEnv DebugPuts 2 "Constraints:" - DebugPArray 2 ::tcltest::testConstraints + DebugPArray 2 tcltest::testConstraints + return } -# ::tcltest::loadTestedCommands -- +##################################################################### + +# Code to run the tests goes here. + +# tcltest::testPuts -- # -# Uses the specified script to load the commands to test. Allowed to -# be empty, as the tested commands could have been compiled into the -# interpreter. +# Used to redefine puts in test environment. +# Stores whatever goes out on stdout in tcltest::outData and stderr in +# tcltest::errData before sending it on to the regular puts. # -# Arguments -# none +# Arguments: +# same as standard puts # -# Results -# none +# Results: +# none +# +# Side effects: +# Intercepts puts; data that would otherwise go to stdout, stderr, or +# file channels specified in tcltest::outputChannel and errorChannel does +# not get sent to the normal puts function. + +proc tcltest::testPuts {args} { + set len [llength $args] + if {$len == 1} { + # Only the string to be printed is specified + append tcltest::outData "[lindex $args 0]\n" + return +# return [tcltest::normalPuts [lindex $args 0]] + } elseif {$len == 2} { + # Either -nonewline or channelId has been specified + if {[regexp {^-nonewline} [lindex $args 0]]} { + append tcltest::outData "[lindex $args end]" + return +# return [tcltest::normalPuts -nonewline [lindex $args end]] + } else { + set channel [lindex $args 0] + } + } elseif {$len == 3} { + if {[lindex $args 0] == "-nonewline"} { + # Both -nonewline and channelId are specified, unless it's an + # error. -nonewline is supposed to be argv[0]. + set channel [lindex $args 1] + } + } -proc ::tcltest::loadTestedCommands {} { - if {$::tcltest::loadScript == {}} { + if {[info exists channel]} { + if {($channel == [outputChannel]) || ($channel == "stdout")} { + append tcltest::outData "[lindex $args end]\n" + } elseif {($channel == [errorChannel]) || ($channel == "stderr")} { + append tcltest::errData "[lindex $args end]\n" + } return + # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]] } - - uplevel #0 $::tcltest::loadScript + + # If we haven't returned by now, we don't know how to handle the input. + # Let puts handle it. + return [eval tcltest::normalPuts $args] } -# ::tcltest::cleanupTests -- +# tcltest::testEval -- # -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. +# Evaluate the script in the test environment. If ignoreOutput is +# false, store data sent to stderr and stdout in tcltest::outData and +# tcltest::errData. Otherwise, ignore this output altogether. # -# Print the names of the files created without the makeFile command -# since the tests were invoked. +# Arguments: +# script Script to evaluate +# ?ignoreOutput? Indicates whether or not to ignore output sent to +# stdout & stderr # -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). - -proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { - - set testFileName [file tail [info script]] +# Results: +# result from running the script +# +# Side effects: +# Empties the contents of tcltest::outData and tcltest::errData before +# running a test if ignoreOutput is set to 0. - # Call the cleanup hook - ::tcltest::cleanupTestsHook +proc tcltest::testEval {script {ignoreOutput 1}} { + DebugPuts 3 "testEval called" + if {!$ignoreOutput} { + set tcltest::outData {} + set tcltest::errData {} + uplevel rename ::puts tcltest::normalPuts + uplevel rename tcltest::testPuts ::puts + } + set result [uplevel $script] + if {!$ignoreOutput} { + uplevel rename ::puts tcltest::testPuts + uplevel rename tcltest::normalPuts ::puts + } + return $result +} - # Remove files and directories created by the :tcltest::makeFile and - # ::tcltest::makeDirectory procedures. - # Record the names of files in ::tcltest::workingDirectory that were not - # pre-existing, and associate them with the test file that created them. +# compareStrings -- +# +# compares the expected answer to the actual answer, depending on the +# mode provided. Mode determines whether a regexp, exact, or glob +# comparison is done. +# +# Arguments: +# actual - string containing the actual result +# expected - pattern to be matched against +# mode - type of comparison to be done +# +# Results: +# result of the match +# +# Side effects: +# None. - if {!$calledFromAllFile} { - foreach file $::tcltest::filesMade { - if {[file exists $file]} { - catch {file delete -force $file} - } +proc tcltest::compareStrings {actual expected mode} { + switch -- $mode { + exact { + set retval [string equal $actual $expected] } - set currentFiles {} - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend currentFiles [file tail $file] + glob { + set retval [string match $expected $actual] } - set newFiles {} - foreach file $currentFiles { - if {[lsearch -exact $::tcltest::filesExisted $file] == -1} { - lappend newFiles $file - } - } - set ::tcltest::filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set ::tcltest::createdNewFiles($testFileName) $newFiles + regexp { + set retval [regexp -- $expected $actual] } } + return $retval +} - if {$calledFromAllFile || $::tcltest::testSingleFile} { - # print stats +# +# tcltest::substArguments list +# +# This helper function takes in a list of words, then perform a +# substitution on the list as though each word in the list is a +# separate argument to the Tcl function. For example, if this +# function is invoked as: +# +# substArguments {$a {$a}} +# +# Then it is as though the function is invoked as: +# +# substArguments $a {$a} +# +# This code is adapted from Paul Duffin's function "SplitIntoWords". +# The original function can be found on: +# +# http://purl.org/thecliff/tcl/wiki/858.html +# +# Results: +# a list containing the result of the substitution +# +# Exceptions: +# An error may occur if the list containing unbalanced quote or +# unknown variable. +# +# Side Effects: +# None. +# + +proc tcltest::substArguments {argList} { + + # We need to split the argList up into tokens but cannot use + # list operations as they throw away some significant + # quoting, and [split] ignores braces as it should. + # Therefore what we do is gradually build up a string out of + # whitespace seperated strings. We cannot use [split] to + # split the argList into whitespace seperated strings as it + # throws away the whitespace which maybe important so we + # have to do it all by hand. + + set result {} + set token "" + + while {[string length $argList]} { + # Look for the next word containing a quote: " { } + if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ + $argList all]} { + # Get the text leading up to this word, but not + # including this word, from the argList. + set text [string range $argList 0 \ + [expr {[lindex $all 0] - 1}]] + # Get the word with the quote + set word [string range $argList \ + [lindex $all 0] [lindex $all 1]] + + # Remove all text up to and including the word from the + # argList. + set argList [string range $argList \ + [expr {[lindex $all 1] + 1}] end] + } else { + # Take everything up to the end of the argList. + set text $argList + set word {} + set argList {} + } + + if {$token != {}} { + # If we saw a word with quote before, then there is a + # multi-word token starting with that word. In this case, + # add the text and the current word to this token. + append token $text $word + } else { + # Add the text to the result. There is no need to parse + # the text because it couldn't be a part of any multi-word + # token. Then start a new multi-word token with the word + # because we need to pass this token to the Tcl parser to + # check for balancing quotes + append result $text + set token $word + } + + if { [catch {llength $token} length] == 0 && $length == 1} { + # The token is a valid list so add it to the result. + # lappend result [string trim $token] + append result \{$token\} + set token {} + } + } - puts -nonewline $::tcltest::outputChannel "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline $::tcltest::outputChannel \ - "\t$index\t$::tcltest::numTests($index)" - } - puts $::tcltest::outputChannel "" + # If the last token has not been added to the list then there + # is a problem. + if { [string length $token] } { + error "incomplete token \"$token\"" + } - # print number test files sourced - # print names of files that ran tests which failed + return $result +} - if {$calledFromAllFile} { - puts $::tcltest::outputChannel \ - "Sourced $::tcltest::numTestFiles Test Files." - set ::tcltest::numTestFiles 0 - if {[llength $::tcltest::failFiles] > 0} { - puts $::tcltest::outputChannel \ - "Files with failing tests: $::tcltest::failFiles" - set ::tcltest::failFiles {} - } - } - # if any tests were skipped, print the constraints that kept them - # from running. +# tcltest::test -- +# +# This procedure runs a test and prints an error message if the test fails. +# If tcltest::verbose has been set, it also prints a message even if the +# test succeeds. The test will be skipped if it doesn't match the +# tcltest::match variable, if it matches an element in +# tcltest::skip, or if one of the elements of "constraints" turns +# out not to be true. +# +# If testLevel is 1, then this is a top level test, and we record pass/fail +# information; otherwise, this information is not logged and is not added to +# running totals. +# +# Attributes: +# Only description is a required attribute. All others are optional. +# Default values are indicated. +# +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "tcltest::testConstraints". If any +# of these elements is zero, the test is +# skipped. This attribute is optional; default is {} +# body - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. This attribute is optional; +# default is {} +# result - Expected result from script. This attribute is +# optional; default is {}. +# output - Expected output sent to stdout. This attribute +# is optional; default is {}. +# errorOutput - Expected output sent to stderr. This attribute +# is optional; default is {}. +# returnCodes - Expected return codes. This attribute is +# optional; default is {0 2}. +# setup - Code to run before $script (above). This +# attribute is optional; default is {}. +# cleanup - Code to run after $script (above). This +# attribute is optional; default is {}. +# match - specifies type of matching to do on result, +# output, errorOutput; this must be one of: exact, +# glob, regexp. default is exact. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# +# Results: +# 0 if the command ran successfully; 1 otherwise. +# +# Side effects: +# None. +# - set constraintList [array names ::tcltest::skippedBecause] - if {[llength $constraintList] > 0} { - puts $::tcltest::outputChannel \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts $::tcltest::outputChannel \ - "\t$::tcltest::skippedBecause($constraint)\t$constraint" - unset ::tcltest::skippedBecause($constraint) - } - } +proc tcltest::test {name description args} { + DebugPuts 3 "Test $name $args" - # report the names of test files in ::tcltest::createdNewFiles, and - # reset the array to be empty. + incr tcltest::testLevel - set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts $::tcltest::outputChannel "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts $::tcltest::outputChannel \ - "\t$testFile:\t$::tcltest::createdNewFiles($testFile)" - unset ::tcltest::createdNewFiles($testFile) + # Pre-define everything to null except output and errorOutput. We + # determine whether or not to trap output based on whether or not these + # variables (output & errorOutput) are defined. + foreach item {constraints setup cleanup body result returnCodes match} { + set $item {} + } + + # Set the default match mode + set match exact + + # Set the default match values for return codes (0 is the standard expected + # return value if everything went well; 2 represents 'return' being used in + # the test script). + set returnCodes [list 0 2] + + # The old test format can't have a 3rd argument (constraints or script) + # that starts with '-'. + if {[llength $args] == 0} { + puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}" + incr tcltest::testLevel -1 + return 1 + } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} { + + if {[llength $args] == 1} { + set list [substArguments [lindex $args 0]] + foreach {element value} $list { + set testAttributes($element) $value + } + foreach item {constraints match setup body cleanup \ + result returnCodes output errorOutput} { + if {[info exists testAttributes([subst -$item])]} { + set testAttributes([subst -$item]) \ + [uplevel concat $testAttributes([subst -$item])] + } } + } else { + array set testAttributes $args } - # reset filesMade, filesExisted, and numTests + set validFlags {-setup -cleanup -body -result -returnCodes -match \ + -output -errorOutput -constraints} - set ::tcltest::filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set ::tcltest::numTests($index) 0 + foreach flag [array names testAttributes] { + if {[lsearch -exact $validFlags $flag] == -1} { + puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test" + incr tcltest::testLevel -1 + return 1 + } } - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && ![info exists tcl_interactive]} { - exit + # store whatever the user gave us + foreach item [array names testAttributes] { + set [string trimleft $item "-"] $testAttributes($item) } - } else { - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed + # Check the values supplied for -match + if {[lsearch {regexp glob exact} $match] == -1} { + puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}" + incr tcltest::testLevel -1 + return 1 + } - incr ::tcltest::numTestFiles - if {($::tcltest::currentFailure) && \ - ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} { - lappend ::tcltest::failFiles $testFileName + # Replace symbolic valies supplied for -returnCodes + regsub -nocase normal $returnCodes 0 returnCodes + regsub -nocase error $returnCodes 1 returnCodes + regsub -nocase return $returnCodes 2 returnCodes + regsub -nocase break $returnCodes 3 returnCodes + regsub -nocase continue $returnCodes 4 returnCodes + } else { + # This is parsing for the old test command format; it is here for + # backward compatibility. + set result [lindex $args end] + if {[llength $args] == 2} { + set body [lindex $args 0] + } elseif {[llength $args] == 3} { + set constraints [lindex $args 0] + set body [lindex $args 1] + } else { + puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}" + incr tcltest::testLevel -1 + return 1 } - set ::tcltest::currentFailure false + } - # restore the environment to the state it was in before this package - # was loaded + set setupFailure 0 + set cleanupFailure 0 - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists ::tcltest::originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { - if {$::env($index) != $::tcltest::originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $::tcltest::originalEnv($index) - } - } + # Run the setup script + if {[catch {uplevel $setup} setupMsg]} { + set setupFailure 1 + } + + # run the test script + set command [list tcltest::runTest $name $description $body \ + $result $constraints] + if {!$setupFailure} { + if {[info exists output] || [info exists errorOutput]} { + set testResult [uplevel tcltest::testEval [list $command] 0] + } else { + set testResult [uplevel tcltest::testEval [list $command] 1] } - foreach index [array names ::tcltest::originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $::tcltest::originalEnv($index) + } else { + set testResult setupFailure + } + + # Run the cleanup code + if {[catch {uplevel $cleanup} cleanupMsg]} { + set cleanupFailure 1 + } + + # If testResult is an empty list, then the test was skipped + if {$testResult != {}} { + set coreFailure 0 + set coreMsg "" + # check for a core file first - if one was created by the test, then + # the test failed + if {$tcltest::preserveCore} { + set currentTclPlatform [array get tcl_platform] + if {[file exists [file join [tcltest::workingDirectory] core]]} { + # There's only a test failure if there is a core file and (1) + # there previously wasn't one or (2) the new one is different + # from the old one. + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [tcltest::workingDirectory] core]]} { + set coreFailure 1 + } + } else { + set coreFailure 1 + } + + if {($tcltest::preserveCore > 1) && ($coreFailure)} { + append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]" + catch {file rename -force \ + [file join [tcltest::workingDirectory] core] \ + [file join $tcltest::temporaryDirectory \ + core-$name]} msg + if {[string length $msg] > 0} { + append coreMsg "\nError: Problem renaming core file: $msg" + } + } } + array set tcl_platform $currentTclPlatform } - if {[llength $newEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements changed:\t$changedEnv" + + set actualAnswer [lindex $testResult 0] + set code [lindex $testResult end] + + # If expected output/error strings exist, we have to compare + # them. If the comparison fails, then so did the test. + set outputFailure 0 + set errorFailure 0 + if {[info exists output]} { + set outputFailure [expr ![compareStrings $tcltest::outData \ + $output $match]] + } + if {[info exists errorOutput]} { + set errorFailure [expr ![compareStrings $tcltest::errData \ + $errorOutput $match]] } - if {[llength $removedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements removed:\t$removedEnv" + + set testFailed 1 + set codeFailure 0 + set scriptFailure 0 + + # check if the return code matched the expected return code + if {[lsearch -exact $returnCodes $code] == -1} { + set codeFailure 1 + } + + # check if the answer matched the expected answer + if {[compareStrings $actualAnswer $result $match] == 0} { + set scriptFailure 1 } - set changedTclPlatform {} - foreach index [array names ::tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $::tcltest::originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $::tcltest::originalTclPlatform($index) + # if we didn't experience any failures, then we passed + if {!($setupFailure || $cleanupFailure || $coreFailure || \ + $outputFailure || $errorFailure || $codeFailure || \ + $scriptFailure)} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Passed) + if {[tcltest::isVerbose pass]} { + puts [outputChannel] "++++ $name PASSED" + } } + set testFailed 0 } - if {[llength $changedTclPlatform] > 0} { - puts $::tcltest::outputChannel \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "produced core file! \ - Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" - flush $::tcltest::outputChannel - catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" + if {$testFailed} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Failed) + } + set tcltest::currentFailure true + if {![tcltest::isVerbose body]} { + set body "" + } + puts [outputChannel] "\n==== $name [string trim $description] FAILED" + if {$body != ""} { + puts [outputChannel] "==== Contents of test case:" + puts [outputChannel] $body + } + if {$setupFailure} { + puts [outputChannel] "---- Test setup failed:\n$setupMsg" + } + if {$scriptFailure} { + puts [outputChannel] "---- Result was:\n$actualAnswer" + puts [outputChannel] "---- Result should have been ($match matching):\n$result" + } + if {$codeFailure} { + switch -- $code { + 0 { set msg "Test completed normally" } + 1 { set msg "Test generated error" } + 2 { set msg "Test generated return exception" } + 3 { set msg "Test generated break exception" } + 4 { set msg "Test generated continue exception" } + default { set msg "Test generated exception" } } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists ::tcltest::coreModificationTime]} { - if {$::tcltest::coreModificationTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "A core file was created!" + puts [outputChannel] "---- $msg; Return code was: $code" + puts [outputChannel] "---- Return code should have been one of: $returnCodes" + if {[tcltest::isVerbose error]} { + if {[info exists ::errorInfo]} { + puts [outputChannel] "---- errorInfo: $::errorInfo" + puts [outputChannel] "---- errorCode: $::errorCode" } - } else { - puts $::tcltest::outputChannel "A core file was created!" - } + } + } + if {$outputFailure} { + puts [outputChannel] "---- Output was:\n$tcltest::outData" + puts [outputChannel] "---- Output should have been ($match matching):\n$output" + } + if {$errorFailure} { + puts [outputChannel] "---- Error output was:\n$tcltest::errData" + puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput" + } + if {$cleanupFailure} { + puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" } + if {$coreFailure} { + puts [outputChannel] "---- Core file produced while running test! $coreMsg" + } + puts [outputChannel] "==== $name FAILED\n" + } } + + incr tcltest::testLevel -1 + return 0 } -# ::tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { - proc ::tcltest::cleanupTestsHook {} {} -} -# test -- +# runTest -- # +# This is the defnition of the version 1.0 test routine for tcltest. It is +# provided here for backward compatibility. It is also used as the 'backbone' +# of the test procedure, as in, this is where all the work really gets done. +# # This procedure runs a test and prints an error message if the test fails. -# If ::tcltest::verbose has been set, it also prints a message even if the +# If tcltest::verbose has been set, it also prints a message even if the # test succeeds. The test will be skipped if it doesn't match the -# ::tcltest::match variable, if it matches an element in -# ::tcltest::skip, or if one of the elements of "constraints" turns +# tcltest::match variable, if it matches an element in +# tcltest::skip, or if one of the elements of "constraints" turns # out not to be true. # # Arguments: @@ -1364,81 +2429,93 @@ if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { # help humans understand what it does. # constraints - A list of one or more keywords, each of # which must be the name of an element in -# the array "::tcltest::testConstraints". If any of these +# the array "tcltest::testConstraints". If any of these # elements is zero, the test is skipped. # This argument may be omitted. # script - Script to run to carry out the test. It must # return a result that can be checked for # correctness. # expectedAnswer - Expected result from script. +# +# Behavior depends on the value of testLevel; if testLevel is 1 (top level), +# then events are logged and we track the number of tests run/skipped and why. +# Otherwise, we don't track this information. +# +# Results: +# empty list if test is skipped; otherwise returns list containing +# actual returned value from the test and the return code. +# +# Side Effects: +# none. +# -proc ::tcltest::test {name description script expectedAnswer args} { - - DebugPuts 3 "Running $name ($description)" - - incr ::tcltest::numTests(Total) +proc tcltest::runTest {name description script expectedAnswer constraints} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Total) + } + # skip the test if it's name matches an element of skip - - foreach pattern $::tcltest::skip { + foreach pattern $tcltest::skip { if {[string match $pattern $name]} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip} + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip} + } return } } # skip the test if it's name doesn't match any element of match - - if {[llength $::tcltest::match] > 0} { + if {[llength $tcltest::match] > 0} { set ok 0 - foreach pattern $::tcltest::match { + foreach pattern $tcltest::match { if {[string match $pattern $name]} { set ok 1 break } } if {!$ok} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch} + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch} + } return } } - set i [llength $args] - if {$i == 0} { - set constraints {} + DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints" + + if {$constraints == {}} { # If we're limited to the listed constraints and there aren't any # listed, then we shouldn't run the test. - if {$::tcltest::limitConstraints} { - ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint - incr ::tcltest::numTests(Skipped) + if {$tcltest::limitConstraints} { + tcltest::AddToSkippedBecause userSpecifiedLimitConstraint + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + } return } - } elseif {$i == 1} { - - # "constraints" argument exists; shuffle arguments down, then + } else { + # "constraints" argument exists; # make sure that the constraints are satisfied. - set constraints $script - set script $expectedAnswer - set expectedAnswer [lindex $args 0] set doTest 0 if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 expr $constraints]} } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { # something like {a || b} should be turned into - # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$::tcltest::testConstraints(&)} c + # $tcltest::testConstraints(a) || $tcltest::testConstraints(b). + regsub -all {[.\w]+} $constraints \ + {$tcltest::testConstraints(&)} c catch {set doTest [eval expr $c]} } else { # just simple constraints such as {unixOnly fonts}. set doTest 1 foreach constraint $constraints { - if {(![info exists ::tcltest::testConstraints($constraint)]) \ - || (!$::tcltest::testConstraints($constraint))} { + if {(![info exists tcltest::testConstraints($constraint)]) \ + || (!$tcltest::testConstraints($constraint))} { set doTest 0 # store the constraint that kept the test from running @@ -1447,28 +2524,30 @@ proc ::tcltest::test {name description script expectedAnswer args} { } } } + if {$doTest == 0} { - if {[string first s $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints" + if {[tcltest::isVerbose skip]} { + puts [outputChannel] "++++ $name SKIPPED: $constraints" + } + + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + tcltest::AddToSkippedBecause $constraints } - - incr ::tcltest::numTests(Skipped) - ::tcltest::AddToSkippedBecause $constraints return } - } else { - error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" - } + } # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with tcl_platform. + # tcl_platform environment because some of the tests mess with + # tcl_platform. - if {$::tcltest::preserveCore} { + if {$tcltest::preserveCore} { set currentTclPlatform [array get tcl_platform] - array set tcl_platform $::tcltest::originalTclPlatform - if {[file exists [file join $::tcltest::workingDirectory core]]} { + array set tcl_platform $tcltest::originalTclPlatform + if {[file exists [file join [tcltest::workingDirectory] core]]} { set coreModTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + [tcltest::workingDirectory] core]] } array set tcl_platform $currentTclPlatform } @@ -1480,107 +2559,288 @@ proc ::tcltest::test {name description script expectedAnswer args} { memory tag $name } + if {[tcltest::isVerbose start]} { + puts [outputChannel] "---- $name start" + flush [outputChannel] + } + set code [catch {uplevel $script} actualAnswer] - if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} { - incr ::tcltest::numTests(Passed) - if {[string first p $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name PASSED" + + return [list $actualAnswer $code] +} + +##################################################################### + +# tcltest::cleanupTestsHook -- +# +# This hook allows a harness that builds upon tcltest to specify +# additional things that should be done at cleanup. +# + +if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} { + proc tcltest::cleanupTestsHook {} {} +} + +# tcltest::cleanupTests -- +# +# Remove files and dirs created using the makeFile and makeDirectory +# commands since the last time this proc was invoked. +# +# Print the names of the files created without the makeFile command +# since the tests were invoked. +# +# Print the number tests (total, passed, failed, and skipped) since the +# tests were invoked. +# +# Restore original environment (as reported by special variable env). +# +# Arguments: +# calledFromAllFile - if 0, behave as if we are running a single test file +# within an entire suite of tests. if we aren't running a single test +# file, then don't report status. check for new files created during the +# test run and report on them. if 1, report collated status from all the +# test file runs. +# +# Results: +# None. +# +# Side Effects: +# None +# + +proc tcltest::cleanupTests {{calledFromAllFile 0}} { + + set testFileName [file tail [info script]] + + # Call the cleanup hook + tcltest::cleanupTestsHook + + # Remove files and directories created by the :tcltest::makeFile and + # tcltest::makeDirectory procedures. + # Record the names of files in tcltest::workingDirectory that were not + # pre-existing, and associate them with the test file that created them. + + if {!$calledFromAllFile} { + foreach file $tcltest::filesMade { + if {[file exists $file]} { + catch {file delete -force $file} + } + } + set currentFiles {} + foreach file [glob -nocomplain \ + [file join $tcltest::temporaryDirectory *]] { + lappend currentFiles [file tail $file] + } + set newFiles {} + foreach file $currentFiles { + if {[lsearch -exact $tcltest::filesExisted $file] == -1} { + lappend newFiles $file + } + } + set tcltest::filesExisted $currentFiles + if {[llength $newFiles] > 0} { + set tcltest::createdNewFiles($testFileName) $newFiles + } + } + + if {$calledFromAllFile || $tcltest::testSingleFile} { + + # print stats + + puts -nonewline [outputChannel] "$testFileName:" + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + puts -nonewline [outputChannel] \ + "\t$index\t$tcltest::numTests($index)" + } + puts [outputChannel] "" + + # print number test files sourced + # print names of files that ran tests which failed + + if {$calledFromAllFile} { + puts [outputChannel] \ + "Sourced $tcltest::numTestFiles Test Files." + set tcltest::numTestFiles 0 + if {[llength $tcltest::failFiles] > 0} { + puts [outputChannel] \ + "Files with failing tests: $tcltest::failFiles" + set tcltest::failFiles {} + } + } + + # if any tests were skipped, print the constraints that kept them + # from running. + + set constraintList [array names tcltest::skippedBecause] + if {[llength $constraintList] > 0} { + puts [outputChannel] \ + "Number of tests skipped for each constraint:" + foreach constraint [lsort $constraintList] { + puts [outputChannel] \ + "\t$tcltest::skippedBecause($constraint)\t$constraint" + unset tcltest::skippedBecause($constraint) + } + } + + # report the names of test files in tcltest::createdNewFiles, and + # reset the array to be empty. + + set testFilesThatTurded [lsort [array names tcltest::createdNewFiles]] + if {[llength $testFilesThatTurded] > 0} { + puts [outputChannel] "Warning: files left behind:" + foreach testFile $testFilesThatTurded { + puts [outputChannel] \ + "\t$testFile:\t$tcltest::createdNewFiles($testFile)" + unset tcltest::createdNewFiles($testFile) + } + } + + # reset filesMade, filesExisted, and numTests + + set tcltest::filesMade {} + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + set tcltest::numTests($index) 0 + } + + # exit only if running Tk in non-interactive mode + + global tk_version tcl_interactive + if {[info exists tk_version] && ![info exists tcl_interactive]} { + exit } } else { - incr ::tcltest::numTests(Failed) - set ::tcltest::currentFailure true - if {[string first b $::tcltest::verbose] == -1} { - set script "" - } - puts $::tcltest::outputChannel "\n==== $name $description FAILED" - if {$script != ""} { - puts $::tcltest::outputChannel "==== Contents of test case:" - puts $::tcltest::outputChannel $script - } - if {$code != 0} { - if {$code == 1} { - puts $::tcltest::outputChannel "==== Test generated error:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 2} { - puts $::tcltest::outputChannel "==== Test generated return exception; result was:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 3} { - puts $::tcltest::outputChannel "==== Test generated break exception" - } elseif {$code == 4} { - puts $::tcltest::outputChannel "==== Test generated continue exception" + + # if we're deferring stat-reporting until all files are sourced, + # then add current file to failFile list if any tests in this file + # failed + + incr tcltest::numTestFiles + if {($tcltest::currentFailure) && \ + ([lsearch -exact $tcltest::failFiles $testFileName] == -1)} { + lappend tcltest::failFiles $testFileName + } + set tcltest::currentFailure false + + # restore the environment to the state it was in before this package + # was loaded + + set newEnv {} + set changedEnv {} + set removedEnv {} + foreach index [array names ::env] { + if {![info exists tcltest::originalEnv($index)]} { + lappend newEnv $index + unset ::env($index) } else { - puts $::tcltest::outputChannel "==== Test generated exception $code; message was:" - puts $::tcltest::outputChannel $actualAnswer + if {$::env($index) != $tcltest::originalEnv($index)} { + lappend changedEnv $index + set ::env($index) $tcltest::originalEnv($index) + } } - } else { - puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer" } - puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer" - puts $::tcltest::outputChannel "==== $name FAILED\n" - } - if {$::tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "==== $name produced core file! \ + foreach index [array names tcltest::originalEnv] { + if {![info exists ::env($index)]} { + lappend removedEnv $index + set ::env($index) $tcltest::originalEnv($index) + } + } + if {[llength $newEnv] > 0} { + puts [outputChannel] \ + "env array elements created:\t$newEnv" + } + if {[llength $changedEnv] > 0} { + puts [outputChannel] \ + "env array elements changed:\t$changedEnv" + } + if {[llength $removedEnv] > 0} { + puts [outputChannel] \ + "env array elements removed:\t$removedEnv" + } + + set changedTclPlatform {} + foreach index [array names tcltest::originalTclPlatform] { + if {$::tcl_platform($index) != \ + $tcltest::originalTclPlatform($index)} { + lappend changedTclPlatform $index + set ::tcl_platform($index) \ + $tcltest::originalTclPlatform($index) + } + } + if {[llength $changedTclPlatform] > 0} { + puts [outputChannel] \ + "tcl_platform array elements changed:\t$changedTclPlatform" + } + + if {[file exists [file join [tcltest::workingDirectory] core]]} { + if {$tcltest::preserveCore > 1} { + puts "rename core file (> 1)" + puts [outputChannel] "produced core file! \ Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" + [file join $tcltest::temporaryDirectory core-$name]" catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg + [file join [tcltest::workingDirectory] core] \ + [file join $tcltest::temporaryDirectory \ + core-$name]} msg if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" + tcltest::PrintError "Problem renaming file: $msg" } } else { # Print a message if there is a core file and (1) there # previously wasn't one or (2) the new one is different from # the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "==== $name produced core file!" + if {[info exists tcltest::coreModificationTime]} { + if {$tcltest::coreModificationTime != [file mtime \ + [file join [tcltest::workingDirectory] core]]} { + puts [outputChannel] "A core file was created!" } } else { - puts $::tcltest::outputChannel "==== $name produced core file!" + puts [outputChannel] "A core file was created!" } } } - array set tcl_platform $currentTclPlatform } + flush [outputChannel] + flush [errorChannel] + return } -# ::tcltest::getMatchingFiles +##################################################################### + +# Procs that determine which tests/test files to run + +# tcltest::getMatchingFiles # # Looks at the patterns given to match and skip files # and uses them to put together a list of the tests that will be run. # # Arguments: -# none +# directory to search # # Results: # The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. +# be used in 'all.tcl' files. It is used in runAllTests. +# +# Side Effects: +# None -proc ::tcltest::getMatchingFiles {args} { - set matchingFiles {} - if {[llength $args]} { - set searchDirectory $args - } else { - set searchDirectory [list $::tcltest::testsDirectory] +proc tcltest::getMatchingFiles { {searchDirectory ""} } { + if {[llength [info level 0]] == 1} { + set searchDirectory [tcltest::testsDirectory] } + set matchingFiles {} + # Find the matching files in the list of directories and then remove the # ones that match the skip pattern foreach directory $searchDirectory { set matchFileList {} - foreach match $::tcltest::matchFiles { + foreach match $tcltest::matchFiles { set matchFileList [concat $matchFileList \ [glob -nocomplain [file join $directory $match]]] } - if {[string compare {} $::tcltest::skipFiles]} { + if {[string compare {} $tcltest::skipFiles]} { set skipFileList {} - foreach skip $::tcltest::skipFiles { + foreach skip $tcltest::skipFiles { set skipFileList [concat $skipFileList \ [glob -nocomplain [file join $directory $skip]]] } @@ -1597,35 +2857,213 @@ proc ::tcltest::getMatchingFiles {args} { } } if {[string equal $matchingFiles {}]} { - ::tcltest::PrintError "No test files remain after applying \ + tcltest::PrintError "No test files remain after applying \ your match and skip patterns!" } return $matchingFiles } -# The following two procs are used in the io tests. - -proc ::tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} +# tcltest::getMatchingDirectories -- +# +# Looks at the patterns given to match and skip directories and uses them +# to put together a list of the test directories that we should attempt +# to run. (Only subdirectories containing an "all.tcl" file are put into +# the list.) +# +# Arguments: +# root directory from which to search +# +# Results: +# The constructed list is returned to the user. This is used in the +# primary all.tcl file. Lower-level all.tcl files should use the +# tcltest::testAllFiles proc instead. +# +# Side Effects: +# None. + +proc tcltest::getMatchingDirectories {rootdir} { + set matchingDirs {} + set matchDirList {} + # Find the matching directories in tcltest::testsDirectory and then + # remove the ones that match the skip pattern + foreach match $tcltest::matchDirectories { + foreach file [glob -nocomplain [file join $rootdir $match]] { + if {([file isdirectory $file]) && ($file != $rootdir)} { + set matchDirList [concat $matchDirList \ + [tcltest::getMatchingDirectories $file]] + if {[file exists [file join $file all.tcl]]} { + set matchDirList [concat $matchDirList $file] + } + } + } } - return $result + if {$tcltest::skipDirectories != {}} { + set skipDirs {} + foreach skip $tcltest::skipDirectories { + set skipDirs [concat $skipDirs \ + [glob -nocomplain [file join $tcltest::testsDirectory \ + $skip]]] + } + foreach dir $matchDirList { + # Only include directories that don't match the skip pattern + if {[lsearch -exact $skipDirs $dir] == -1} { + lappend matchingDirs $dir + } + } + } else { + set matchingDirs [concat $matchingDirs $matchDirList] + } + if {$matchingDirs == {}} { + DebugPuts 1 "No test directories remain after applying match and skip patterns!" + } + return $matchingDirs } -proc ::tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} +# tcltest::runAllTests -- +# +# prints output and sources test files according to the match and skip +# patterns provided. after sourcing test files, it goes on to source +# all.tcl files in matching test subdirectories. +# +# Arguments: +# shell being tested +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::runAllTests { {shell ""} } { + global argv + + if {[llength [info level 0]] == 1} { + set shell [tcltest::interpreter] } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p + + set tcltest::testSingleFile false + + puts [outputChannel] "Tests running in interp: $shell" + puts [outputChannel] "Tests located in: $tcltest::testsDirectory" + puts [outputChannel] "Tests running in: [tcltest::workingDirectory]" + puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory" + if {[tcltest::singleProcess]} { + puts [outputChannel] "Test files sourced into current interpreter" + } else { + puts [outputChannel] "Test files run in separate interpreters" + } + if {[llength $tcltest::skip] > 0} { + puts [outputChannel] "Skipping tests that match: $tcltest::skip" + } + if {[llength $tcltest::match] > 0} { + puts [outputChannel] "Only running tests that match: $tcltest::match" + } + + if {[llength $tcltest::skipFiles] > 0} { + puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles" + } + if {[llength $tcltest::matchFiles] > 0} { + puts [outputChannel] "Only running test files that match: $tcltest::matchFiles" + } + + set timeCmd {clock format [clock seconds]} + puts [outputChannel] "Tests began at [eval $timeCmd]" + + # Run each of the specified tests + foreach file [lsort [tcltest::getMatchingFiles]] { + set tail [file tail $file] + puts [outputChannel] $tail + + if {$tcltest::singleProcess} { + incr tcltest::numTestFiles + uplevel [list source $file] + } else { + # Change to the tests directory so the value of the following + # variable is set correctly when we spawn the child test processes + cd $tcltest::testsDirectory + set cmd [concat [list | $shell $file] [split $argv]] + if {[catch { + incr tcltest::numTestFiles + set pipeFd [open $cmd "r"] + while {[gets $pipeFd line] >= 0} { + if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + incr tcltest::numTests($index) [set $index] + } + if {$Failed > 0} { + lappend tcltest::failFiles $testFile + } + } elseif {[regexp {^Number of tests skipped for each constraint:|^\t(\d+)\t(.+)$} $line match skipped constraint]} { + if {$match != "Number of tests skipped for each constraint:"} { + tcltest::AddToSkippedBecause $constraint $skipped + } + } else { + puts [outputChannel] $line + } + } + close $pipeFd + } msg]} { + # Print results to tcltest::outputChannel. + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported later + lappend testFileFailures $file + } } } - return $leak + + # cleanup + puts [outputChannel] "\nTests ended at [eval $timeCmd]" + tcltest::cleanupTests 1 + if {[info exists testFileFailures]} { + puts [outputChannel] "\nTest files exiting with errors: \n" + foreach file $testFileFailures { + puts " [file tail $file]\n" + } + } + + # Checking for subdirectories in which to run tests + foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] { + set dir [file tail $directory] + puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + puts [outputChannel] "$dir test began at [eval $timeCmd]\n" + + uplevel "source [file join $directory all.tcl]" + + set endTime [eval $timeCmd] + puts [outputChannel] "\n$dir test ended at $endTime" + puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + } + return +} + +##################################################################### + +# Test utility procs - not used in tcltest, but may be useful for testing. + +# tcltest::loadTestedCommands -- +# +# Uses the specified script to load the commands to test. Allowed to +# be empty, as the tested commands could have been compiled into the +# interpreter. +# +# Arguments +# none +# +# Results +# none +# +# Side Effects: +# none. + +proc tcltest::loadTestedCommands {} { + if {$tcltest::loadScript == {}} { + return + } + + return [uplevel $tcltest::loadScript] } -# ::tcltest::saveState -- +# tcltest::saveState -- # # Save information regarding what procs and variables exist. # @@ -1633,58 +3071,71 @@ proc ::tcltest::leakfiles {old} { # none # # Results: -# Modifies the variable ::tcltest::saveState +# Modifies the variable tcltest::saveState +# +# Side effects: +# None. -proc ::tcltest::saveState {} { - uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState" +proc tcltest::saveState {} { + uplevel {set tcltest::saveState [list [info procs] [info vars]]} + DebugPuts 2 "tcltest::saveState: $tcltest::saveState" + return } -# ::tcltest::restoreState -- +# tcltest::restoreState -- # # Remove procs and variables that didn't exist before the call to -# ::tcltest::saveState. +# tcltest::saveState. # # Arguments: # none # # Results: # Removes procs and variables from your environment if they don't exist -# in the ::tcltest::saveState variable. +# in the tcltest::saveState variable. +# +# Side effects: +# None. -proc ::tcltest::restoreState {} { +proc tcltest::restoreState {} { foreach p [info procs] { - if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \ - (![string equal ::tcltest::$p [namespace origin $p]])} { + if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \ + (![string match "*tcltest::$p" [namespace origin $p]])} { - DebugPuts 2 "::tcltest::restoreState: Removing proc $p" + DebugPuts 2 "tcltest::restoreState: Removing proc $p" rename $p {} } } - foreach p [uplevel #0 {info vars}] { - if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { - DebugPuts 2 "::tcltest::restoreState: Removing variable $p" - uplevel #0 "catch {unset $p}" + foreach p [uplevel {info vars}] { + if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} { + DebugPuts 2 "tcltest::restoreState: Removing variable $p" + uplevel "catch {unset $p}" } } + return } -# ::tcltest::normalizeMsg -- +# tcltest::normalizeMsg -- # # Removes "extra" newlines from a string. # # Arguments: # msg String to be modified # +# Results: +# string with extra newlines removed +# +# Side effects: +# None. -proc ::tcltest::normalizeMsg {msg} { +proc tcltest::normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg regsub -all "\n\n" $msg "\n" msg regsub -all "\n\}" $msg "\}" msg return $msg } -# makeFile -- +# tcltest::makeFile -- # # Create a new file with the name <name>, and write <contents> to it. # @@ -1692,12 +3143,28 @@ proc ::tcltest::normalizeMsg {msg} { # cleanupTests was called, add it to the $filesMade list, so it will # be removed by the next call to cleanupTests. # -proc ::tcltest::makeFile {contents name} { +# Arguments: +# contents content of the new file +# name name of the new file +# directory directory name for new file +# +# Results: +# absolute path to the file created +# +# Side effects: +# None. + +proc tcltest::makeFile {contents name {directory ""}} { global tcl_platform + + if {[llength [info level 0]] == 3} { + set directory [tcltest::temporaryDirectory] + } - DebugPuts 3 "::tcltest::makeFile: putting $contents into $name" + set fullName [file join $directory $name] + + DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" - set fullName [file join $::tcltest::temporaryDirectory $name] set fd [open $fullName w] fconfigure $fd -translation lf @@ -1709,26 +3176,36 @@ proc ::tcltest::makeFile {contents name} { } close $fd - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName + if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { + lappend tcltest::filesMade $fullName } return $fullName } -# ::tcltest::removeFile -- +# tcltest::removeFile -- # # Removes the named file from the filesystem # # Arguments: -# name file to be removed +# name file to be removed +# directory directory from which to remove file # +# Results: +# return value from [file delete] +# +# Side effects: +# None. -proc ::tcltest::removeFile {name} { - DebugPuts 3 "::tcltest::removeFile: removing $name" - file delete [file join $::tcltest::temporaryDirectory $name] +proc tcltest::removeFile {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeFile: removing $fullName" + return [file delete $fullName] } -# makeDirectory -- +# tcltest::makeDirectory -- # # Create a new dir with the name <name>. # @@ -1736,75 +3213,85 @@ proc ::tcltest::removeFile {name} { # cleanupTests was called, add it to the $directoriesMade list, so it will # be removed by the next call to cleanupTests. # -proc ::tcltest::makeDirectory {name} { - file mkdir $name +# Arguments: +# name name of the new directory +# directory directory in which to create new dir +# +# Results: +# absolute path to the directory created +# +# Side effects: +# None. - set fullName [file join [pwd] $name] - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName +proc tcltest::makeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::makeDirectory: creating $fullName" + file mkdir $fullName + if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { + lappend tcltest::filesMade $fullName + } + return $fullName } -# ::tcltest::removeDirectory -- +# tcltest::removeDirectory -- # # Removes a named directory from the file system. # # Arguments: -# name Name of the directory to remove +# name Name of the directory to remove +# directory Directory from which to remove # +# Results: +# return value from [file delete] +# +# Side effects: +# None -proc ::tcltest::removeDirectory {name} { - file delete -force $name -} - -proc ::tcltest::viewFile {name} { - global tcl_platform - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ($::tcltest::testConstraints(unixExecs) == 0)} { - set f [open [file join $::tcltest::temporaryDirectory $name]] - set data [read -nonewline $f] - close $f - return $data - } else { - exec cat [file join $::tcltest::temporaryDirectory $name] +proc tcltest::removeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" + return [file delete -force $fullName] } -# grep -- +# tcltest::viewFile -- # -# Evaluate a given expression against each element of a list and return all -# elements for which the expression evaluates to true. For the purposes of -# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the -# value of the current element within the expression. This is equivalent to -# the perl grep command where CURRENT_ELEMENT would be the name for the special -# variable $_. +# reads the content of a file and returns it # -# Examples of usage would be: -# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] -# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] +# Arguments: +# name of the file to read +# directory in which file is located # -# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is -# assumed to be the final argument to the expression provided. -# -# Example: -# grep {regexp a} $someList +# Results: +# content of the named file # -proc ::tcltest::grep { expression searchList } { - foreach element $searchList { - if {[regsub -all CURRENT_ELEMENT $expression $element \ - newExpression] == 0} { - set newExpression "$expression {$element}" - } - if {[eval $newExpression] == 1} { - lappend returnList $element - } +# Side effects: +# None. + +proc tcltest::viewFile {name {directory ""}} { + global tcl_platform + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } - if {[info exists returnList]} { - return $returnList + set fullName [file join $directory $name] + if {([string equal $tcl_platform(platform) "macintosh"]) || \ + ([tcltest::testConstraint unixExecs] == 0)} { + set f [open $fullName] + set data [read -nonewline $f] + close $f + return $data + } else { + return [exec cat $fullName] } return } +# tcltest::bytestring -- # # Construct a string that consists of the requested sequence of bytes, # as opposed to a string of properly formed UTF-8 characters. @@ -1818,30 +3305,112 @@ proc ::tcltest::grep { expression searchList } { # Generally, it's a bad idea to examine the bytes in a Tcl string or to # construct improperly formed strings in this manner, because it involves # exposing that Tcl uses UTF-8 internally. +# +# Arguments: +# string being converted +# +# Results: +# result fom encoding +# +# Side effects: +# None + +proc tcltest::bytestring {string} { + return [encoding convertfrom identity $string] +} + +# tcltest::openfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. -proc ::tcltest::bytestring {string} { - encoding convertfrom identity $string +proc tcltest::openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +# tcltest::leakfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak } # # Internationalization / ISO support procs -- dl # -proc ::tcltest::set_iso8859_1_locale {} { + +# tcltest::set_iso8859_1_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::set_iso8859_1_locale {} { if {[info commands testlocale] != ""} { - set ::tcltest::previousLocale [testlocale ctype] - testlocale ctype $::tcltest::isoLocale + set tcltest::previousLocale [testlocale ctype] + testlocale ctype $tcltest::isoLocale } return } -proc ::tcltest::restore_locale {} { +# tcltest::restore_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::restore_locale {} { if {[info commands testlocale] != ""} { - testlocale ctype $::tcltest::previousLocale + testlocale ctype $tcltest::previousLocale } return } -# threadReap -- +# tcltest::threadReap -- # # Kill all threads except for the main thread. # Do nothing if testthread is not defined. @@ -1851,7 +3420,12 @@ proc ::tcltest::restore_locale {} { # # Results: # Returns the number of existing threads. -proc ::tcltest::threadReap {} { +# +# Side Effects: +# none. +# + +proc tcltest::threadReap {} { if {[info commands testthread] != {}} { # testthread built into tcltest @@ -1859,7 +3433,7 @@ proc ::tcltest::threadReap {} { testthread errorproc ThreadNullError while {[llength [testthread names]] > 1} { foreach tid [testthread names] { - if {$tid != $::tcltest::mainThread} { + if {$tid != $tcltest::mainThread} { catch {testthread send -async $tid {testthread exit}} } } @@ -1877,7 +3451,7 @@ proc ::tcltest::threadReap {} { thread::errorproc ThreadNullError while {[llength [thread::names]] > 1} { foreach tid [thread::names] { - if {$tid != $::tcltest::mainThread} { + if {$tid != $tcltest::mainThread} { catch {thread::send -async $tid {thread::exit}} } } @@ -1891,6 +3465,7 @@ proc ::tcltest::threadReap {} { } else { return 1 } + return 0 } # Initialize the constraints and set up command line arguments @@ -1898,8 +3473,18 @@ namespace eval tcltest { # Ensure that we have a minimal auto_path so we don't pick up extra junk. set ::auto_path [list [info library]] - ::tcltest::initConstraints - if {[namespace children ::tcltest] == {}} { - ::tcltest::processCmdLineArgs + tcltest::initConstraints + if {[namespace children [namespace current]] == {}} { + tcltest::processCmdLineArgs + } + + # Save the names of files that already exist in + # the output directory. + foreach file [glob -nocomplain \ + [file join $tcltest::temporaryDirectory *]] { + lappend tcltest::filesExisted [file tail $file] } } + +package provide tcltest 2.0 + diff --git a/library/tcltest1.0/tcltest2.tcl b/library/tcltest1.0/tcltest2.tcl deleted file mode 100755 index c05732d..0000000 --- a/library/tcltest1.0/tcltest2.tcl +++ /dev/null @@ -1,3490 +0,0 @@ -# tcltest.tcl -- -# -# This file contains support code for the Tcl test suite. It -# defines the tcltest namespace and finds and defines the output -# directory, constraints available, output and error channels, etc. used -# by Tcl tests. See the tcltest man page for more details. -# -# This design was based on the Tcl testing approach designed and -# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. -# -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions -# All rights reserved. -# -# RCS: @(#) $Id: tcltest2.tcl,v 1.4 2000/10/19 18:00:58 jenn Exp $ - -# create the "tcltest" namespace for all testing variables and procedures - -namespace eval tcltest { - - # Export the public tcltest procs - set procList [list test cleanupTests saveState restoreState \ - normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring threadReap debug testConstraint \ - limitConstraints loadTestedCommands normalizePath verbose match \ - skip matchFiles skipFiles preserveCore loadScript loadFile \ - mainThread workingDirectory singleProcess interpreter runAllTests \ - outputChannel outputFile errorChannel \ - errorFile temporaryDirectory testsDirectory matchDirectories \ - skipDirectories ] - foreach proc $procList { - namespace export $proc - } - - # tcltest::verbose defaults to {body} - if {![info exists verbose]} { - variable verbose {body} - } - - # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory and - # matchDirectories, which defaults to all directories. - - if {![info exists match]} { - variable match {} - } - if {![info exists skip]} { - variable skip {} - } - if {![info exists matchFiles]} { - variable matchFiles {*.test} - } - if {![info exists skipFiles]} { - variable skipFiles {} - } - if {![info exists matchDirectories]} { - variable matchDirectories {*} - } - if {![info exists skipDirectories]} { - variable skipDirectories {} - } - - # By default, don't save core files - if {![info exists preserveCore]} { - variable preserveCore 0 - } - - # output goes to stdout by default - if {![info exists outputChannel]} { - variable outputChannel stdout - } - if {![info exists outputFile]} { - variable outputFile stdout - } - - # errors go to stderr by default - if {![info exists errorChannel]} { - variable errorChannel stderr - } - if {![info exists errorFile]} { - variable errorFile stderr - } - - # debug output doesn't get printed by default; debug level 1 spits - # up only the tests that were skipped because they didn't match or were - # specifically skipped. A debug level of 2 would spit up the tcltest - # variables and flags provided; a debug level of 3 causes some additional - # output regarding operations of the test harness. The tcltest package - # currently implements only up to debug level 3. - if {![info exists debug]} { - variable debug 0 - } - - # Save any arguments that we might want to pass through to other programs. - # This is used by the -args flag. - if {![info exists parameters]} { - variable parameters {} - } - - # Count the number of files tested (0 if runAllTests wasn't called). - # runAllTests will set testSingleFile to false, so stats will - # not be printed until runAllTests calls the cleanupTests proc. - # The currentFailure var stores the boolean value of whether the - # current test file has had any failures. The failFiles list - # stores the names of test files that had failures. - - if {![info exists numTestFiles]} { - variable numTestFiles 0 - } - if {![info exists testSingleFile]} { - variable testSingleFile true - } - if {![info exists currentFailure]} { - variable currentFailure false - } - if {![info exists failFiles]} { - variable failFiles {} - } - - # Tests should remove all files they create. The test suite will - # check the current working dir for files created by the tests. - # tcltest::filesMade keeps track of such files created using the - # tcltest::makeFile and tcltest::makeDirectory procedures. - # tcltest::filesExisted stores the names of pre-existing files. - - if {![info exists filesMade]} { - variable filesMade {} - } - if {![info exists filesExisted]} { - variable filesExisted {} - } - - # tcltest::numTests will store test files as indices and the list - # of files (that should not have been) left behind by the test files. - - if {![info exists createdNewFiles]} { - variable createdNewFiles - array set tcltest::createdNewFiles {} - } - - # initialize tcltest::numTests array to keep track fo the number of - # tests that pass, fail, and are skipped. - - if {![info exists numTests]} { - variable numTests - array set tcltest::numTests \ - [list Total 0 Passed 0 Skipped 0 Failed 0] - } - - # initialize tcltest::skippedBecause array to keep track of - # constraints that kept tests from running; a constraint name of - # "userSpecifiedSkip" means that the test appeared on the list of tests - # that matched the -skip value given to the flag; "userSpecifiedNonMatch" - # means that the test didn't match the argument given to the -match flag; - # both of these constraints are counted only if tcltest::debug is set to - # true. - - if {![info exists skippedBecause]} { - variable skippedBecause - array set tcltest::skippedBecause {} - } - - # initialize the tcltest::testConstraints array to keep track of valid - # predefined constraints (see the explanation for the - # tcltest::initConstraints proc for more details). - - if {![info exists testConstraints]} { - variable testConstraints - array set tcltest::testConstraints {} - } - - if {![info exists constraintsSpecified]} { - variable constraintsSpecified {} - } - - # Don't run only the constrained tests by default - - if {![info exists limitConstraints]} { - variable limitConstraints false - } - - # A test application has to know how to load the tested commands into - # the interpreter. - - if {![info exists loadScript]} { - variable loadScript {} - } - - # and the filename of the script file, if it exists - if {![info exists loadFile]} { - variable loadFile {} - } - - # tests that use threads need to know which is the main thread - - if {![info exists mainThread]} { - variable mainThread 1 - if {[info commands thread::id] != {}} { - set mainThread [thread::id] - } elseif {[info commands testthread] != {}} { - set mainThread [testthread id] - } - } - - # save the original environment so that it can be restored later - - if {![info exists originalEnv]} { - variable originalEnv - array set tcltest::originalEnv [array get ::env] - } - - # Set tcltest::workingDirectory to [pwd]. The default output directory - # for Tcl tests is the working directory. - - if {![info exists workingDirectory]} { - variable workingDirectory [pwd] - } - if {![info exists temporaryDirectory]} { - variable temporaryDirectory $workingDirectory - } - - # Tests should not rely on the current working directory. - # Files that are part of the test suite should be accessed relative to - # tcltest::testsDirectory. - - if {![info exists testsDirectory]} { - set oldpwd [pwd] - catch {cd [file join [file dirname [info script]] .. .. tests]} - variable testsDirectory [pwd] - cd $oldpwd - unset oldpwd - } - - # Default is to run each test file in a separate process - if {![info exists singleProcess]} { - variable singleProcess 0 - } - - # the variables and procs that existed when tcltest::saveState was - # called are stored in a variable of the same name - if {![info exists saveState]} { - variable saveState {} - } - - # Internationalization support -- used in tcltest::set_iso8859_1_locale - # and tcltest::restore_locale. Those commands are used in cmdIL.test. - if {![info exists previousLocale]} { - variable previousLocale - } - - if {![info exists isoLocale]} { - variable isoLocale fr - switch -- $tcl_platform(platform) { - "unix" { - - # Try some 'known' values for some platforms: - - switch -exact -- $tcl_platform(os) { - "FreeBSD" { - set tcltest::isoLocale fr_FR.ISO_8859-1 - } - HP-UX { - set tcltest::isoLocale fr_FR.iso88591 - } - Linux - - IRIX { - set tcltest::isoLocale fr - } - default { - - # Works on SunOS 4 and Solaris, and maybe others... - # define it to something else on your system - #if you want to test those. - - set tcltest::isoLocale iso_8859_1 - } - } - } - "windows" { - set tcltest::isoLocale French - } - } - } - - # Set the location of the execuatble - if {![info exists tcltest]} { - variable tcltest [info nameofexecutable] - } - - # save the platform information so it can be restored later - if {![info exists originalTclPlatform]} { - variable originalTclPlatform [array get tcl_platform] - } - - # If a core file exists, save its modification time. - if {![info exists coreModificationTime]} { - if {[file exists [file join $tcltest::workingDirectory core]]} { - variable coreModificationTime [file mtime [file join \ - $tcltest::workingDirectory core]] - } - } - - # stdout and stderr buffers for use when we want to store them - if {![info exists outData]} { - variable outData {} - } - if {![info exists errData]} { - variable errData {} - } - - # keep track of test level for nested test commands - variable testLevel 0 -} - -##################################################################### - -# tcltest::Debug* -- -# -# Internal helper procedures to write out debug information -# dependent on the chosen level. A test shell may overide -# them, f.e. to redirect the output into a different -# channel, or even into a GUI. - -# tcltest::DebugPuts -- -# -# Prints the specified string if the current debug level is -# higher than the provided level argument. -# -# Arguments: -# level The lowest debug level triggering the output -# string The string to print out. -# -# Results: -# Prints the string. Nothing else is allowed. -# -# Side Effects: -# None. -# - -proc tcltest::DebugPuts {level string} { - variable debug - if {$debug >= $level} { - puts $string - } - return -} - -# tcltest::DebugPArray -- -# -# Prints the contents of the specified array if the current -# debug level is higher than the provided level argument -# -# Arguments: -# level The lowest debug level triggering the output -# arrayvar The name of the array to print out. -# -# Results: -# Prints the contents of the array. Nothing else is allowed. -# -# Side Effects: -# None. -# - -proc tcltest::DebugPArray {level arrayvar} { - variable debug - - if {$debug >= $level} { - catch {upvar $arrayvar $arrayvar} - parray $arrayvar - } - return -} - -# tcltest::DebugDo -- -# -# Executes the script if the current debug level is greater than -# the provided level argument -# -# Arguments: -# level The lowest debug level triggering the execution. -# script The tcl script executed upon a debug level high enough. -# -# Results: -# Arbitrary side effects, dependent on the executed script. -# -# Side Effects: -# None. -# - -proc tcltest::DebugDo {level script} { - variable debug - - if {$debug >= $level} { - uplevel $script - } - return -} - -##################################################################### - -# tcltest::CheckDirectory -- -# -# This procedure checks whether the specified path is a readable -# and/or writable directory. If one of the conditions is not -# satisfied an error is printed and the application aborted. The -# procedure assumes that the caller already checked the existence -# of the path. -# -# Arguments -# rw Information what attributes to check. Allowed values: -# r, w, rw, wr. If 'r' is part of the value the directory -# must be readable. 'w' associates to 'writable'. -# dir The directory to check. -# errMsg The string to prepend to the actual error message before -# printing it. -# -# Results -# none -# -# Side Effects: -# None. -# - -proc tcltest::CheckDirectory {rw dir errMsg} { - # Allowed values for 'rw': r, w, rw, wr - - if {![file isdir $dir]} { - set msg "$errMsg \"$dir\" is not a directory" - error $msg - } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - set msg "$errMsg \"$dir\" is not writeable" - error $msg - } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - set msg "$errMsg \"$dir\" is not readable" - error $msg - } - return -} - -# tcltest::normalizePath -- -# -# This procedure resolves any symlinks in the path thus creating a -# path without internal redirection. It assumes that the incoming -# path is absolute. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# -# Results -# The path is modified in place. -# -# Side Effects: -# None. -# - -proc tcltest::normalizePath {pathVar} { - upvar $pathVar path - - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd - return $path -} - - -# tcltest::MakeAbsolutePath -- -# -# This procedure checks whether the incoming path is absolute or not. -# Makes it absolute if it was not. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# prefix is optional, contains the path to use to make the other an -# absolute one. The current working directory is used if it was -# not specified. -# -# Results -# The path is modified in place. -# -# Side Effects: -# None. -# - -proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { - upvar $pathVar path - - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { - set prefix [pwd] - } - - set path [file join $prefix $path] - } - return $path -} - -##################################################################### - -# tcltest::<variableName> -# -# Accessor functions for tcltest variables that can be modified externally. -# These are vars that could otherwise be modified using command line -# arguments to tcltest. - -# tcltest::verbose -- -# -# Set or return the verbosity level (tcltest::verbose) for tests. This -# determines what gets printed to the screen and when, with regard to the -# running of the tests. The proc does not check for invalid values. It -# assumes that a string that doesn't match its predefined keywords -# is a string containing letter-specified verbosity levels. -# -# Arguments: -# A string containing any combination of 'pbste' or a list of keywords -# (listed in parens) -# p = print output whenever a test passes (pass) -# b = print the body of the test when it fails (body) -# s = print when a test is skipped (skip) -# t = print when a test starts (start) -# e = print errorInfo and errorCode when a test encounters an error -# (error) -# -# Results: -# content of tcltest::verbose - this is always the character combination -# (pbste) instead of the list form. -# -# Side effects: -# None. - -proc tcltest::verbose { {level ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::verbose - } - if {[llength $level] > 1} { - set tcltest::verbose $level - } else { - if {[regexp {pass|body|skip|start|error} $level]} { - set tcltest::verbose $level - } else { - set levelList [split $level {}] - set tcltest::verbose [string map {p pass b body s skip t start e - error} $levelList] - } - } - return $tcltest::verbose -} - -# tcltest::isVerbose -- -# -# Returns true if argument is one of the verbosity levels currently being -# used; returns false otherwise. -# -# Arguments: -# level -# -# Results: -# boolean 1 (true) or 0 (false), depending on whether or not the level -# provided is one of the ones stored in tcltest::verbose. -# -# Side effects: -# None. - -proc tcltest::isVerbose {level} { - if {[lsearch -exact [tcltest::verbose] $level] == -1} { - return 0 - } - return 1 -} - - - -# tcltest::match -- -# -# Set or return the match patterns (tcltest::match) that determine which -# tests are run. -# -# Arguments: -# List containing match patterns (glob format) -# -# Results: -# content of tcltest::match -# -# Side effects: -# none - -proc tcltest::match { {matchList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::match - } - set tcltest::match $matchList -} - -# tcltest::skip -- -# -# Set or return the skip patterns (tcltest::skip) that determine which -# tests are skipped. -# -# Arguments: -# List containing skip patterns (glob format) -# -# Results: -# content of tcltest::skip -# -# Side effects: -# None. - -proc tcltest::skip { {skipList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skip - } - set tcltest::skip $skipList -} - -# tcltest::matchFiles -- -# -# set or return the match patterns for file sourcing -# -# Arguments: -# list containing match file list (glob format) -# -# Results: -# content of tcltest::matchFiles -# -# Side effects: -# None. - -proc tcltest::matchFiles { {matchFileList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::matchFiles - } - set tcltest::matchFiles $matchFileList -} - -# tcltest::skipFiles -- -# -# set or return the skip patterns for file sourcing -# -# Arguments: -# list containing the skip file list (glob format) -# -# Results: -# content of tcltest::skipFiles -# -# Side effects: -# None. - -proc tcltest::skipFiles { {skipFileList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skipFiles - } - set tcltest::skipFiles $skipFileList -} - - -# tcltest::matchDirectories -- -# -# set or return the list of directories for matching (glob pattern list) -# -# Arguments: -# list of glob patterns matching subdirectories of -# tcltest::testsDirectory -# -# Results: -# content of tcltest::matchDirectories -# -# Side effects: -# None. - -proc tcltest::matchDirectories { {dirlist ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::matchDirectories - } - set tcltest::matchDirectories $dirlist -} - -# tcltest::skipDirectories -- -# -# set or return the list of directories to skip (glob pattern list) -# -# Arguments: -# list of glob patterns matching directories to skip; these directories -# are subdirectories of tcltest::testsDirectory -# -# Results: -# content of tcltest::skipDirectories -# -# Side effects: -# None. - -proc tcltest::skipDirectories { {dirlist ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skipDirectories - } - set tcltest::skipDirectories $dirlist -} - -# tcltest::preserveCore -- -# -# set or return the core preservation level. This proc does not do any -# error checking for invalid values. -# -# Arguments: -# core level: -# '0' = don't do anything with core files (default) -# '1' = notify the user if core files are created -# '2' = save any core files produced during testing to -# tcltest::temporaryDirectory -# -# Results: -# content of tcltest::preserveCore -# -# Side effects: -# None. - -proc tcltest::preserveCore { {coreLevel ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::preserveCore - } - set tcltest::preserveCore $coreLevel -} - -# tcltest::outputChannel -- -# -# set or return the output file descriptor based on the supplied file -# name (where tcltest puts all of its output) -# -# Arguments: -# output file descriptor -# -# Results: -# file descriptor corresponding to supplied file name (or currently set -# file descriptor, if no new filename was supplied) - this is the content -# of tcltest::outputChannel -# -# Side effects: -# None. - -proc tcltest::outputChannel { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::outputChannel - } - if {($filename == "stderr") || ($filename == "stdout")} { - set tcltest::outputChannel $filename - } else { - set tcltest::outputChannel [open $filename w] - } - return $tcltest::outputChannel -} - -# tcltest::outputFile -- -# -# set or return the output file name (where tcltest puts all of its -# output); calls tcltest::outputChannel to set the corresponding file -# descriptor -# -# Arguments: -# output file name -# -# Results: -# file name corresponding to supplied file name (or currently set -# file name, if no new filename was supplied) - this is the content -# of tcltest::outputFile -# -# Side effects: -# if the file name supplied is relative, it will be made absolute with -# respect to the predefined temporaryDirectory - -proc tcltest::outputFile { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::outputFile - } - if {($filename != "stderr") && ($filename != "stdout")} { - MakeAbsolutePath filename $tcltest::temporaryDirectory - } - tcltest::outputChannel $filename - set tcltest::outputFile $filename -} - -# tcltest::errorChannel -- -# -# set or return the error file descriptor based on the supplied file name -# (where tcltest sends all its errors) -# -# Arguments: -# error file name -# -# Results: -# file descriptor corresponding to the supplied file name (or currently -# set file descriptor, if no new filename was supplied) - this is the -# content of tcltest::errorChannel -# -# Side effects: -# opens the descriptor in w mode unless the filename is set to stderr or -# stdout - -proc tcltest::errorChannel { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::errorChannel - } - if {($filename == "stderr") || ($filename == "stdout")} { - set tcltest::errorChannel $filename - } else { - set tcltest::errorChannel [open $filename w] - } - return $tcltest::errorChannel -} - -# tcltest::errorFile -- -# -# set or return the error file name; calls tcltest::errorChannel to set -# the corresponding file descriptor -# -# Arguments: -# error file name -# -# Results: -# content of tcltest::errorFile -# -# Side effects: -# if the file name supplied is relative, it will be made absolute with -# respect to the predefined temporaryDirectory - -proc tcltest::errorFile { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::errorFile - } - if {($filename != "stderr") && ($filename != "stdout")} { - MakeAbsolutePath filename $tcltest::temporaryDirectory - } - set tcltest::errorFile $filename - errorChannel $tcltest::errorFile - return $tcltest::errorFile -} - -# tcltest::debug -- -# -# set or return the debug level for tcltest; this proc does not check for -# invalid values -# -# Arguments: -# debug level: -# '0' = no debug output (default) -# '1' = skipped tests -# '2' = tcltest variables and supplied flags -# '3' = harness operations -# -# Results: -# content of tcltest::debug -# -# Side effects: -# None. - -proc tcltest::debug { {debugLevel ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::debug - } - set tcltest::debug $debugLevel -} - -# tcltest::testConstraint -- -# -# sets a test constraint to a value; to do multiple constraints, call -# this proc multiple times. also returns the value of the named -# constraint if no value was supplied. -# -# Arguments: -# constraint - name of the constraint -# value - new value for constraint (should be boolean) - if not supplied, -# this is a query -# -# Results: -# content of tcltest::testConstraints($constraint) -# -# Side effects: -# appends the constraint name to tcltest::constraintsSpecified - -proc tcltest::testConstraint {constraint {value ""}} { - DebugPuts 3 "entering testConstraint $constraint $value" - if {[llength [info level 0]] == 2} { - return $tcltest::testConstraints($constraint) - } - lappend tcltest::constraintsSpecified $constraint - set tcltest::testConstraints($constraint) $value -} - -# tcltest::constraintsSpecified -- -# -# returns a list of all the constraint names specified using -# testConstraint -# -# Arguments: -# None. -# -# Results: -# list of the constraint names in tcltest::constraintsSpecified -# -# Side effects: -# None. - -proc tcltest::constraintsSpecified {} { - return $tcltest::constraintsSpecified -} - -# tcltest::constraintList -- -# -# returns a list of all the constraint names -# -# Arguments: -# None. -# -# Results: -# list of the constraint names in tcltest::testConstraints -# -# Side effects: -# None. - -proc tcltest::constraintList {} { - return [array names tcltest::testConstraints] -} - -# tcltest::limitConstraints -- -# -# sets the limited constraints to tcltest::limitConstraints -# -# Arguments: -# list of constraint names -# -# Results: -# content of tcltest::limitConstraints -# -# Side effects: -# None. - -proc tcltest::limitConstraints { {constraintList ""} } { - DebugPuts 3 "entering limitConstraints $constraintList" - if {[llength [info level 0]] == 1} { - return $tcltest::limitConstraints - } - set tcltest::limitConstraints $constraintList - foreach elt [tcltest::constraintList] { - if {[lsearch -exact [tcltest::constraintsSpecified] $elt] == -1} { - tcltest::testConstraint $elt 0 - } - } - return $tcltest::limitConstraints -} - -# tcltest::loadScript -- -# -# sets the load script -# -# Arguments: -# script to be set -# -# Results: -# contents of tcltest::loadScript -# -# Side effects: -# None. - -proc tcltest::loadScript { {script ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::loadScript - } - set tcltest::loadScript $script -} - -# tcltest::loadFile -- -# -# set the load file (containing the load script); -# put the content of the load file into loadScript -# -# Arguments: -# script's file name -# -# Results: -# content of tcltest::loadFile -# -# Side effects: -# None. - -proc tcltest::loadFile { {scriptFile ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::loadFile - } - MakeAbsolutePath scriptFile $tcltest::temporaryDirectory - set tmp [open $scriptFile r] - tcltest::loadScript [read $tmp] - close $tmp - set tcltest::loadFile $scriptFile -} - -# tcltest::workingDirectory -- -# -# set workingDirectory to the given path. -# If the path is relative, make it absolute. -# change directory to the stated working directory, if resetting the -# value -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::workingDirectory -# -# Side effects: -# None. - -proc tcltest::workingDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::workingDirectory - } - set tcltest::workingDirectory $dir - MakeAbsolutePath tcltest::workingDirectory - cd $tcltest::workingDirectory - return $tcltest::workingDirectory -} - -# tcltest::temporaryDirectory -- -# -# Set tcltest::temporaryDirectory to the given path. -# If the path is relative, make it absolute. If the file exists but -# is not a dir, then return an error. -# -# If tcltest::temporaryDirectory does not already exist, create it. -# If you cannot create it, then return an error (the file mkdir isn't -# caught and will propagate). -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::temporaryDirectory -# -# Side effects: -# None. - -proc tcltest::temporaryDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::temporaryDirectory - } - set tcltest::temporaryDirectory $dir - - MakeAbsolutePath tcltest::temporaryDirectory - set tmpDirError "bad argument for temporary directory: " - - if {[file exists $tcltest::temporaryDirectory]} { - tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError - } else { - file mkdir $tcltest::temporaryDirectory - } - - normalizePath tcltest::temporaryDirectory -} - -# tcltest::testsDirectory -- -# -# Set tcltest::testsDirectory to the given path. -# If the path is relative, make it absolute. If the file exists but -# is not a dir, then return an error. -# -# If tcltest::testsDirectory does not already exist, return an error. -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::testsDirectory -# -# Side effects: -# None. - -proc tcltest::testsDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::testsDirectory - } - - set tcltest::testsDirectory $dir - - MakeAbsolutePath tcltest::testsDirectory - set testDirError "bad argument for tests directory: " - - if {[file exists $tcltest::testsDirectory]} { - tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError - } else { - set msg "$testDirError \"$tcltest::testsDirectory\" does not exist" - error $msg - } - - normalizePath tcltest::testsDirectory -} - -# tcltest::singleProcess -- -# -# sets tcltest::singleProcess to the value provided. -# -# Arguments: -# value for singleProcess: -# 1 = source each test file into the current process -# 0 = run each test file in its own process -# -# Results: -# content of tcltest::singleProcess -# -# Side effects: -# None. - -proc tcltest::singleProcess { {value ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::singleProcess - } - set tcltest::singleProcess $value -} - -# tcltest::interpreter -- -# -# the interpreter name stored in tcltest::tcltest -# -# Arguments: -# executable name -# -# Results: -# content of tcltest::tcltest -# -# Side effects: -# None. - -proc tcltest::interpreter { {interp ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::tcltest - } - set tcltest::tcltest $interp -} - -# tcltest::mainThread -- -# -# sets or returns the thread id stored in tcltest::mainThread -# -# Arguments: -# thread id -# -# Results: -# content of tcltest::mainThread -# -# Side effects: -# None. - -proc tcltest::mainThread { {threadid ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::mainThread - } - set tcltest::mainThread $threadid -} - -##################################################################### - -# tcltest::AddToSkippedBecause -- -# -# Increments the variable used to track how many tests were skipped -# because of a particular constraint. -# -# Arguments: -# constraint The name of the constraint to be modified -# -# Results: -# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't -# previously exist - otherwise, it just increments it. -# -# Side effects: -# None. - -proc tcltest::AddToSkippedBecause { constraint {value 1}} { - # add the constraint to the list of constraints that kept tests - # from running - - if {[info exists tcltest::skippedBecause($constraint)]} { - incr tcltest::skippedBecause($constraint) $value - } else { - set tcltest::skippedBecause($constraint) $value - } - return -} - -# tcltest::PrintError -- -# -# Prints errors to tcltest::errorChannel and then flushes that -# channel, making sure that all messages are < 80 characters per line. -# -# Arguments: -# errorMsg String containing the error to be printed -# -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::PrintError {errorMsg} { - set InitialMessage "Error: " - set InitialMsgLen [string length $InitialMessage] - puts -nonewline [errorChannel] $InitialMessage - - # Keep track of where the end of the string is. - set endingIndex [string length $errorMsg] - - if {$endingIndex < 80} { - puts [errorChannel] $errorMsg - } else { - # Print up to 80 characters on the first line, including the - # InitialMessage. - set beginningIndex [string last " " [string range $errorMsg 0 \ - [expr {80 - $InitialMsgLen}]]] - puts [errorChannel] [string range $errorMsg 0 $beginningIndex] - - while {$beginningIndex != "end"} { - puts -nonewline [errorChannel] \ - [string repeat " " $InitialMsgLen] - if {[expr {$endingIndex - $beginningIndex}] < 72} { - puts [errorChannel] [string trim \ - [string range $errorMsg $beginningIndex end]] - set beginningIndex end - } else { - set newEndingIndex [expr [string last " " [string range \ - $errorMsg $beginningIndex \ - [expr {$beginningIndex + 72}]]] + $beginningIndex] - if {($newEndingIndex <= 0) \ - || ($newEndingIndex <= $beginningIndex)} { - set newEndingIndex end - } - puts [errorChannel] [string trim \ - [string range $errorMsg \ - $beginningIndex $newEndingIndex]] - set beginningIndex $newEndingIndex - } - } - } - flush [errorChannel] - return -} - -if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { - proc tcltest::initConstraintsHook {} {} -} - -# tcltest::safeFetch -- -# -# The following trace procedure makes it so that we can safely refer to -# non-existent members of the tcltest::testConstraints array without -# causing an error. Instead, reading a non-existent member will return -# 0. This is necessary because tests are allowed to use constraint "X" -# without ensuring that tcltest::testConstraints("X") is defined. -# -# Arguments: -# n1 - name of the array (tcltest::testConstraints) -# n2 - array key value (constraint name) -# op - operation performed on tcltest::testConstraints (generally r) -# -# Results: -# none -# -# Side effects: -# sets tcltest::testConstraints($n2) to 0 if it's referenced but never -# before used - -proc tcltest::safeFetch {n1 n2 op} { - DebugPuts 3 "entering safeFetch $n1 $n2 $op" - if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { - tcltest::testConstraint $n2 0 - } -} - -# tcltest::initConstraints -- -# -# Check constraint information that will determine which tests -# to run. To do this, create an array tcltest::testConstraints. Each -# element has a 0 or 1 value. If the element is "true" then tests -# with that constraint will be run, otherwise tests with that constraint -# will be skipped. See the tcltest man page for the list of built-in -# constraints defined in this procedure. -# -# Arguments: -# none -# -# Results: -# The tcltest::testConstraints array is reset to have an index for -# each built-in test constraint. -# -# Side Effects: -# None. -# - -proc tcltest::initConstraints {} { - global tcl_platform tcl_interactive tk_version - - # Safely refer to non-existent members of the tcltest::testConstraints - # array without causing an error. - trace variable tcltest::testConstraints r tcltest::safeFetch - - tcltest::initConstraintsHook - - tcltest::testConstraint singleTestInterp [singleProcess] - - # All the 'pc' constraints are here for backward compatibility and are not - # documented. They have been replaced with equivalent 'win' constraints. - - tcltest::testConstraint unixOnly \ - [string equal $tcl_platform(platform) "unix"] - tcltest::testConstraint macOnly \ - [string equal $tcl_platform(platform) "macintosh"] - tcltest::testConstraint pcOnly \ - [string equal $tcl_platform(platform) "windows"] - tcltest::testConstraint winOnly \ - [string equal $tcl_platform(platform) "windows"] - - tcltest::testConstraint unix [tcltest::testConstraint unixOnly] - tcltest::testConstraint mac [tcltest::testConstraint macOnly] - tcltest::testConstraint pc [tcltest::testConstraint pcOnly] - tcltest::testConstraint win [tcltest::testConstraint winOnly] - - tcltest::testConstraint unixOrPc \ - [expr {[tcltest::testConstraint unix] \ - || [tcltest::testConstraint pc]}] - tcltest::testConstraint macOrPc \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint pc]}] - tcltest::testConstraint unixOrWin \ - [expr {[tcltest::testConstraint unix] \ - || [tcltest::testConstraint win]}] - tcltest::testConstraint macOrWin \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint win]}] - tcltest::testConstraint macOrUnix \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint unix]}] - - tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"] - tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"] - tcltest::testConstraint 98 [string equal $tcl_platform(os) "Windows 98"] - - # The following Constraints switches are used to mark tests that should - # work, but have been temporarily disabled on certain platforms because - # they don't and we haven't gotten around to fixing the underlying - # problem. - - tcltest::testConstraint tempNotPc \ - [expr {![tcltest::testConstraint pc]}] - tcltest::testConstraint tempNotWin \ - [expr {![tcltest::testConstraint win]}] - tcltest::testConstraint tempNotMac \ - [expr {![tcltest::testConstraint mac]}] - tcltest::testConstraint tempNotUnix \ - [expr {![tcltest::testConstraint unix]}] - - # The following Constraints switches are used to mark tests that crash on - # certain platforms, so that they can be reactivated again when the - # underlying problem is fixed. - - tcltest::testConstraint pcCrash \ - [expr {![tcltest::testConstraint pc]}] - tcltest::testConstraint winCrash \ - [expr {![tcltest::testConstraint win]}] - tcltest::testConstraint macCrash \ - [expr {![tcltest::testConstraint mac]}] - tcltest::testConstraint unixCrash \ - [expr {![tcltest::testConstraint unix]}] - - # Skip empty tests - - tcltest::testConstraint emptyTest 0 - - # By default, tests that expose known bugs are skipped. - - tcltest::testConstraint knownBug 0 - - # By default, non-portable tests are skipped. - - tcltest::testConstraint nonPortable 0 - - # Some tests require user interaction. - - tcltest::testConstraint userInteraction 0 - - # Some tests must be skipped if the interpreter is not in interactive mode - - if {[info exists tcl_interactive]} { - tcltest::testConstraint interactive $::tcl_interactive - } else { - tcltest::testConstraint interactive 0 - } - - # Some tests can only be run if the installation came from a CD image - # instead of a web image - # Some tests must be skipped if you are running as root on Unix. - # Other tests can only be run if you are running as root on Unix. - - tcltest::testConstraint root 0 - tcltest::testConstraint notRoot 1 - set user {} - if {[string equal $tcl_platform(platform) "unix"]} { - catch {set user [exec whoami]} - if {[string equal $user ""]} { - catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} - } - if {([string equal $user "root"]) || ([string equal $user ""])} { - tcltest::testConstraint root 1 - tcltest::testConstraint notRoot 0 - } - } - - # Set nonBlockFiles constraint: 1 means this platform supports - # ting files into nonblocking mode. - - if {[catch {set f [open defs r]}]} { - tcltest::testConstraint nonBlockFiles 1 - } else { - if {[catch {fconfigure $f -blocking off}] == 0} { - tcltest::testConstraint nonBlockFiles 1 - } else { - tcltest::testConstraint nonBlockFiles 0 - } - close $f - } - - # Set asyncPipeClose constraint: 1 means this platform supports - # async flush and async close on a pipe. - # - # Test for SCO Unix - cannot run async flushing tests because a - # potential problem with select is apparently interfering. - # (Mark Diekhans). - - if {[string equal $tcl_platform(platform) "unix"]} { - if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - tcltest::testConstraint asyncPipeClose 0 - } else { - tcltest::testConstraint asyncPipeClose 1 - } - } else { - tcltest::testConstraint asyncPipeClose 1 - } - - # Test to see if we have a broken version of sprintf with respect - # to the "e" format of floating-point numbers. - - tcltest::testConstraint eformat 1 - if {![string equal "[format %g 5e-5]" "5e-05"]} { - tcltest::testConstraint eformat 0 - } - - # Test to see if execed commands such as cat, echo, rm and so forth are - # present on this machine. - - tcltest::testConstraint unixExecs 1 - if {[string equal $tcl_platform(platform) "macintosh"]} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([string equal $tcl_platform(platform) "windows"])} { - if {[catch {exec cat defs}] == 1} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec echo hello}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec sh -c echo hello}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec wc defs}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {[tcltest::testConstraint unixExecs] == 1} { - exec echo hello > removeMe - if {[catch {exec rm removeMe}] == 1} { - tcltest::testConstraint unixExecs 0 - } - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec sleep 1}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec fgrep unixExecs defs}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec ps}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec echo abc > removeMe}] == 0) && \ - ([catch {exec chmod 644 removeMe}] == 1) && \ - ([catch {exec rm removeMe}] == 0)} { - tcltest::testConstraint unixExecs 0 - } else { - catch {exec rm -f removeMe} - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec mkdir removeMe}] == 1)} { - tcltest::testConstraint unixExecs 0 - } else { - catch {exec rm -r removeMe} - } - } - - # Locate tcltest executable - - if {![info exists tk_version]} { - set tcltest::tcltest [info nameofexecutable] - - if {$tcltest::tcltest == "{}"} { - set tcltest::tcltest {} - } - } - - tcltest::testConstraint stdio 0 - catch { - catch {file delete -force tmp} - set f [open tmp w] - puts $f { - exit - } - close $f - - set f [open "|[list $tcltest tmp]" r] - close $f - - tcltest::testConstraint stdio 1 - } - catch {file delete -force tmp} - - # Deliberately call socket with the wrong number of arguments. The error - # message you get will indicate whether sockets are available on this - # system. - - catch {socket} msg - tcltest::testConstraint socket \ - [expr {$msg != "sockets are not available on this system"}] - - # Check for internationalization - - if {[info commands testlocale] == ""} { - # No testlocale command, no tests... - tcltest::testConstraint hasIsoLocale 0 - } else { - tcltest::testConstraint hasIsoLocale \ - [string length [tcltest::set_iso8859_1_locale]] - tcltest::restore_locale - } -} - -##################################################################### - -# Handle command line arguments (from argv) and default arg settings -# (in TCLTEST_OPTIONS). - -# tcltest::PrintUsageInfoHook -# -# Hook used for customization of display of usage information. -# - -if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} { - proc tcltest::PrintUsageInfoHook {} {} -} - -# tcltest::PrintUsageInfo -# -# Prints out the usage information for package tcltest. This can be -# customized with the redefinition of tcltest::PrintUsageInfoHook. -# -# Arguments: -# none -# -# Results: -# none -# -# Side Effects: -# none - -proc tcltest::PrintUsageInfo {} { - puts [format "Usage: [file tail [info nameofexecutable]] \ - script ?-help? ?flag value? ... \n\ - Available flags (and valid input values) are: \n\ - -help \t Display this usage information. \n\ - -verbose level \t Takes any combination of the values \n\ - \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\ - \t display all passed tests if 'p' is \n\ - \t specified, all skipped tests if 's' \n\ - \t is specified, the bodies of \n\ - \t failed tests if 'b' is specified, \n\ - \t and when tests start if 't' is specified. \n\ - \t ErrorInfo is displayed if 'e' is specified. \n\ - \t The default value is 'b'. \n\ - -constraints list\t Do not skip the listed constraints\n\ - -limitconstraints bool\t Only run tests with the constraints\n\ - \t listed in -constraints.\n\ - -match pattern \t Run all tests within the specified \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -skip pattern \t Skip all tests within the set of \n\ - \t specified tests (via -match) and \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -file pattern \t Run tests in all test files that \n\ - \t match the glob pattern given. \n\ - -notfile pattern\t Skip all test files that match the \n\ - \t glob pattern given. \n\ - -relateddir pattern\t Run tests in directories that match \n\ - \t the glob pattern given. \n\ - -asidefromdir pattern\t Skip tests in directories that match \n\ - \t the glob pattern given.\n\ - -preservecore level \t If 2, save any core files produced \n\ - \t during testing in the directory \n\ - \t specified by -tmpdir. If 1, notify the\n\ - \t user if core files are created. The default \n\ - \t is $tcltest::preserveCore. \n\ - -tmpdir directory\t Save temporary files in the specified\n\ - \t directory. The default value is \n\ - \t $tcltest::temporaryDirectory. \n\ - -testdir directories\t Search tests in the specified\n\ - \t directories. The default value is \n\ - \t $tcltest::testsDirectory. \n\ - -outfile file \t Send output from test runs to the \n\ - \t specified file. The default is \n\ - \t stdout. \n\ - -errfile file \t Send errors from test runs to the \n\ - \t specified file. The default is \n\ - \t stderr. \n\ - -loadfile file \t Read the script to load the tested \n\ - \t commands from the specified file. \n\ - -load script \t Specifies the script to load the tested \n\ - \t commands. \n\ - -debug level \t Internal debug flag."] - tcltest::PrintUsageInfoHook - return -} - -# tcltest::processCmdLineArgsFlagsHook -- -# -# This hook is used to add to the list of command line arguments that are -# processed by tcltest::ProcessFlags. It is called at the beginning of -# ProcessFlags. -# - -if {[namespace inscope tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { - proc tcltest::processCmdLineArgsAddFlagsHook {} {} -} - -# tcltest::processCmdLineArgsHook -- -# -# This hook is used to actually process the flags added by -# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of -# ProcessFlags. -# -# Arguments: -# flags The flags that have been pulled out of argv -# - -if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} { - proc tcltest::processCmdLineArgsHook {flag} {} -} - -# tcltest::ProcessFlags -- -# -# process command line arguments supplied in the flagArray - this is -# called by processCmdLineArgs -# modifies tcltest variables according to the content of the flagArray. -# -# Arguments: -# flagArray - array containing name/value pairs of flags -# -# Results: -# sets tcltest variables according to their values as defined by -# flagArray -# -# Side effects: -# None. - -proc tcltest::ProcessFlags {flagArray} { - # Process -help first - if {[lsearch -exact $flagArray {-help}] != -1} { - tcltest::PrintUsageInfo - exit 1 - } - - catch {array set flag $flagArray} - - # -help is not listed since it has already been processed - lappend defaultFlags -verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints -testdir \ - -load -loadfile -asidefromdir \ - -relateddir -singleproc - set defaultFlags [concat $defaultFlags \ - [tcltest::processCmdLineArgsAddFlagsHook ]] - - # Set tcltest::verbose to the arg of the -verbose flag, if given - if {[info exists flag(-verbose)]} { - tcltest::verbose $flag(-verbose) - } - - # Set tcltest::match to the arg of the -match flag, if given. - if {[info exists flag(-match)]} { - tcltest::match $flag(-match) - } - - # Set tcltest::skip to the arg of the -skip flag, if given - if {[info exists flag(-skip)]} { - tcltest::skip $flag(-skip) - } - - # Handle the -file and -notfile flags - if {[info exists flag(-file)]} { - tcltest::matchFiles $flag(-file) - } - if {[info exists flag(-notfile)]} { - tcltest::skipFiles $flag(-notfile) - } - - # Handle -relateddir and -asidefromdir flags - if {[info exists flag(-relateddir)]} { - tcltest::matchDirectories $flag(-relateddir) - } - if {[info exists flag(-asidefromdir)]} { - tcltest::skipDirectories $flag(-asidefromdir) - } - - # Use the -constraints flag, if given, to turn on constraints that are - # turned off by default: userInteractive knownBug nonPortable. This - # code fragment must be run after constraints are initialized. - - if {[info exists flag(-constraints)]} { - foreach elt $flag(-constraints) { - tcltest::testConstraint $elt 1 - } - } - - # Use the -limitconstraints flag, if given, to tell the harness to limit - # tests run to those that were specified using the -constraints flag. If - # the -constraints flag was not specified, print out an error and exit. - if {[info exists flag(-limitconstraints)]} { - if {![info exists flag(-constraints)]} { - set msg "-limitconstraints flag can only be used with -constraints" - error $msg - } - tcltest::limitConstraints $flag(-limitconstraints) - } - - # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if - # given. - - if {[info exists flag(-tmpdir)]} { - tcltest::temporaryDirectory $flag(-tmpdir) - } - - # Set the tcltest::testsDirectory to the arg of -testdir, if - # given. - - if {[info exists flag(-testdir)]} { - tcltest::testsDirectory $flag(-testdir) - } - - # If an alternate error or output files are specified, change the - # default channels. - - if {[info exists flag(-outfile)]} { - tcltest::outputFile $flag(-outfile) - } - - if {[info exists flag(-errfile)]} { - tcltest::errorFile $flag(-errfile) - } - - # If a load script was specified, either directly or through - # a file, remember it for later usage. - - if {[info exists flag(-load)] && \ - ([lsearch -exact $flagArray -load] > \ - [lsearch -exact $flagArray -loadfile])} { - tcltest::loadScript $flag(-load) - } - - if {[info exists flag(-loadfile)] && \ - ([lsearch -exact $flagArray -loadfile] > \ - [lsearch -exact $flagArray -load]) } { - tcltest::loadFile $flag(-loadfile) - } - - # If the user specifies debug testing, print out extra information during - # the run. - if {[info exists flag(-debug)]} { - tcltest::debug $flag(-debug) - } - - # Handle -preservecore - if {[info exists flag(-preservecore)]} { - tcltest::preserveCore $flag(-preservecore) - } - - # Handle -singleproc flag - if {[info exists flag(-singleproc)]} { - tcltest::singleProcess $flag(-singleproc) - } - - # Call the hook - tcltest::processCmdLineArgsHook [array get flag] - return -} - -# tcltest::processCmdLineArgs -- -# -# Use command line args to set tcltest namespace variables. -# -# This procedure must be run after constraints are initialized, because -# some constraints can be overridden. -# -# Set variables based on the contents of the environment variable -# TCLTEST_OPTIONS first, then override with command-line options, if -# specified. -# -# Arguments: -# none -# -# Results: -# Sets the above-named variables in the tcltest namespace. -# -# Side Effects: -# None. -# - -proc tcltest::processCmdLineArgs {} { - global argv - - # If the TCLTEST_OPTIONS environment variable exists, parse it first, then - # the argv list. The command line argument parsing will be a two-pass - # affair from now on, so that TCLTEST_OPTIONS contain the default options. - # These can be overridden by the command line flags. - - if {[info exists ::env(TCLTEST_OPTIONS)]} { - tcltest::ProcessFlags $::env(TCLTEST_OPTIONS) - } - - # The "argv" var doesn't exist in some cases, so use {}. - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv - } - - tcltest::ProcessFlags $flagArray - - # Spit out everything you know if we're at a debug level 2 or greater - DebugPuts 2 "Flags passed into tcltest:" - if {[info exists ::env(TCLTEST_OPTIONS)]} { - DebugPuts 2 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" - } - if {[info exists argv]} { - DebugPuts 2 " argv: $argv" - } - DebugPuts 2 "tcltest::debug = [tcltest::debug]" - DebugPuts 2 "tcltest::testsDirectory = [tcltest::testsDirectory]" - DebugPuts 2 "tcltest::workingDirectory = [tcltest::workingDirectory]" - DebugPuts 2 "tcltest::temporaryDirectory = [tcltest::temporaryDirectory]" - DebugPuts 2 "tcltest::outputChannel = [outputChannel]" - DebugPuts 2 "tcltest::errorChannel = [errorChannel]" - DebugPuts 2 "Original environment (tcltest::originalEnv):" - DebugPArray 2 tcltest::originalEnv - DebugPuts 2 "Constraints:" - DebugPArray 2 tcltest::testConstraints - return -} - -##################################################################### - -# Code to run the tests goes here. - -# tcltest::testPuts -- -# -# Used to redefine puts in test environment. -# Stores whatever goes out on stdout in tcltest::outData and stderr in -# tcltest::errData before sending it on to the regular puts. -# -# Arguments: -# same as standard puts -# -# Results: -# none -# -# Side effects: -# Intercepts puts; data that would otherwise go to stdout, stderr, or -# file channels specified in tcltest::outputChannel and errorChannel does -# not get sent to the normal puts function. - -proc tcltest::testPuts {args} { - set len [llength $args] - if {$len == 1} { - # Only the string to be printed is specified - append tcltest::outData "[lindex $args 0]\n" - return -# return [tcltest::normalPuts [lindex $args 0]] - } elseif {$len == 2} { - # Either -nonewline or channelId has been specified - if {[regexp {^-nonewline} [lindex $args 0]]} { - append tcltest::outData "[lindex $args end]" - return -# return [tcltest::normalPuts -nonewline [lindex $args end]] - } else { - set channel [lindex $args 0] - } - } elseif {$len == 3} { - if {[lindex $args 0] == "-nonewline"} { - # Both -nonewline and channelId are specified, unless it's an - # error. -nonewline is supposed to be argv[0]. - set channel [lindex $args 1] - } - } - - if {[info exists channel]} { - if {($channel == [outputChannel]) || ($channel == "stdout")} { - append tcltest::outData "[lindex $args end]\n" - } elseif {($channel == [errorChannel]) || ($channel == "stderr")} { - append tcltest::errData "[lindex $args end]\n" - } - return - # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]] - } - - # If we haven't returned by now, we don't know how to handle the input. - # Let puts handle it. - return [eval tcltest::normalPuts $args] -} - -# tcltest::testEval -- -# -# Evaluate the script in the test environment. If ignoreOutput is -# false, store data sent to stderr and stdout in tcltest::outData and -# tcltest::errData. Otherwise, ignore this output altogether. -# -# Arguments: -# script Script to evaluate -# ?ignoreOutput? Indicates whether or not to ignore output sent to -# stdout & stderr -# -# Results: -# result from running the script -# -# Side effects: -# Empties the contents of tcltest::outData and tcltest::errData before -# running a test if ignoreOutput is set to 0. - -proc tcltest::testEval {script {ignoreOutput 1}} { - DebugPuts 3 "testEval called" - if {!$ignoreOutput} { - set tcltest::outData {} - set tcltest::errData {} - uplevel rename ::puts tcltest::normalPuts - uplevel rename tcltest::testPuts ::puts - } - set result [uplevel $script] - if {!$ignoreOutput} { - uplevel rename ::puts tcltest::testPuts - uplevel rename tcltest::normalPuts ::puts - } - return $result -} - -# compareStrings -- -# -# compares the expected answer to the actual answer, depending on the -# mode provided. Mode determines whether a regexp, exact, or glob -# comparison is done. -# -# Arguments: -# actual - string containing the actual result -# expected - pattern to be matched against -# mode - type of comparison to be done -# -# Results: -# result of the match -# -# Side effects: -# None. - -proc tcltest::compareStrings {actual expected mode} { - switch -- $mode { - exact { - set retval [string equal $actual $expected] - } - glob { - set retval [string match $expected $actual] - } - regexp { - set retval [regexp -- $expected $actual] - } - } - return $retval -} - - -# -# tcltest::substArguments list -# -# This helper function takes in a list of words, then perform a -# substitution on the list as though each word in the list is a -# separate argument to the Tcl function. For example, if this -# function is invoked as: -# -# substArguments {$a {$a}} -# -# Then it is as though the function is invoked as: -# -# substArguments $a {$a} -# -# This code is adapted from Paul Duffin's function "SplitIntoWords". -# The original function can be found on: -# -# http://purl.org/thecliff/tcl/wiki/858.html -# -# Results: -# a list containing the result of the substitution -# -# Exceptions: -# An error may occur if the list containing unbalanced quote or -# unknown variable. -# -# Side Effects: -# None. -# - -proc tcltest::substArguments {argList} { - - # We need to split the argList up into tokens but cannot use - # list operations as they throw away some significant - # quoting, and [split] ignores braces as it should. - # Therefore what we do is gradually build up a string out of - # whitespace seperated strings. We cannot use [split] to - # split the argList into whitespace seperated strings as it - # throws away the whitespace which maybe important so we - # have to do it all by hand. - - set result {} - set token "" - - while {[string length $argList]} { - # Look for the next word containing a quote: " { } - if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ - $argList all]} { - # Get the text leading up to this word, but not - # including this word, from the argList. - set text [string range $argList 0 \ - [expr {[lindex $all 0] - 1}]] - # Get the word with the quote - set word [string range $argList \ - [lindex $all 0] [lindex $all 1]] - - # Remove all text up to and including the word from the - # argList. - set argList [string range $argList \ - [expr {[lindex $all 1] + 1}] end] - } else { - # Take everything up to the end of the argList. - set text $argList - set word {} - set argList {} - } - - if {$token != {}} { - # If we saw a word with quote before, then there is a - # multi-word token starting with that word. In this case, - # add the text and the current word to this token. - append token $text $word - } else { - # Add the text to the result. There is no need to parse - # the text because it couldn't be a part of any multi-word - # token. Then start a new multi-word token with the word - # because we need to pass this token to the Tcl parser to - # check for balancing quotes - append result $text - set token $word - } - - if { [catch {llength $token} length] == 0 && $length == 1} { - # The token is a valid list so add it to the result. - # lappend result [string trim $token] - append result \{$token\} - set token {} - } - } - - # If the last token has not been added to the list then there - # is a problem. - if { [string length $token] } { - error "incomplete token \"$token\"" - } - - return $result -} - - -# tcltest::test -- -# -# This procedure runs a test and prints an error message if the test fails. -# If tcltest::verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# tcltest::match variable, if it matches an element in -# tcltest::skip, or if one of the elements of "constraints" turns -# out not to be true. -# -# If testLevel is 1, then this is a top level test, and we record pass/fail -# information; otherwise, this information is not logged and is not added to -# running totals. -# -# Attributes: -# Only description is a required attribute. All others are optional. -# Default values are indicated. -# -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "tcltest::testConstraints". If any -# of these elements is zero, the test is -# skipped. This attribute is optional; default is {} -# body - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. This attribute is optional; -# default is {} -# result - Expected result from script. This attribute is -# optional; default is {}. -# output - Expected output sent to stdout. This attribute -# is optional; default is {}. -# errorOutput - Expected output sent to stderr. This attribute -# is optional; default is {}. -# returnCodes - Expected return codes. This attribute is -# optional; default is {0 2}. -# setup - Code to run before $script (above). This -# attribute is optional; default is {}. -# cleanup - Code to run after $script (above). This -# attribute is optional; default is {}. -# match - specifies type of matching to do on result, -# output, errorOutput; this must be one of: exact, -# glob, regexp. default is exact. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# -# Results: -# 0 if the command ran successfully; 1 otherwise. -# -# Side effects: -# None. -# - -proc tcltest::test {name description args} { - DebugPuts 3 "Test $name $args" - - incr tcltest::testLevel - - # Pre-define everything to null except output and errorOutput. We - # determine whether or not to trap output based on whether or not these - # variables (output & errorOutput) are defined. - foreach item {constraints setup cleanup body result returnCodes match} { - set $item {} - } - - # Set the default match mode - set match exact - - # Set the default match values for return codes (0 is the standard expected - # return value if everything went well; 2 represents 'return' being used in - # the test script). - set returnCodes [list 0 2] - - # The old test format can't have a 3rd argument (constraints or script) - # that starts with '-'. - if {[llength $args] == 0} { - puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}" - incr tcltest::testLevel -1 - return 1 - } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} { - - if {[llength $args] == 1} { - set list [substArguments [lindex $args 0]] - foreach {element value} $list { - set testAttributes($element) $value - } - foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { - if {[info exists testAttributes([subst -$item])]} { - set testAttributes([subst -$item]) \ - [uplevel concat $testAttributes([subst -$item])] - } - } - } else { - array set testAttributes $args - } - - set validFlags {-setup -cleanup -body -result -returnCodes -match \ - -output -errorOutput -constraints} - - foreach flag [array names testAttributes] { - if {[lsearch -exact $validFlags $flag] == -1} { - puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test" - incr tcltest::testLevel -1 - return 1 - } - } - - # store whatever the user gave us - foreach item [array names testAttributes] { - set [string trimleft $item "-"] $testAttributes($item) - } - - # Check the values supplied for -match - if {[lsearch {regexp glob exact} $match] == -1} { - puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}" - incr tcltest::testLevel -1 - return 1 - } - - # Replace symbolic valies supplied for -returnCodes - regsub -nocase normal $returnCodes 0 returnCodes - regsub -nocase error $returnCodes 1 returnCodes - regsub -nocase return $returnCodes 2 returnCodes - regsub -nocase break $returnCodes 3 returnCodes - regsub -nocase continue $returnCodes 4 returnCodes - } else { - # This is parsing for the old test command format; it is here for - # backward compatibility. - set result [lindex $args end] - if {[llength $args] == 2} { - set body [lindex $args 0] - } elseif {[llength $args] == 3} { - set constraints [lindex $args 0] - set body [lindex $args 1] - } else { - puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}" - incr tcltest::testLevel -1 - return 1 - } - } - - set setupFailure 0 - set cleanupFailure 0 - - # Run the setup script - if {[catch {uplevel $setup} setupMsg]} { - set setupFailure 1 - } - - # run the test script - set command [list tcltest::runTest $name $description $body \ - $result $constraints] - if {!$setupFailure} { - if {[info exists output] || [info exists errorOutput]} { - set testResult [uplevel tcltest::testEval [list $command] 0] - } else { - set testResult [uplevel tcltest::testEval [list $command] 1] - } - } else { - set testResult setupFailure - } - - # Run the cleanup code - if {[catch {uplevel $cleanup} cleanupMsg]} { - set cleanupFailure 1 - } - - # If testResult is an empty list, then the test was skipped - if {$testResult != {}} { - set coreFailure 0 - set coreMsg "" - # check for a core file first - if one was created by the test, then - # the test failed - if {$tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - if {[file exists [file join [tcltest::workingDirectory] core]]} { - # There's only a test failure if there is a core file and (1) - # there previously wasn't one or (2) the new one is different - # from the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join [tcltest::workingDirectory] core]]} { - set coreFailure 1 - } - } else { - set coreFailure 1 - } - - if {($tcltest::preserveCore > 1) && ($coreFailure)} { - append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]" - catch {file rename -force \ - [file join [tcltest::workingDirectory] core] \ - [file join $tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - append coreMsg "\nError: Problem renaming core file: $msg" - } - } - } - array set tcl_platform $currentTclPlatform - } - - set actualAnswer [lindex $testResult 0] - set code [lindex $testResult end] - - # If expected output/error strings exist, we have to compare - # them. If the comparison fails, then so did the test. - set outputFailure 0 - set errorFailure 0 - if {[info exists output]} { - set outputFailure [expr ![compareStrings $tcltest::outData \ - $output $match]] - } - if {[info exists errorOutput]} { - set errorFailure [expr ![compareStrings $tcltest::errData \ - $errorOutput $match]] - } - - set testFailed 1 - set codeFailure 0 - set scriptFailure 0 - - # check if the return code matched the expected return code - if {[lsearch -exact $returnCodes $code] == -1} { - set codeFailure 1 - } - - # check if the answer matched the expected answer - if {[compareStrings $actualAnswer $result $match] == 0} { - set scriptFailure 1 - } - - # if we didn't experience any failures, then we passed - if {!($setupFailure || $cleanupFailure || $coreFailure || \ - $outputFailure || $errorFailure || $codeFailure || \ - $scriptFailure)} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Passed) - if {[tcltest::isVerbose pass]} { - puts [outputChannel] "++++ $name PASSED" - } - } - set testFailed 0 - } - - if {$testFailed} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Failed) - } - set tcltest::currentFailure true - if {![tcltest::isVerbose body]} { - set body "" - } - puts [outputChannel] "\n==== $name [string trim $description] FAILED" - if {$body != ""} { - puts [outputChannel] "==== Contents of test case:" - puts [outputChannel] $body - } - if {$setupFailure} { - puts [outputChannel] "---- Test setup failed:\n$setupMsg" - } - if {$scriptFailure} { - puts [outputChannel] "---- Result was:\n$actualAnswer" - puts [outputChannel] "---- Result should have been ($match matching):\n$result" - } - if {$codeFailure} { - switch -- $code { - 0 { set msg "Test completed normally" } - 1 { set msg "Test generated error" } - 2 { set msg "Test generated return exception" } - 3 { set msg "Test generated break exception" } - 4 { set msg "Test generated continue exception" } - default { set msg "Test generated exception" } - } - puts [outputChannel] "---- $msg; Return code was: $code" - puts [outputChannel] "---- Return code should have been one of: $returnCodes" - if {[tcltest::isVerbose error]} { - if {[info exists ::errorInfo]} { - puts [outputChannel] "---- errorInfo: $::errorInfo" - puts [outputChannel] "---- errorCode: $::errorCode" - } - } - } - if {$outputFailure} { - puts [outputChannel] "---- Output was:\n$tcltest::outData" - puts [outputChannel] "---- Output should have been ($match matching):\n$output" - } - if {$errorFailure} { - puts [outputChannel] "---- Error output was:\n$tcltest::errData" - puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput" - } - if {$cleanupFailure} { - puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" - } - if {$coreFailure} { - puts [outputChannel] "---- Core file produced while running test! $coreMsg" - } - puts [outputChannel] "==== $name FAILED\n" - - } - } - - incr tcltest::testLevel -1 - return 0 -} - - -# runTest -- -# -# This is the defnition of the version 1.0 test routine for tcltest. It is -# provided here for backward compatibility. It is also used as the 'backbone' -# of the test procedure, as in, this is where all the work really gets done. -# -# This procedure runs a test and prints an error message if the test fails. -# If tcltest::verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# tcltest::match variable, if it matches an element in -# tcltest::skip, or if one of the elements of "constraints" turns -# out not to be true. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "tcltest::testConstraints". If any of these -# elements is zero, the test is skipped. -# This argument may be omitted. -# script - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. -# expectedAnswer - Expected result from script. -# -# Behavior depends on the value of testLevel; if testLevel is 1 (top level), -# then events are logged and we track the number of tests run/skipped and why. -# Otherwise, we don't track this information. -# -# Results: -# empty list if test is skipped; otherwise returns list containing -# actual returned value from the test and the return code. -# -# Side Effects: -# none. -# - -proc tcltest::runTest {name description script expectedAnswer constraints} { - - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Total) - } - - # skip the test if it's name matches an element of skip - foreach pattern $tcltest::skip { - if {[string match $pattern $name]} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip} - } - return - } - } - - # skip the test if it's name doesn't match any element of match - if {[llength $tcltest::match] > 0} { - set ok 0 - foreach pattern $tcltest::match { - if {[string match $pattern $name]} { - set ok 1 - break - } - } - if {!$ok} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch} - } - return - } - } - - DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints" - - if {$constraints == {}} { - # If we're limited to the listed constraints and there aren't any - # listed, then we shouldn't run the test. - if {$tcltest::limitConstraints} { - tcltest::AddToSkippedBecause userSpecifiedLimitConstraint - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - } - return - } - } else { - # "constraints" argument exists; - # make sure that the constraints are satisfied. - - set doTest 0 - if {[string match {*[$\[]*} $constraints] != 0} { - # full expression, e.g. {$foo > [info tclversion]} - catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { - # something like {a || b} should be turned into - # $tcltest::testConstraints(a) || $tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$tcltest::testConstraints(&)} c - catch {set doTest [eval expr $c]} - } else { - # just simple constraints such as {unixOnly fonts}. - set doTest 1 - foreach constraint $constraints { - if {(![info exists tcltest::testConstraints($constraint)]) \ - || (!$tcltest::testConstraints($constraint))} { - set doTest 0 - - # store the constraint that kept the test from running - set constraints $constraint - break - } - } - } - - if {$doTest == 0} { - if {[tcltest::isVerbose skip]} { - puts [outputChannel] "++++ $name SKIPPED: $constraints" - } - - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - tcltest::AddToSkippedBecause $constraints - } - return - } - } - - # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with - # tcl_platform. - - if {$tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - array set tcl_platform $tcltest::originalTclPlatform - if {[file exists [file join [tcltest::workingDirectory] core]]} { - set coreModTime [file mtime [file join \ - [tcltest::workingDirectory] core]] - } - array set tcl_platform $currentTclPlatform - } - - # If there is no "memory" command (because memory debugging isn't - # enabled), then don't attempt to use the command. - - if {[info commands memory] != {}} { - memory tag $name - } - - if {[tcltest::isVerbose start]} { - puts [outputChannel] "---- $name start" - flush [outputChannel] - } - - set code [catch {uplevel $script} actualAnswer] - - return [list $actualAnswer $code] -} - -##################################################################### - -# tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} { - proc tcltest::cleanupTestsHook {} {} -} - -# tcltest::cleanupTests -- -# -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. -# -# Print the names of the files created without the makeFile command -# since the tests were invoked. -# -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). -# -# Arguments: -# calledFromAllFile - if 0, behave as if we are running a single test file -# within an entire suite of tests. if we aren't running a single test -# file, then don't report status. check for new files created during the -# test run and report on them. if 1, report collated status from all the -# test file runs. -# -# Results: -# None. -# -# Side Effects: -# None -# - -proc tcltest::cleanupTests {{calledFromAllFile 0}} { - - set testFileName [file tail [info script]] - - # Call the cleanup hook - tcltest::cleanupTestsHook - - # Remove files and directories created by the :tcltest::makeFile and - # tcltest::makeDirectory procedures. - # Record the names of files in tcltest::workingDirectory that were not - # pre-existing, and associate them with the test file that created them. - - if {!$calledFromAllFile} { - foreach file $tcltest::filesMade { - if {[file exists $file]} { - catch {file delete -force $file} - } - } - set currentFiles {} - foreach file [glob -nocomplain \ - [file join $tcltest::temporaryDirectory *]] { - lappend currentFiles [file tail $file] - } - set newFiles {} - foreach file $currentFiles { - if {[lsearch -exact $tcltest::filesExisted $file] == -1} { - lappend newFiles $file - } - } - set tcltest::filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set tcltest::createdNewFiles($testFileName) $newFiles - } - } - - if {$calledFromAllFile || $tcltest::testSingleFile} { - - # print stats - - puts -nonewline [outputChannel] "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline [outputChannel] \ - "\t$index\t$tcltest::numTests($index)" - } - puts [outputChannel] "" - - # print number test files sourced - # print names of files that ran tests which failed - - if {$calledFromAllFile} { - puts [outputChannel] \ - "Sourced $tcltest::numTestFiles Test Files." - set tcltest::numTestFiles 0 - if {[llength $tcltest::failFiles] > 0} { - puts [outputChannel] \ - "Files with failing tests: $tcltest::failFiles" - set tcltest::failFiles {} - } - } - - # if any tests were skipped, print the constraints that kept them - # from running. - - set constraintList [array names tcltest::skippedBecause] - if {[llength $constraintList] > 0} { - puts [outputChannel] \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts [outputChannel] \ - "\t$tcltest::skippedBecause($constraint)\t$constraint" - unset tcltest::skippedBecause($constraint) - } - } - - # report the names of test files in tcltest::createdNewFiles, and - # reset the array to be empty. - - set testFilesThatTurded [lsort [array names tcltest::createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts [outputChannel] "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts [outputChannel] \ - "\t$testFile:\t$tcltest::createdNewFiles($testFile)" - unset tcltest::createdNewFiles($testFile) - } - } - - # reset filesMade, filesExisted, and numTests - - set tcltest::filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set tcltest::numTests($index) 0 - } - - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && ![info exists tcl_interactive]} { - exit - } - } else { - - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed - - incr tcltest::numTestFiles - if {($tcltest::currentFailure) && \ - ([lsearch -exact $tcltest::failFiles $testFileName] == -1)} { - lappend tcltest::failFiles $testFileName - } - set tcltest::currentFailure false - - # restore the environment to the state it was in before this package - # was loaded - - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists tcltest::originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { - if {$::env($index) != $tcltest::originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $tcltest::originalEnv($index) - } - } - } - foreach index [array names tcltest::originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $tcltest::originalEnv($index) - } - } - if {[llength $newEnv] > 0} { - puts [outputChannel] \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts [outputChannel] \ - "env array elements changed:\t$changedEnv" - } - if {[llength $removedEnv] > 0} { - puts [outputChannel] \ - "env array elements removed:\t$removedEnv" - } - - set changedTclPlatform {} - foreach index [array names tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $tcltest::originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $tcltest::originalTclPlatform($index) - } - } - if {[llength $changedTclPlatform] > 0} { - puts [outputChannel] \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } - - if {[file exists [file join [tcltest::workingDirectory] core]]} { - if {$tcltest::preserveCore > 1} { - puts "rename core file (> 1)" - puts [outputChannel] "produced core file! \ - Moving file to: \ - [file join $tcltest::temporaryDirectory core-$name]" - catch {file rename -force \ - [file join [tcltest::workingDirectory] core] \ - [file join $tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - tcltest::PrintError "Problem renaming file: $msg" - } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists tcltest::coreModificationTime]} { - if {$tcltest::coreModificationTime != [file mtime \ - [file join [tcltest::workingDirectory] core]]} { - puts [outputChannel] "A core file was created!" - } - } else { - puts [outputChannel] "A core file was created!" - } - } - } - } - flush [outputChannel] - flush [errorChannel] - return -} - -##################################################################### - -# Procs that determine which tests/test files to run - -# tcltest::getMatchingFiles -# -# Looks at the patterns given to match and skip files -# and uses them to put together a list of the tests that will be run. -# -# Arguments: -# directory to search -# -# Results: -# The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. It is used in runAllTests. -# -# Side Effects: -# None - -proc tcltest::getMatchingFiles { {searchDirectory ""} } { - if {[llength [info level 0]] == 1} { - set searchDirectory [tcltest::testsDirectory] - } - set matchingFiles {} - - # Find the matching files in the list of directories and then remove the - # ones that match the skip pattern - foreach directory $searchDirectory { - set matchFileList {} - foreach match $tcltest::matchFiles { - set matchFileList [concat $matchFileList \ - [glob -nocomplain [file join $directory $match]]] - } - if {[string compare {} $tcltest::skipFiles]} { - set skipFileList {} - foreach skip $tcltest::skipFiles { - set skipFileList [concat $skipFileList \ - [glob -nocomplain [file join $directory $skip]]] - } - foreach file $matchFileList { - # Only include files that don't match the skip pattern and - # aren't SCCS lock files. - if {([lsearch -exact $skipFileList $file] == -1) && \ - (![string match l.*.test [file tail $file]])} { - lappend matchingFiles $file - } - } - } else { - set matchingFiles [concat $matchingFiles $matchFileList] - } - } - if {[string equal $matchingFiles {}]} { - tcltest::PrintError "No test files remain after applying \ - your match and skip patterns!" - } - return $matchingFiles -} - -# tcltest::getMatchingDirectories -- -# -# Looks at the patterns given to match and skip directories and uses them -# to put together a list of the test directories that we should attempt -# to run. (Only subdirectories containing an "all.tcl" file are put into -# the list.) -# -# Arguments: -# root directory from which to search -# -# Results: -# The constructed list is returned to the user. This is used in the -# primary all.tcl file. Lower-level all.tcl files should use the -# tcltest::testAllFiles proc instead. -# -# Side Effects: -# None. - -proc tcltest::getMatchingDirectories {rootdir} { - set matchingDirs {} - set matchDirList {} - # Find the matching directories in tcltest::testsDirectory and then - # remove the ones that match the skip pattern - foreach match $tcltest::matchDirectories { - foreach file [glob -nocomplain [file join $rootdir $match]] { - if {([file isdirectory $file]) && ($file != $rootdir)} { - set matchDirList [concat $matchDirList \ - [tcltest::getMatchingDirectories $file]] - if {[file exists [file join $file all.tcl]]} { - set matchDirList [concat $matchDirList $file] - } - } - } - } - if {$tcltest::skipDirectories != {}} { - set skipDirs {} - foreach skip $tcltest::skipDirectories { - set skipDirs [concat $skipDirs \ - [glob -nocomplain [file join $tcltest::testsDirectory \ - $skip]]] - } - foreach dir $matchDirList { - # Only include directories that don't match the skip pattern - if {[lsearch -exact $skipDirs $dir] == -1} { - lappend matchingDirs $dir - } - } - } else { - set matchingDirs [concat $matchingDirs $matchDirList] - } - if {$matchingDirs == {}} { - DebugPuts 1 "No test directories remain after applying match and skip patterns!" - } - return $matchingDirs -} - -# tcltest::runAllTests -- -# -# prints output and sources test files according to the match and skip -# patterns provided. after sourcing test files, it goes on to source -# all.tcl files in matching test subdirectories. -# -# Arguments: -# shell being tested -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::runAllTests { {shell ""} } { - global argv - - if {[llength [info level 0]] == 1} { - set shell [tcltest::interpreter] - } - - set tcltest::testSingleFile false - - puts [outputChannel] "Tests running in interp: $shell" - puts [outputChannel] "Tests located in: $tcltest::testsDirectory" - puts [outputChannel] "Tests running in: [tcltest::workingDirectory]" - puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory" - if {[tcltest::singleProcess]} { - puts [outputChannel] "Test files sourced into current interpreter" - } else { - puts [outputChannel] "Test files run in separate interpreters" - } - if {[llength $tcltest::skip] > 0} { - puts [outputChannel] "Skipping tests that match: $tcltest::skip" - } - if {[llength $tcltest::match] > 0} { - puts [outputChannel] "Only running tests that match: $tcltest::match" - } - - if {[llength $tcltest::skipFiles] > 0} { - puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles" - } - if {[llength $tcltest::matchFiles] > 0} { - puts [outputChannel] "Only running test files that match: $tcltest::matchFiles" - } - - set timeCmd {clock format [clock seconds]} - puts [outputChannel] "Tests began at [eval $timeCmd]" - - # Run each of the specified tests - foreach file [lsort [tcltest::getMatchingFiles]] { - set tail [file tail $file] - puts [outputChannel] $tail - - if {$tcltest::singleProcess} { - incr tcltest::numTestFiles - uplevel [list source $file] - } else { - # Change to the tests directory so the value of the following - # variable is set correctly when we spawn the child test processes - cd $tcltest::testsDirectory - set cmd [concat [list | $shell $file] [split $argv]] - if {[catch { - incr tcltest::numTestFiles - set pipeFd [open $cmd "r"] - while {[gets $pipeFd line] >= 0} { - if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - incr tcltest::numTests($index) [set $index] - } - if {$Failed > 0} { - lappend tcltest::failFiles $testFile - } - } elseif {[regexp {^Number of tests skipped for each constraint:|^\t(\d+)\t(.+)$} $line match skipped constraint]} { - if {$match != "Number of tests skipped for each constraint:"} { - tcltest::AddToSkippedBecause $constraint $skipped - } - } else { - puts [outputChannel] $line - } - } - close $pipeFd - } msg]} { - # Print results to tcltest::outputChannel. - puts [outputChannel] "Test file error: $msg" - # append the name of the test to a list to be reported later - lappend testFileFailures $file - } - } - } - - # cleanup - puts [outputChannel] "\nTests ended at [eval $timeCmd]" - tcltest::cleanupTests 1 - if {[info exists testFileFailures]} { - puts [outputChannel] "\nTest files exiting with errors: \n" - foreach file $testFileFailures { - puts " [file tail $file]\n" - } - } - - # Checking for subdirectories in which to run tests - foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] { - set dir [file tail $directory] - puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - puts [outputChannel] "$dir test began at [eval $timeCmd]\n" - - uplevel "source [file join $directory all.tcl]" - - set endTime [eval $timeCmd] - puts [outputChannel] "\n$dir test ended at $endTime" - puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - } - return -} - -##################################################################### - -# Test utility procs - not used in tcltest, but may be useful for testing. - -# tcltest::loadTestedCommands -- -# -# Uses the specified script to load the commands to test. Allowed to -# be empty, as the tested commands could have been compiled into the -# interpreter. -# -# Arguments -# none -# -# Results -# none -# -# Side Effects: -# none. - -proc tcltest::loadTestedCommands {} { - if {$tcltest::loadScript == {}} { - return - } - - return [uplevel $tcltest::loadScript] -} - -# tcltest::saveState -- -# -# Save information regarding what procs and variables exist. -# -# Arguments: -# none -# -# Results: -# Modifies the variable tcltest::saveState -# -# Side effects: -# None. - -proc tcltest::saveState {} { - uplevel {set tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "tcltest::saveState: $tcltest::saveState" - return -} - -# tcltest::restoreState -- -# -# Remove procs and variables that didn't exist before the call to -# tcltest::saveState. -# -# Arguments: -# none -# -# Results: -# Removes procs and variables from your environment if they don't exist -# in the tcltest::saveState variable. -# -# Side effects: -# None. - -proc tcltest::restoreState {} { - foreach p [info procs] { - if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \ - (![string match "*tcltest::$p" [namespace origin $p]])} { - - DebugPuts 2 "tcltest::restoreState: Removing proc $p" - rename $p {} - } - } - foreach p [uplevel {info vars}] { - if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} { - DebugPuts 2 "tcltest::restoreState: Removing variable $p" - uplevel "catch {unset $p}" - } - } - return -} - -# tcltest::normalizeMsg -- -# -# Removes "extra" newlines from a string. -# -# Arguments: -# msg String to be modified -# -# Results: -# string with extra newlines removed -# -# Side effects: -# None. - -proc tcltest::normalizeMsg {msg} { - regsub "\n$" [string tolower $msg] "" msg - regsub -all "\n\n" $msg "\n" msg - regsub -all "\n\}" $msg "\}" msg - return $msg -} - -# tcltest::makeFile -- -# -# Create a new file with the name <name>, and write <contents> to it. -# -# If this file hasn't been created via makeFile since the last time -# cleanupTests was called, add it to the $filesMade list, so it will -# be removed by the next call to cleanupTests. -# -# Arguments: -# contents content of the new file -# name name of the new file -# directory directory name for new file -# -# Results: -# absolute path to the file created -# -# Side effects: -# None. - -proc tcltest::makeFile {contents name {directory ""}} { - global tcl_platform - - if {[llength [info level 0]] == 3} { - set directory [tcltest::temporaryDirectory] - } - - set fullName [file join $directory $name] - - DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" - - set fd [open $fullName w] - - fconfigure $fd -translation lf - - if {[string equal [string index $contents end] "\n"]} { - puts -nonewline $fd $contents - } else { - puts $fd $contents - } - close $fd - - if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { - lappend tcltest::filesMade $fullName - } - return $fullName -} - -# tcltest::removeFile -- -# -# Removes the named file from the filesystem -# -# Arguments: -# name file to be removed -# directory directory from which to remove file -# -# Results: -# return value from [file delete] -# -# Side effects: -# None. - -proc tcltest::removeFile {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::removeFile: removing $fullName" - return [file delete $fullName] -} - -# tcltest::makeDirectory -- -# -# Create a new dir with the name <name>. -# -# If this dir hasn't been created via makeDirectory since the last time -# cleanupTests was called, add it to the $directoriesMade list, so it will -# be removed by the next call to cleanupTests. -# -# Arguments: -# name name of the new directory -# directory directory in which to create new dir -# -# Results: -# absolute path to the directory created -# -# Side effects: -# None. - -proc tcltest::makeDirectory {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::makeDirectory: creating $fullName" - file mkdir $fullName - if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { - lappend tcltest::filesMade $fullName - } - return $fullName -} - -# tcltest::removeDirectory -- -# -# Removes a named directory from the file system. -# -# Arguments: -# name Name of the directory to remove -# directory Directory from which to remove -# -# Results: -# return value from [file delete] -# -# Side effects: -# None - -proc tcltest::removeDirectory {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" - return [file delete -force $fullName] -} - -# tcltest::viewFile -- -# -# reads the content of a file and returns it -# -# Arguments: -# name of the file to read -# directory in which file is located -# -# Results: -# content of the named file -# -# Side effects: -# None. - -proc tcltest::viewFile {name {directory ""}} { - global tcl_platform - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ([tcltest::testConstraint unixExecs] == 0)} { - set f [open $fullName] - set data [read -nonewline $f] - close $f - return $data - } else { - return [exec cat $fullName] - } - return -} - -# tcltest::bytestring -- -# -# Construct a string that consists of the requested sequence of bytes, -# as opposed to a string of properly formed UTF-8 characters. -# This allows the tester to -# 1. Create denormalized or improperly formed strings to pass to C procedures -# that are supposed to accept strings with embedded NULL bytes. -# 2. Confirm that a string result has a certain pattern of bytes, for instance -# to confirm that "\xe0\0" in a Tcl script is stored internally in -# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". -# -# Generally, it's a bad idea to examine the bytes in a Tcl string or to -# construct improperly formed strings in this manner, because it involves -# exposing that Tcl uses UTF-8 internally. -# -# Arguments: -# string being converted -# -# Results: -# result fom encoding -# -# Side effects: -# None - -proc tcltest::bytestring {string} { - return [encoding convertfrom identity $string] -} - -# tcltest::openfiles -- -# -# used in io tests, uses testchannel -# -# Arguments: -# None. -# -# Results: -# ??? -# -# Side effects: -# None. - -proc tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} - } - return $result -} - -# tcltest::leakfiles -- -# -# used in io tests, uses testchannel -# -# Arguments: -# None. -# -# Results: -# ??? -# -# Side effects: -# None. - -proc tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} - } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p - } - } - return $leak -} - -# -# Internationalization / ISO support procs -- dl -# - -# tcltest::set_iso8859_1_locale -- -# -# used in cmdIL.test, uses testlocale -# -# Arguments: -# None. -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::set_iso8859_1_locale {} { - if {[info commands testlocale] != ""} { - set tcltest::previousLocale [testlocale ctype] - testlocale ctype $tcltest::isoLocale - } - return -} - -# tcltest::restore_locale -- -# -# used in cmdIL.test, uses testlocale -# -# Arguments: -# None. -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::restore_locale {} { - if {[info commands testlocale] != ""} { - testlocale ctype $tcltest::previousLocale - } - return -} - -# tcltest::threadReap -- -# -# Kill all threads except for the main thread. -# Do nothing if testthread is not defined. -# -# Arguments: -# none. -# -# Results: -# Returns the number of existing threads. -# -# Side Effects: -# none. -# - -proc tcltest::threadReap {} { - if {[info commands testthread] != {}} { - - # testthread built into tcltest - - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != $tcltest::mainThread} { - catch {testthread send -async $tid {testthread exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - testthread errorproc ThreadError - return [llength [testthread names]] - } elseif {[info commands thread::id] != {}} { - - # Thread extension - - thread::errorproc ThreadNullError - while {[llength [thread::names]] > 1} { - foreach tid [thread::names] { - if {$tid != $tcltest::mainThread} { - catch {thread::send -async $tid {thread::exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - thread::errorproc ThreadError - return [llength [thread::names]] - } else { - return 1 - } - return 0 -} - -# Initialize the constraints and set up command line arguments -namespace eval tcltest { - # Ensure that we have a minimal auto_path so we don't pick up extra junk. - set ::auto_path [list [info library]] - - tcltest::initConstraints - if {[namespace children [namespace current]] == {}} { - tcltest::processCmdLineArgs - } - - # Save the names of files that already exist in - # the output directory. - foreach file [glob -nocomplain \ - [file join $tcltest::temporaryDirectory *]] { - lappend tcltest::filesExisted [file tail $file] - } -} - -package provide tcltest 2.0 - |