diff options
| author | dgp <dgp@users.sourceforge.net> | 2002-03-27 08:19:57 (GMT) |
|---|---|---|
| committer | dgp <dgp@users.sourceforge.net> | 2002-03-27 08:19:57 (GMT) |
| commit | 5003cf213ea8c44687443350d6c1c10d691dad4e (patch) | |
| tree | 8eb06cbe5adb9b0201e5058335f5e04370df57ac /library/tcltest/tcltest.tcl | |
| parent | b2c0ae891a638888904d882ce02ed1637b867403 (diff) | |
| download | tcl-5003cf213ea8c44687443350d6c1c10d691dad4e.zip tcl-5003cf213ea8c44687443350d6c1c10d691dad4e.tar.gz tcl-5003cf213ea8c44687443350d6c1c10d691dad4e.tar.bz2 | |
* Major code cleanup to deal with whitespace,
coding conventions, and namespace issues, with several minor bugs
fixed in the process.
Diffstat (limited to 'library/tcltest/tcltest.tcl')
| -rw-r--r-- | library/tcltest/tcltest.tcl | 2534 |
1 files changed, 1202 insertions, 1332 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 4eaaa4f..a64a6c4 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1,35 +1,39 @@ # tcltest.tcl -- # -# This file contains support code for the Tcl test suite. It +# 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. -# +# 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. +# 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: tcltest.tcl,v 1.42 2002/03/25 22:05:03 dgp Exp $ +# +# RCS: @(#) $Id: tcltest.tcl,v 1.43 2002/03/27 08:19:57 dgp Exp $ -# create the "tcltest" namespace for all testing variables and procedures +# create the "tcltest" namespace for all testing variables and +# procedures package require Tcl 8.3 -namespace eval tcltest { +namespace eval tcltest { # Export the public tcltest procs - namespace export bytestring cleanupTests debug errorChannel errorFile \ - interpreter limitConstraints loadFile loadScript \ + namespace export bytestring cleanupTests debug errorChannel \ + errorFile interpreter limitConstraints loadFile loadScript \ loadTestedCommands mainThread makeDirectory makeFile match \ matchDirectories matchFiles normalizeMsg normalizePath \ - outputChannel outputFile preserveCore removeDirectory removeFile \ - restoreState runAllTests saveState singleProcess skip \ - skipDirectories skipFiles temporaryDirectory test testConstraint \ - testsDirectory threadReap verbose viewFile workingDirectory + outputChannel outputFile preserveCore removeDirectory \ + removeFile restoreState runAllTests saveState \ + singleProcess skip skipDirectories skipFiles \ + temporaryDirectory test testConstraint testsDirectory \ + threadReap verbose viewFile workingDirectory proc Default {varName value} { variable $varName @@ -49,12 +53,13 @@ namespace eval tcltest { array set $varName $value } - # tcltest::verbose defaults to {body} + # verbose defaults to {body} Default 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. + # matchFiles, which defaults to all .test files in the + # testsDirectory and matchDirectories, which defaults to all + # directories. Default match {} Default skip {} Default matchFiles {*.test} @@ -74,15 +79,15 @@ namespace eval tcltest { Default 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. + # 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. Default debug 0 - # Save any arguments that we might want to pass through to other programs. - # This is used by the -args flag. + # Save any arguments that we might want to pass through to other + # programs. This is used by the -args flag. Default parameters {} # Count the number of files tested (0 if runAllTests wasn't called). @@ -98,40 +103,40 @@ 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. + # filesMade keeps track of such files created using the makeFile and + # makeDirectory procedures. filesExisted stores the names of + # pre-existing files. Default filesMade {} Default 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. + # numTests will store test files as indices and the list of files + # (that should not have been) left behind by the test files. ArrayDefault createdNewFiles {} - # initialize tcltest::numTests array to keep track fo the number of - # tests that pass, fail, and are skipped. - ArrayDefault 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. + # initialize numTests array to keep track fo the number of tests + # that pass, fail, and are skipped. + ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0] + + # initialize skippedBecause array to keep track of constraints that + # kept tests from running; a constraint name of "userSpecifiedSkip" + # means that the test appeared on the list of tests that matched the + # -skip value given to the flag; "userSpecifiedNonMatch" means that + # the test didn't match the argument given to the -match flag; both + # of these constraints are counted only if tcltest::debug is set to + # true. ArrayDefault skippedBecause {} - # initialize the tcltest::testConstraints array to keep track of valid + # initialize the testConstraints array to keep track of valid # predefined constraints (see the explanation for the - # tcltest::initConstraints proc for more details). + # InitConstraints proc for more details). ArrayDefault testConstraints {} Default constraintsSpecified {} # Don't run only the constrained tests by default Default limitConstraints false - # A test application has to know how to load the tested commands into - # the interpreter. + # A test application has to know how to load the tested commands + # into the interpreter. Default loadScript {} # and the filename of the script file, if it exists @@ -149,32 +154,53 @@ namespace eval tcltest { # save the original environment so that it can be restored later ArrayDefault originalEnv [array get ::env] - # Set tcltest::workingDirectory to [pwd]. The default output directory - # for Tcl tests is the working directory. + # Set workingDirectory to [pwd]. The default output directory for + # Tcl tests is the working directory. Default workingDirectory [pwd] Default 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 [namespace current]::testsDirectory]} { - variable oldpwd [pwd] - catch {cd [file join [file dirname [info script]] .. .. tests]} - variable testsDirectory [pwd] + # 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 normalizePath {pathVar} { + upvar $pathVar path + set oldpwd [pwd] + catch {cd $path} + set path [pwd] cd $oldpwd - unset oldpwd + return $path } + # Tests should not rely on the current working directory. + # Files that are part of the test suite should be accessed relative + # to tcltest::testsDirectory. + Default testsDirectory [file join \ + [file dirname [info script]] .. .. tests] + variable testsDirectory + normalizePath testsDirectory + # Default is to run each test file in a separate process Default singleProcess 0 - # the variables and procs that existed when tcltest::saveState was - # called are stored in a variable of the same name + # the variables and procs that existed when saveState was called are + # stored in a variable of the same name Default saveState {} - # Internationalization support -- used in tcltest::set_iso8859_1_locale - # and tcltest::restore_locale. Those commands are used in cmdIL.test. + # Internationalization support -- used in [SetIso8859_1_Locale] and + # [RestoreLocale]. Those commands are used in cmdIL.test. if {![info exists [namespace current]::isoLocale]} { variable isoLocale fr @@ -196,9 +222,9 @@ namespace eval tcltest { } default { - # Works on SunOS 4 and Solaris, and maybe others... - # define it to something else on your system - #if you want to test those. + # Works on SunOS 4 and Solaris, and maybe + # others... Define it to something else on your + # system if you want to test those. set isoLocale iso_8859_1 } @@ -219,7 +245,7 @@ namespace eval tcltest { # If a core file exists, save its modification time. variable workingDirectory if {[file exists [file join $workingDirectory core]]} { - Default coreModificationTime \ + Default coreModTime \ [file mtime [file join $workingDirectory core]] } @@ -229,7 +255,7 @@ namespace eval tcltest { # keep track of test level for nested test commands variable testLevel 0 -} +} ##################################################################### @@ -310,7 +336,7 @@ proc tcltest::DebugDo {level script} { variable debug if {$debug >= $level} { - uplevel $script + uplevel 1 $script } return } @@ -344,55 +370,26 @@ 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 + return -code error "$errMsg \"$dir\" is not a directory" } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - set msg "$errMsg \"$dir\" is not writeable" - error $msg + return -code error "$errMsg \"$dir\" is not writeable" } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - set msg "$errMsg \"$dir\" is not readable" - error $msg + return -code error "$errMsg \"$dir\" is not readable" } 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. +# 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. +# 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. +# absolute one. The current working directory is used if it +# was not specified. # # Results # The path is modified in place. @@ -404,12 +401,12 @@ proc tcltest::normalizePath {pathVar} { proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { upvar $pathVar path - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { + if {![string equal [file pathtype $path] "absolute"]} { + if {[string equal {} $prefix]} { set prefix [pwd] } - set path [file join $prefix $path] + set path [file join $prefix $path] } return $path } @@ -417,317 +414,205 @@ proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { ##################################################################### # 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. +# +# Accessor functions for tcltest variables that can be modified +# externally. These are vars that could otherwise be modified +# using command line arguments to tcltest. + +# Many of them are all the same boilerplate: + +namespace eval tcltest { + variable var + foreach var { + match skip matchFiles skipFiles matchDirectories + skipDirectories preserveCore debug loadScript singleProcess + mainThread + } { + proc $var { {new ""} } [subst -nocommands { + variable $var + if {[llength [info level 0]] == 1} { + return [set $var] + } + set $var \$new + }] + } + unset var +} + +# The rest have something special to deal with: # 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. +# 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) +# 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) +# 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. +# content of tcltest::verbose # # Side effects: # None. proc tcltest::verbose { {level ""} } { + variable verbose if {[llength [info level 0]] == 1} { - return $tcltest::verbose - } + return $verbose + } if {[llength $level] > 1} { - set tcltest::verbose $level + set verbose $level } else { if {[regexp {pass|body|skip|start|error} $level]} { - set tcltest::verbose $level - } else { + set verbose $level + } else { set levelList [split $level {}] - set tcltest::verbose [string map {p pass b body s skip t start e - error} $levelList] + set verbose [string map \ + {p pass b body s skip t start e error} $levelList] } } - return $tcltest::verbose + return $verbose } -# tcltest::isVerbose -- +# tcltest::IsVerbose -- # -# Returns true if argument is one of the verbosity levels currently being -# used; returns false otherwise. +# 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. +# 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} { +proc tcltest::IsVerbose {level} { + if {[lsearch -exact [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) +# 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 +# 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 ""} } { + variable outputChannel if {[llength [info level 0]] == 1} { - return $tcltest::outputChannel + return $outputChannel } - if {($filename == "stderr") || ($filename == "stdout")} { - set tcltest::outputChannel $filename - } else { - set tcltest::outputChannel [open $filename w] + switch -exact -- $filename { + stderr - + stdout { + set outputChannel $filename + } + default { + set outputChannel [open $filename w] + } } - return $tcltest::outputChannel + return $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 +# set or return the output file name (where tcltest puts all of +# its output); calls [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 +# 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 +# if the file name supplied is relative, it will be made absolute +# with respect to the predefined temporaryDirectory proc tcltest::outputFile { {filename ""} } { + variable outputFile if {[llength [info level 0]] == 1} { - return $tcltest::outputFile + return $outputFile } - if {($filename != "stderr") && ($filename != "stdout")} { - MakeAbsolutePath filename $tcltest::temporaryDirectory + switch -exact -- $filename { + stderr - + stdout { + # do nothing + } + default { + MakeAbsolutePath filename [temporaryDirectory] + } } - tcltest::outputChannel $filename - set tcltest::outputFile $filename + outputChannel $filename + set outputFile $filename } # tcltest::errorChannel -- # -# set or return the error file descriptor based on the supplied file name -# (where tcltest sends all its errors) +# 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 +# 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 +# opens the descriptor in w mode unless the filename is set to +# stderr or stdout proc tcltest::errorChannel { {filename ""} } { + variable errorChannel if {[llength [info level 0]] == 1} { - return $tcltest::errorChannel + return $errorChannel } - if {($filename == "stderr") || ($filename == "stdout")} { - set tcltest::errorChannel $filename - } else { - set tcltest::errorChannel [open $filename w] + switch -exact -- $filename { + stderr - + stdout { + set errorChannel $filename + } + default { + set errorChannel [open $filename w] + } } - return $tcltest::errorChannel + return $errorChannel } # tcltest::errorFile -- # -# set or return the error file name; calls tcltest::errorChannel to set +# set or return the error file name; calls [errorChannel] to set # the corresponding file descriptor # # Arguments: @@ -737,56 +622,38 @@ proc tcltest::errorChannel { {filename ""} } { # content of tcltest::errorFile # # Side effects: -# if the file name supplied is relative, it will be made absolute with -# respect to the predefined temporaryDirectory +# if the file name supplied is relative, it will be made absolute +# with respect to the predefined temporaryDirectory proc tcltest::errorFile { {filename ""} } { + variable errorFile if {[llength [info level 0]] == 1} { - return $tcltest::errorFile - } - if {($filename != "stderr") && ($filename != "stdout")} { - MakeAbsolutePath filename $tcltest::temporaryDirectory + return $errorFile } - 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 + switch -exact -- $filename { + stderr - + stdout { + # do nothing + } + default { + MakeAbsolutePath filename [temporaryDirectory] + } } - set tcltest::debug $debugLevel + set errorFile $filename + errorChannel $errorFile + return $errorFile } # 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. +# 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 +# value - new value for constraint (should be boolean) - if not +# supplied, this is a query # # Results: # content of tcltest::testConstraints($constraint) @@ -795,47 +662,14 @@ proc tcltest::debug { {debugLevel ""} } { # appends the constraint name to tcltest::constraintsSpecified proc tcltest::testConstraint {constraint {value ""}} { + variable testConstraints + variable constraintsSpecified 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] + return $testConstraints($constraint) + } + lappend constraintsSpecified $constraint + set testConstraints($constraint) $value } # tcltest::limitConstraints -- @@ -852,42 +686,25 @@ proc tcltest::constraintList {} { # None. proc tcltest::limitConstraints { {constraintList ""} } { + variable constraintsSpecified + variable testConstraints + variable limitConstraints 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 $limitConstraints } - 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 limitConstraints $constraintList + foreach elt [array names testConstraints] { + if {[lsearch -exact $constraintsSpecified $elt] == -1} { + testConstraint $elt 0 + } } - set tcltest::loadScript $script + return $limitConstraints } # tcltest::loadFile -- # -# set the load file (containing the load script); +# set the load file (containing the load script); # put the content of the load file into loadScript # # Arguments: @@ -900,22 +717,22 @@ proc tcltest::loadScript { {script ""} } { # None. proc tcltest::loadFile { {scriptFile ""} } { + variable loadFile if {[llength [info level 0]] == 1} { - return $tcltest::loadFile + return $loadFile } - MakeAbsolutePath scriptFile $tcltest::temporaryDirectory + MakeAbsolutePath scriptFile [temporaryDirectory] set tmp [open $scriptFile r] - tcltest::loadScript [read $tmp] + loadScript [read $tmp] close $tmp - set tcltest::loadFile $scriptFile + set 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 +# 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 @@ -927,23 +744,24 @@ proc tcltest::loadFile { {scriptFile ""} } { # None. proc tcltest::workingDirectory { {dir ""} } { + variable workingDirectory if {[llength [info level 0]] == 1} { - return $tcltest::workingDirectory + return $workingDirectory } - set tcltest::workingDirectory $dir - MakeAbsolutePath tcltest::workingDirectory - cd $tcltest::workingDirectory - return $tcltest::workingDirectory + set workingDirectory $dir + MakeAbsolutePath workingDirectory + cd $workingDirectory + return $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. +# Set 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 +# If 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: @@ -956,30 +774,30 @@ proc tcltest::workingDirectory { {dir ""} } { # None. proc tcltest::temporaryDirectory { {dir ""} } { + variable temporaryDirectory if {[llength [info level 0]] == 1} { - return $tcltest::temporaryDirectory + return $temporaryDirectory } - set tcltest::temporaryDirectory $dir - - MakeAbsolutePath tcltest::temporaryDirectory - set tmpDirError "bad argument for temporary directory: " + set temporaryDirectory $dir + MakeAbsolutePath temporaryDirectory - if {[file exists $tcltest::temporaryDirectory]} { - tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError + if {[file exists $temporaryDirectory]} { + CheckDirectory rw $temporaryDirectory \ + {bad argument for temporary directory: } } else { - file mkdir $tcltest::temporaryDirectory + file mkdir $temporaryDirectory } - normalizePath tcltest::temporaryDirectory + normalizePath 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. +# Set 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. +# If testsDirectory does not already exist, return an error. # # Arguments: # directory name @@ -991,45 +809,22 @@ proc tcltest::temporaryDirectory { {dir ""} } { # None. proc tcltest::testsDirectory { {dir ""} } { + variable testsDirectory if {[llength [info level 0]] == 1} { - return $tcltest::testsDirectory + return $testsDirectory } - set tcltest::testsDirectory $dir - - MakeAbsolutePath tcltest::testsDirectory + set testsDirectory $dir + MakeAbsolutePath testsDirectory set testDirError "bad argument for tests directory: " - - if {[file exists $tcltest::testsDirectory]} { - tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError + if {[file exists $testsDirectory]} { + CheckDirectory r $testsDirectory $testDirError } else { - set msg "$testDirError \"$tcltest::testsDirectory\" does not exist" - error $msg + return -code error \ + "$testDirError \"$testsDirectory\" does not exist" } - - 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 + normalizePath testsDirectory } # tcltest::interpreter -- @@ -1050,46 +845,26 @@ proc tcltest::interpreter { {interp ""} } { if {[llength [info level 0]] == 1} { return $tcltest } - if {$interp == "{}"} { + if {[string equal {} $interp]} { set tcltest {} } else { set 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. +# 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. +# Modifies tcltest::skippedBecause; sets the variable to 1 if +# didn't previously exist - otherwise, it just increments it. # # Side effects: # None. @@ -1097,11 +872,12 @@ proc tcltest::mainThread { {threadid ""} } { proc tcltest::AddToSkippedBecause { constraint {value 1}} { # add the constraint to the list of constraints that kept tests # from running + variable skippedBecause - if {[info exists tcltest::skippedBecause($constraint)]} { - incr tcltest::skippedBecause($constraint) $value + if {[info exists skippedBecause($constraint)]} { + incr skippedBecause($constraint) $value } else { - set tcltest::skippedBecause($constraint) $value + set skippedBecause($constraint) $value } return } @@ -1109,12 +885,12 @@ proc tcltest::AddToSkippedBecause { constraint {value 1}} { # tcltest::PrintError -- # # Prints errors to tcltest::errorChannel and then flushes that -# channel, making sure that all messages are < 80 characters per line. +# channel, making sure that all messages are < 80 characters per +# line. # # Arguments: # errorMsg String containing the error to be printed # -# # Results: # None. # @@ -1129,27 +905,30 @@ proc tcltest::PrintError {errorMsg} { # Keep track of where the end of the string is. set endingIndex [string length $errorMsg] - if {$endingIndex < 80} { + if {$endingIndex < (80 - $InitialMsgLen)} { puts [errorChannel] $errorMsg } else { # Print up to 80 characters on the first line, including the - # InitialMessage. + # InitialMessage. set beginningIndex [string last " " [string range $errorMsg 0 \ [expr {80 - $InitialMsgLen}]]] puts [errorChannel] [string range $errorMsg 0 $beginningIndex] - while {$beginningIndex != "end"} { + while {![string equal end $beginningIndex]} { puts -nonewline [errorChannel] \ - [string repeat " " $InitialMsgLen] - if {[expr {$endingIndex - $beginningIndex}] < 72} { + [string repeat " " $InitialMsgLen] + if {($endingIndex - $beginningIndex) + < (80 - $InitialMsgLen)} { puts [errorChannel] [string trim \ [string range $errorMsg $beginningIndex end]] - set beginningIndex end + break } else { - set newEndingIndex [expr [string last " " [string range \ - $errorMsg $beginningIndex \ - [expr {$beginningIndex + 72}]]] + $beginningIndex] - if {($newEndingIndex <= 0) \ + set newEndingIndex [expr {[string last " " \ + [string range $errorMsg $beginningIndex \ + [expr {$beginningIndex + + (80 - $InitialMsgLen)}] + ]] + $beginningIndex}] + if {($newEndingIndex <= 0) || ($newEndingIndex <= $beginningIndex)} { set newEndingIndex end } @@ -1168,181 +947,167 @@ if {[llength [info commands tcltest::initConstraintsHook]] == 0} { proc tcltest::initConstraintsHook {} {} } -# tcltest::safeFetch -- +# 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. +# The following trace procedure makes it so that we can safely +# refer to non-existent members of the testConstraints array +# without causing an error. Instead, reading a non-existent +# member will return 0. This is necessary because tests are +# allowed to use constraint "X" without ensuring that +# testConstraints("X") is defined. # # Arguments: -# n1 - name of the array (tcltest::testConstraints) +# n1 - name of the array (testConstraints) # n2 - array key value (constraint name) -# op - operation performed on tcltest::testConstraints (generally r) +# op - operation performed on testConstraints (generally r) # # Results: # none # # Side effects: -# sets tcltest::testConstraints($n2) to 0 if it's referenced but never +# sets 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 +proc tcltest::SafeFetch {n1 n2 op} { + variable testConstraints + DebugPuts 3 "entering SafeFetch $n1 $n2 $op" + if {[string equal {} $n2]} {return} + if {![info exists testConstraints($n2)]} { + testConstraint $n2 0 } } -# tcltest::initConstraints -- +# 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. +# Check constraint information that will determine which tests to run. +# To do this, create an array testConstraints. Each element has a value +# of 0 or 1. 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. -# +# The 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 - - # 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]}] + variable testConstraints + + # Safely refer to non-existent members of the testConstraints array + # without causing an error. + trace variable testConstraints r [namespace code SafeFetch] + + initConstraintsHook + + testConstraint singleTestInterp [singleProcess] + + # All the 'pc' constraints are here for backward compatibility and + # are not documented. They have been replaced with equivalent 'win' + # constraints. + + testConstraint unixOnly [string equal $tcl_platform(platform) unix] + testConstraint macOnly \ + [string equal $tcl_platform(platform) macintosh] + testConstraint pcOnly [string equal $tcl_platform(platform) windows] + testConstraint winOnly \ + [string equal $tcl_platform(platform) windows] + + testConstraint unix [testConstraint unixOnly] + testConstraint mac [testConstraint macOnly] + testConstraint pc [testConstraint pcOnly] + testConstraint win [testConstraint winOnly] + + testConstraint unixOrPc \ + [expr {[testConstraint unix] || [testConstraint pc]}] + testConstraint macOrPc \ + [expr {[testConstraint mac] || [testConstraint pc]}] + testConstraint unixOrWin \ + [expr {[testConstraint unix] || [testConstraint win]}] + testConstraint macOrWin \ + [expr {[testConstraint mac] || [testConstraint win]}] + testConstraint macOrUnix \ + [expr {[testConstraint mac] || [testConstraint unix]}] + + testConstraint nt [string equal $tcl_platform(os) "Windows NT"] + testConstraint 95 [string equal $tcl_platform(os) "Windows 95"] + 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. + + testConstraint tempNotPc [expr {![testConstraint pc]}] + testConstraint tempNotWin [expr {![testConstraint win]}] + testConstraint tempNotMac [expr {![testConstraint mac]}] + testConstraint tempNotUnix [expr {![testConstraint unix]}] + + # The following Constraints switches are used to mark tests that + # crash on certain platforms, so that they can be reactivated again + # when the underlying problem is fixed. + + testConstraint pcCrash [expr {![testConstraint pc]}] + testConstraint winCrash [expr {![testConstraint win]}] + testConstraint macCrash [expr {![testConstraint mac]}] + testConstraint unixCrash [expr {![testConstraint unix]}] # Skip empty tests - tcltest::testConstraint emptyTest 0 + testConstraint emptyTest 0 # By default, tests that expose known bugs are skipped. - tcltest::testConstraint knownBug 0 + testConstraint knownBug 0 # By default, non-portable tests are skipped. - tcltest::testConstraint nonPortable 0 + testConstraint nonPortable 0 # Some tests require user interaction. - tcltest::testConstraint userInteraction 0 + testConstraint userInteraction 0 + + # Some tests must be skipped if the interpreter is not in + # interactive mode - # Some tests must be skipped if the interpreter is not in interactive mode - if {[info exists tcl_interactive]} { - tcltest::testConstraint interactive $::tcl_interactive + testConstraint interactive $tcl_interactive } else { - tcltest::testConstraint interactive 0 + 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. + # 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 - } + testConstraint root 0 + testConstraint notRoot 1 + if {[string equal unix $tcl_platform(platform)] + && ([string equal root $tcl_platform(user)] + || [string equal "" $tcl_platform(user)])} { + testConstraint root 1 + testConstraint notRoot 0 } # Set nonBlockFiles constraint: 1 means this platform supports # setting files into nonblocking mode. if {[catch {set f [open defs r]}]} { - tcltest::testConstraint nonBlockFiles 1 + testConstraint nonBlockFiles 1 } else { if {[catch {fconfigure $f -blocking off}] == 0} { - tcltest::testConstraint nonBlockFiles 1 + testConstraint nonBlockFiles 1 } else { - tcltest::testConstraint nonBlockFiles 0 + testConstraint nonBlockFiles 0 } close $f } @@ -1354,36 +1119,36 @@ proc tcltest::initConstraints {} { # potential problem with select is apparently interfering. # (Mark Diekhans). - tcltest::testConstraint asyncPipeClose 1 - if {[string equal $tcl_platform(platform) "unix"] \ - && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0)} { - tcltest::testConstraint asyncPipeClose 0 + testConstraint asyncPipeClose 1 + if {[string equal unix $tcl_platform(platform)] && ([catch { + exec uname -X | fgrep {Release = 3.2v}}] == 0)} { + testConstraint asyncPipeClose 0 } # 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 + testConstraint eformat 1 + if {![string equal [format %g 5e-5] 5e-05]} { + testConstraint eformat 0 } - # Test to see if execed commands such as cat, echo, rm and so forth are - # present on this machine. + # 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 + testConstraint unixExecs 1 + if {[string equal macintosh $tcl_platform(platform)]} { + testConstraint unixExecs 0 } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([string equal $tcl_platform(platform) "windows"])} { + if {[testConstraint unixExecs] + && [string equal windows $tcl_platform(platform)]} { set file "_tcl_test_remove_me.txt" if {[catch { set fid [open $file w] puts $fid "hello" close $fid }]} { - tcltest::testConstraint unixExecs 0 + testConstraint unixExecs 0 } elseif { [catch {exec cat $file}] || [catch {exec echo hello}] || @@ -1398,7 +1163,7 @@ proc tcltest::initConstraints {} { [string equal {} [auto_execok grep]] || [string equal {} [auto_execok ps]] } { - tcltest::testConstraint unixExecs 0 + testConstraint unixExecs 0 } file delete -force $file } @@ -1408,7 +1173,7 @@ proc tcltest::initConstraints {} { interpreter [info nameofexecutable] } - tcltest::testConstraint stdio 0 + testConstraint stdio 0 catch { catch {file delete -force tmp} set f [open tmp w] @@ -1420,33 +1185,32 @@ proc tcltest::initConstraints {} { set f [open "|[list [interpreter] tmp]" r] close $f - tcltest::testConstraint stdio 1 + 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. + # 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"}] - + testConstraint socket [string compare $msg \ + "sockets are not available on this system"] + # Check for internationalization - if {[info commands testlocale] == ""} { + if {[llength [info commands testlocale]] == 0} { # No testlocale command, no tests... - tcltest::testConstraint hasIsoLocale 0 + testConstraint hasIsoLocale 0 } else { - tcltest::testConstraint hasIsoLocale \ - [string length [tcltest::set_iso8859_1_locale]] - tcltest::restore_locale + testConstraint hasIsoLocale \ + [string length [SetIso8859_1_Locale]] + RestoreLocale } -} - +} ##################################################################### -# Handle command line arguments (from argv) and default arg settings +# Handle command line arguments (from argv) and default arg settings # (in TCLTEST_OPTIONS). # tcltest::PrintUsageInfoHook @@ -1460,8 +1224,8 @@ if {[llength [info commands tcltest::PrintUsageInfoHook]] == 0} { # tcltest::PrintUsageInfo # -# Prints out the usage information for package tcltest. This can be -# customized with the redefinition of tcltest::PrintUsageInfoHook. +# Prints out the usage information for package tcltest. This can +# be customized with the redefinition of [PrintUsageInfoHook]. # # Arguments: # none @@ -1469,83 +1233,88 @@ if {[llength [info commands tcltest::PrintUsageInfoHook]] == 0} { # Results: # none # -# Side Effects: +# 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 + puts "Usage: [file tail [info nameofexecutable]]\ + script ?-help? ?flag value? ... \n\ + Available flags (and valid input values) are:\n\ + -help Display this usage information.\n\ + -verbose level 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 Do not skip the listed constraints\n\ + -limitconstraints bool Only run tests with the constraints\n\ + \t listed in -constraints.\n\ + -match pattern Run all tests within the specified\n\ + \t files that match the glob pattern\n\ + \t given.\n\ + -skip pattern 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 Run tests in all test files that\n\ + \t match the glob pattern given.\n\ + -notfile pattern Skip all test files that match the\n\ + \t glob pattern given.\n\ + -relateddir pattern Run tests in directories that match\n\ + \t the glob pattern given.\n\ + -asidefromdir pattern Skip tests in directories that match\n\ + \t the glob pattern given.\n\ + -preservecore level 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 [preserveCore].\n\ + -tmpdir directory Save temporary files\ + in the specified\n\ + \t directory. The default value is\n\ + \t [temporaryDirectory]\n\ + -testdir directories Search tests in the specified\n\ + \t directories. The default value is\n\ + \t [testsDirectory].\n\ + -outfile file Send output from test runs to the\n\ + \t specified file. The default is\n\ + \t stdout.\n\ + -errfile file Send errors from test runs to the\n\ + \t specified file. The default is\n\ + \t stderr.\n\ + -loadfile file Read the script to load the tested\n\ + \t commands from the specified file.\n\ + -load script Specifies the script\ + to load the tested\n\ + \t commands.\n\ + -debug level Internal debug flag." + 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. +# 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 {[llength [info commands tcltest::processCmdLineArgsAddFlagsHook]] == 0} { +if {[llength [info commands \ + tcltest::processCmdLineArgsAddFlagsHook]] == 0} { 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. +# tcltest::processCmdLineArgsAddFlagsHook. It is called at the +# end of ProcessFlags. # # Arguments: # flags The flags that have been pulled out of argv @@ -1557,16 +1326,16 @@ if {[llength [info commands tcltest::processCmdLineArgsHook]] == 0} { # 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. +# 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 +# flagArray # # Side effects: # None. @@ -1574,10 +1343,10 @@ if {[llength [info commands tcltest::processCmdLineArgsHook]] == 0} { proc tcltest::ProcessFlags {flagArray} { # Process -help first if {[lsearch -exact $flagArray {-help}] != -1} { - tcltest::PrintUsageInfo + PrintUsageInfo exit 1 } - + catch {array set flag $flagArray} # -help is not listed since it has already been processed @@ -1586,154 +1355,156 @@ proc tcltest::ProcessFlags {flagArray} { -preservecore -limitconstraints -testdir \ -load -loadfile -asidefromdir \ -relateddir -singleproc - set defaultFlags [concat $defaultFlags \ - [tcltest::processCmdLineArgsAddFlagsHook ]] + set defaultFlags \ + [concat $defaultFlags [processCmdLineArgsAddFlagsHook]] - # Set tcltest::verbose to the arg of the -verbose flag, if given + # Set verbose to the arg of the -verbose flag, if given if {[info exists flag(-verbose)]} { - tcltest::verbose $flag(-verbose) + verbose $flag(-verbose) } - # Set tcltest::match to the arg of the -match flag, if given. + # Set match to the arg of the -match flag, if given. if {[info exists flag(-match)]} { - tcltest::match $flag(-match) - } + match $flag(-match) + } - # Set tcltest::skip to the arg of the -skip flag, if given + # Set skip to the arg of the -skip flag, if given if {[info exists flag(-skip)]} { - tcltest::skip $flag(-skip) + skip $flag(-skip) } # Handle the -file and -notfile flags if {[info exists flag(-file)]} { - tcltest::matchFiles $flag(-file) + matchFiles $flag(-file) } if {[info exists flag(-notfile)]} { - tcltest::skipFiles $flag(-notfile) + skipFiles $flag(-notfile) } # Handle -relateddir and -asidefromdir flags if {[info exists flag(-relateddir)]} { - tcltest::matchDirectories $flag(-relateddir) + matchDirectories $flag(-relateddir) } if {[info exists flag(-asidefromdir)]} { - tcltest::skipDirectories $flag(-asidefromdir) + 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. + # 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 + 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. + # 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 + error "-limitconstraints flag can only\ + be used with -constraints" } - tcltest::limitConstraints $flag(-limitconstraints) + limitConstraints $flag(-limitconstraints) } - # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if - # given. + # Set the temporaryDirectory to the arg of -tmpdir, if given. if {[info exists flag(-tmpdir)]} { - tcltest::temporaryDirectory $flag(-tmpdir) + temporaryDirectory $flag(-tmpdir) } - # Set the tcltest::testsDirectory to the arg of -testdir, if - # given. - + # Set the testsDirectory to the arg of -testdir, if given. + if {[info exists flag(-testdir)]} { - tcltest::testsDirectory $flag(-testdir) + 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) - } + outputFile $flag(-outfile) + } if {[info exists flag(-errfile)]} { - tcltest::errorFile $flag(-errfile) + 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) + loadScript $flag(-load) } - + if {[info exists flag(-loadfile)] && \ ([lsearch -exact $flagArray -loadfile] > \ [lsearch -exact $flagArray -load]) } { - tcltest::loadFile $flag(-loadfile) + loadFile $flag(-loadfile) } - # If the user specifies debug testing, print out extra information during - # the run. + # If the user specifies debug testing, print out extra information + # during the run. if {[info exists flag(-debug)]} { - tcltest::debug $flag(-debug) + debug $flag(-debug) } # Handle -preservecore if {[info exists flag(-preservecore)]} { - tcltest::preserveCore $flag(-preservecore) + preserveCore $flag(-preservecore) } # Handle -singleproc flag if {[info exists flag(-singleproc)]} { - tcltest::singleProcess $flag(-singleproc) + singleProcess $flag(-singleproc) } # Call the hook - tcltest::processCmdLineArgsHook [array get flag] + processCmdLineArgsHook [array get flag] return } -# tcltest::processCmdLineArgs -- +# 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. -# +# 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. +# 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 {} { +proc tcltest::ProcessCmdLineArgs {} { global argv + variable originalEnv + variable testConstraints - # 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 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) - } + ProcessFlags $::env(TCLTEST_OPTIONS) + } # The "argv" var doesn't exist in some cases, so use {}. if {(![info exists argv]) || ([llength $argv] < 1)} { @@ -1741,27 +1512,29 @@ proc tcltest::processCmdLineArgs {} { } else { set flagArray $argv } - - tcltest::ProcessFlags $flagArray - # Spit out everything you know if we're at a debug level 2 or greater + 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)" + 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::debug = [debug]" + DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]" + DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]" + DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]" DebugPuts 2 "tcltest::outputChannel = [outputChannel]" DebugPuts 2 "tcltest::errorChannel = [errorChannel]" DebugPuts 2 "Original environment (tcltest::originalEnv):" - DebugPArray 2 tcltest::originalEnv + DebugPArray 2 originalEnv DebugPuts 2 "Constraints:" - DebugPArray 2 tcltest::testConstraints + DebugPArray 2 testConstraints return } @@ -1769,11 +1542,11 @@ proc tcltest::processCmdLineArgs {} { # Code to run the tests goes here. -# tcltest::testPuts -- +# 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. +# Used to redefine puts in test environment. Stores whatever goes +# out on stdout in tcltest::outData and stderr in errData before +# sending it on to the regular puts. # # Arguments: # same as standard puts @@ -1782,88 +1555,101 @@ proc tcltest::processCmdLineArgs {} { # 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]" +# Intercepts puts; data that would otherwise go to stdout, stderr, +# or file channels specified in outputChannel and errorChannel +# does not get sent to the normal puts function. +namespace eval tcltest::Replace { + namespace export puts +} +proc tcltest::Replace::puts {args} { + variable [namespace parent]::outData + variable [namespace parent]::errData + switch [llength $args] { + 1 { + # Only the string to be printed is specified + append outData [lindex $args 0]\n return -# return [tcltest::normalPuts -nonewline [lindex $args end]] - } else { - set channel [lindex $args 0] + # return [Puts [lindex $args 0]] + } + 2 { + # Either -nonewline or channelId has been specified + if {[string equal -nonewline [lindex $args 0]]} { + append outData [lindex $args end] + return + # return [Puts -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] + 3 { + if {[string equal -nonewline [lindex $args 0]]} { + # Both -nonewline and channelId are specified, unless + # it's an error. -nonewline is supposed to be argv[0]. + set channel [lindex $args 1] + } } } if {[info exists channel]} { - if {($channel == [outputChannel]) || ($channel == "stdout")} { - append tcltest::outData "[lindex $args end]\n" - } elseif {($channel == [errorChannel]) || ($channel == "stderr")} { - append tcltest::errData "[lindex $args end]\n" + if {[string equal $channel [outputChannel]] + || [string equal $channel stdout]} { + append outData [lindex $args end]\n + } elseif {[string equal $channel [errorChannel]] + || [string equal $channel stderr]} { + append errData [lindex $args end]\n } return - # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]] + # return [Puts [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] + # If we haven't returned by now, we don't know how to handle the + # input. Let puts handle it. + return [eval Puts $args] } -# tcltest::testEval -- +# tcltest::Eval -- # -# 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. +# Evaluate the script in the test environment. If ignoreOutput is +# false, store data sent to stderr and stdout in outData and +# errData. Otherwise, ignore this output altogether. # # Arguments: # script Script to evaluate -# ?ignoreOutput? Indicates whether or not to ignore output sent to -# stdout & stderr +# ?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. +# Empties the contents of outData and errData before running a +# test if ignoreOutput is set to 0. -proc tcltest::testEval {script {ignoreOutput 1}} { - DebugPuts 3 "testEval called" +proc tcltest::Eval {script {ignoreOutput 1}} { + variable outData + variable errData + DebugPuts 3 "[lindex [info level 0] 0] called" if {!$ignoreOutput} { - set tcltest::outData {} - set tcltest::errData {} - uplevel rename ::puts tcltest::normalPuts - uplevel rename tcltest::testPuts ::puts - } - set result [uplevel $script] + set outData {} + set errData {} + # If caller has its own [puts], this may disable it. + uplevel 1 [list ::rename puts [namespace current]::Puts] + uplevel 1 [list ::namespace import \ + [namespace origin Replace::puts]] + } + set result [uplevel 1 $script] if {!$ignoreOutput} { - uplevel rename ::puts tcltest::testPuts - uplevel rename tcltest::normalPuts ::puts + uplevel 1 ::namespace forget puts + uplevel 1 [list ::rename [namespace current]::Puts puts] } return $result } -# compareStrings -- +# tcltest::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. +# 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 @@ -1876,7 +1662,7 @@ proc tcltest::testEval {script {ignoreOutput 1}} { # Side effects: # None. -proc tcltest::compareStrings {actual expected mode} { +proc tcltest::CompareStrings {actual expected mode} { switch -- $mode { exact { set retval [string equal $actual $expected] @@ -1892,19 +1678,18 @@ proc tcltest::compareStrings {actual expected mode} { } -# -# tcltest::substArguments list +# 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: +# 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}} +# SubstArguments {$a {$a}} # # Then it is as though the function is invoked as: # -# substArguments $a {$a} +# SubstArguments $a {$a} # # This code is adapted from Paul Duffin's function "SplitIntoWords". # The original function can be found on: @@ -1922,16 +1707,15 @@ proc tcltest::compareStrings {actual expected mode} { # None. # -proc tcltest::substArguments {argList} { +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. + # We need to split the argList up into tokens but cannot use list + # operations as they throw away some significant quoting, and + # [split] ignores braces as it should. Therefore what we do is + # gradually build up a string out of whitespace seperated strings. + # We cannot use [split] to split the argList into whitespace + # separated strings as it throws away the whitespace which maybe + # important so we have to do it all by hand. set result {} set token "" @@ -1939,11 +1723,11 @@ proc tcltest::substArguments {argList} { 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. + $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}]] + [expr {[lindex $all 0] - 1}]] # Get the word with the quote set word [string range $argList \ [lindex $all 0] [lindex $all 1]] @@ -1958,7 +1742,7 @@ proc tcltest::substArguments {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, @@ -1973,7 +1757,7 @@ proc tcltest::substArguments {argList} { 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] @@ -1994,108 +1778,112 @@ proc tcltest::substArguments {argList} { # 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 +# This procedure runs a test and prints an error message if the test +# fails. If verbose has been set, it also prints a message even if the # test succeeds. The test will be skipped if it doesn't match the -# 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. -# +# match variable, if it matches an element in skip, or if one of the +# elements of "constraints" turns out not to be true. +# +# If testLevel is 1, then this is a top level test, and we record +# pass/fail information; otherwise, this information is not logged and +# is not added to running totals. +# # 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. +# +# constraints - A list of one or more keywords, each of which +# must be the name of an element in the array +# "testConstraints". If any of these elements is +# zero, the test is skipped. This attribute is +# optional; default is {} +# body - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. This attribute is optional; +# 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" + global tcl_platform + variable testLevel + DebugPuts 3 "test $name $args" - incr tcltest::testLevel + incr 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} { + # 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 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 '-'. + # 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 + puts [errorChannel] "test $name: {wrong # args:\ + should be \"test name desc ?options?\"}" + incr testLevel -1 return 1 - } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} { - + } elseif {[string match -* [lindex $args 0]] + || ([llength $args] == 1)} { if {[llength $args] == 1} { - set list [substArguments [lindex $args 0]] - foreach {element value} $list { + 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])] + set testAttributes([subst -$item]) [uplevel 1 \ + ::concat $testAttributes([subst -$item])] } } } else { array set testAttributes $args } - set validFlags {-setup -cleanup -body -result -returnCodes -match \ - -output -errorOutput -constraints} + 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" + puts [errorChannel] "test $name:\ + bad flag $flag supplied to tcltest::test" incr tcltest::testLevel -1 return 1 } @@ -2108,7 +1896,8 @@ proc tcltest::test {name description args} { # 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}" + puts [errorChannel] "test $name: {bad value for -match:\ + must be one of exact, glob, regexp}" incr tcltest::testLevel -1 return 1 } @@ -2118,10 +1907,10 @@ proc tcltest::test {name description args} { regsub -nocase error $returnCodes 1 returnCodes regsub -nocase return $returnCodes 2 returnCodes regsub -nocase break $returnCodes 3 returnCodes - regsub -nocase continue $returnCodes 4 returnCodes + regsub -nocase continue $returnCodes 4 returnCodes } else { - # This is parsing for the old test command format; it is here for - # backward compatibility. + # 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] @@ -2129,35 +1918,39 @@ proc tcltest::test {name description args} { 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\"}" + 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]} { + if {[catch {uplevel 1 $setup} setupMsg]} { set setupFailure 1 } # run the test script - set command [list tcltest::runTest $name $description $body \ - $result $constraints] + set command [list [namespace origin RunTest] $name $description \ + $body $result $constraints] if {!$setupFailure} { if {[info exists output] || [info exists errorOutput]} { - set testResult [uplevel tcltest::testEval [list $command] 0] + set testResult [uplevel 1 \ + [list [namespace origin Eval] $command 0]] } else { - set testResult [uplevel tcltest::testEval [list $command] 1] + set testResult [uplevel 1 \ + [list [namespace origin Eval] $command 1]] } } else { set testResult setupFailure } # Run the cleanup code - if {[catch {uplevel $cleanup} cleanupMsg]} { + if {[catch {uplevel 1 $cleanup} cleanupMsg]} { set cleanupFailure 1 } @@ -2165,31 +1958,34 @@ proc tcltest::test {name description args} { 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} { + # check for a core file first - if one was created by the test, + # then the test failed + if {[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 {[file exists [file join [workingDirectory] core]]} { + # There's only a test failure if there is a core file + # and (1) there previously wasn't one or (2) the new + # one is different from the old one. + variable coreModTime if {[info exists coreModTime]} { if {$coreModTime != [file mtime \ - [file join [tcltest::workingDirectory] core]]} { + [file join [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]" + if {([preserveCore] > 1) && ($coreFailure)} { + append coreMsg "\nMoving file to:\ + [file join [temporaryDirectory] core-$name]" catch {file rename -force \ - [file join [tcltest::workingDirectory] core] \ - [file join $tcltest::temporaryDirectory \ - core-$name]} msg + [file join [workingDirectory] core] \ + [file join [temporaryDirectory] core-$name] + } msg if {[string length $msg] > 0} { - append coreMsg "\nError: Problem renaming core file: $msg" + append coreMsg "\nError:\ + Problem renaming core file: $msg" } } } @@ -2203,13 +1999,15 @@ proc tcltest::test {name description args} { # 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]] - } + variable outData + if {[info exists output]} { + set outputFailure [expr \ + {![CompareStrings $outData $output $match]}] + } + variable errData if {[info exists errorOutput]} { - set errorFailure [expr ![compareStrings $tcltest::errData \ - $errorOutput $match]] + set errorFailure [expr \ + {![CompareStrings $errData $errorOutput $match]}] } set testFailed 1 @@ -2219,20 +2017,21 @@ proc tcltest::test {name description args} { # 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} { + 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]} { + variable numTests + if {!($setupFailure || $cleanupFailure || $coreFailure + || $outputFailure || $errorFailure || $codeFailure + || $scriptFailure)} { + if {$testLevel == 1} { + incr numTests(Passed) + if {[IsVerbose pass]} { puts [outputChannel] "++++ $name PASSED" } } @@ -2240,24 +2039,28 @@ proc tcltest::test {name description args} { } if {$testFailed} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Failed) + if {$testLevel == 1} { + incr numTests(Failed) } - set tcltest::currentFailure true - if {![tcltest::isVerbose body]} { + variable currentFailure true + if {![IsVerbose body]} { set body "" } - puts [outputChannel] "\n==== $name [string trim $description] FAILED" - if {$body != ""} { + puts [outputChannel] "\n==== $name\ + [string trim $description] FAILED" + if {[string length $body]} { puts [outputChannel] "==== Contents of test case:" puts [outputChannel] $body } if {$setupFailure} { - puts [outputChannel] "---- Test setup failed:\n$setupMsg" - } + 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" + puts [outputChannel] "---- Result\ + was:\n$actualAnswer" + puts [outputChannel] "---- Result should have been\ + ($match matching):\n$result" } if {$codeFailure} { switch -- $code { @@ -2265,130 +2068,146 @@ proc tcltest::test {name description args} { 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" } + 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]} { + puts [outputChannel] "---- Return code should have been\ + one of: $returnCodes" + if {[IsVerbose error]} { if {[info exists ::errorInfo]} { - puts [outputChannel] "---- errorInfo: $::errorInfo" - puts [outputChannel] "---- errorCode: $::errorCode" + 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" + puts [outputChannel] "---- Output was:\n$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" + puts [outputChannel] "---- Error output was:\n$errData" + puts [outputChannel] "---- Error output should have\ + been ($match matching):\n$errorOutput" } if {$cleanupFailure} { - puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" + puts [outputChannel] "---- Test cleanup\ + failed:\n$cleanupMsg" } if {$coreFailure} { - puts [outputChannel] "---- Core file produced while running test! $coreMsg" + puts [outputChannel] "---- Core file produced while\ + running test! $coreMsg" } puts [outputChannel] "==== $name FAILED\n" } } - - incr tcltest::testLevel -1 + + incr testLevel -1 return 0 } -# runTest -- +# 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. +# 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 verbose has been set, it also prints a +# message even if the test succeeds. The test will be skipped if it +# doesn't match the match variable, if it matches an element in skip, or +# if one of the elements of "constraints" turns out not to be true. # # 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. +# 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 +# "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. -# +# +# 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} { +proc tcltest::RunTest { + name description script expectedAnswer constraints +} { + variable testLevel + variable numTests + variable skip + variable match + variable limitConstraints + variable testConstraints + variable originalTclPlatform + variable coreModTime - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Total) + if {$testLevel == 1} { + incr numTests(Total) } - + # skip the test if it's name matches an element of skip - foreach pattern $tcltest::skip { + foreach pattern $skip { if {[string match $pattern $name]} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip} + if {$testLevel == 1} { + incr numTests(Skipped) + DebugDo 1 {AddToSkippedBecause userSpecifiedSkip} } return } } # skip the test if it's name doesn't match any element of match - if {[llength $tcltest::match] > 0} { + if {[llength $match] > 0} { set ok 0 - foreach pattern $tcltest::match { + foreach pattern $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} + if {$testLevel == 1} { + incr numTests(Skipped) + DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch} } return } } - DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $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 - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) + if {[string equal {} $constraints]} { + # If we're limited to the listed constraints and there aren't + # any listed, then we shouldn't run the test. + if {$limitConstraints} { + AddToSkippedBecause userSpecifiedLimitConstraint + if {$testLevel == 1} { + incr numTests(Skipped) } return } } else { - # "constraints" argument exists; + # "constraints" argument exists; # make sure that the constraints are satisfied. set doTest 0 @@ -2396,20 +2215,20 @@ proc tcltest::runTest {name description script expectedAnswer constraints} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 expr $constraints]} } elseif {[regexp {[^.a-zA-Z0-9 \n\r\t]+} $constraints] != 0} { - # something like {a || b} should be turned into - # $tcltest::testConstraints(a) || $tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$tcltest::testConstraints(&)} c + # something like {a || b} should be turned into + # $testConstraints(a) || $testConstraints(b). + regsub -all {[.\w]+} $constraints {$testConstraints(&)} c catch {set doTest [eval expr $c]} } elseif {![catch {llength $constraints}]} { # just simple constraints such as {unixOnly fonts}. set doTest 1 foreach constraint $constraints { - if {(![info exists tcltest::testConstraints($constraint)]) \ - || (!$tcltest::testConstraints($constraint))} { + if {(![info exists testConstraints($constraint)]) \ + || (!$testConstraints($constraint))} { set doTest 0 - # store the constraint that kept the test from running + # store the constraint that kept the test from + # running set constraints $constraint break } @@ -2417,46 +2236,46 @@ proc tcltest::runTest {name description script expectedAnswer constraints} { } if {$doTest == 0} { - if {[tcltest::isVerbose skip]} { + if {[IsVerbose skip]} { puts [outputChannel] "++++ $name SKIPPED: $constraints" } - - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - tcltest::AddToSkippedBecause $constraints + + if {$testLevel == 1} { + incr numTests(Skipped) + 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. + # 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} { + if {[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 $originalTclPlatform + if {[file exists [file join [workingDirectory] core]]} { + set coreModTime \ + [file mtime [file join [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] != {}} { + + if {[llength [info commands memory]] == 1} { memory tag $name } - if {[tcltest::isVerbose start]} { + if {[IsVerbose start]} { puts [outputChannel] "---- $name start" flush [outputChannel] } - - set code [catch {uplevel $script} actualAnswer] - + + set code [catch {uplevel 1 $script} actualAnswer] + return [list $actualAnswer $code] } @@ -2482,66 +2301,78 @@ if {[llength [info commands tcltest::cleanupTestsHook]] == 0} { # # 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: +# 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: +# +# Side Effects: # None -# +# proc tcltest::cleanupTests {{calledFromAllFile 0}} { + variable filesMade + variable filesExisted + variable createdNewFiles + variable testSingleFile + variable numTests + variable numTestFiles + variable failFiles + variable skippedBecause + variable currentFailure + variable originalEnv + variable originalTclPlatform + variable coreModTime set testFileName [file tail [info script]] # Call the cleanup hook - tcltest::cleanupTestsHook + 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. + # Remove files and directories created by the makeFile and + # makeDirectory procedures. Record the names of files in + # workingDirectory that were not pre-existing, and associate them + # with the test file that created them. if {!$calledFromAllFile} { - foreach file $tcltest::filesMade { + foreach file $filesMade { if {[file exists $file]} { catch {file delete -force $file} } } set currentFiles {} foreach file [glob -nocomplain \ - [file join $tcltest::temporaryDirectory *]] { + -directory [temporaryDirectory] *] { lappend currentFiles [file tail $file] } set newFiles {} foreach file $currentFiles { - if {[lsearch -exact $tcltest::filesExisted $file] == -1} { + if {[lsearch -exact $filesExisted $file] == -1} { lappend newFiles $file } } - set tcltest::filesExisted $currentFiles + set filesExisted $currentFiles if {[llength $newFiles] > 0} { - set tcltest::createdNewFiles($testFileName) $newFiles + set createdNewFiles($testFileName) $newFiles } } - if {$calledFromAllFile || $tcltest::testSingleFile} { + if {$calledFromAllFile || $testSingleFile} { # print stats puts -nonewline [outputChannel] "$testFileName:" foreach index [list "Total" "Passed" "Skipped" "Failed"] { puts -nonewline [outputChannel] \ - "\t$index\t$tcltest::numTests($index)" + "\t$index\t$numTests($index)" } puts [outputChannel] "" @@ -2550,67 +2381,68 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { if {$calledFromAllFile} { puts [outputChannel] \ - "Sourced $tcltest::numTestFiles Test Files." - set tcltest::numTestFiles 0 - if {[llength $tcltest::failFiles] > 0} { + "Sourced $numTestFiles Test Files." + set numTestFiles 0 + if {[llength $failFiles] > 0} { puts [outputChannel] \ - "Files with failing tests: $tcltest::failFiles" - set tcltest::failFiles {} + "Files with failing tests: $failFiles" + set failFiles {} } } - # if any tests were skipped, print the constraints that kept them - # from running. + # if any tests were skipped, print the constraints that kept + # them from running. - set constraintList [array names tcltest::skippedBecause] + set constraintList [array names 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) + "\t$skippedBecause($constraint)\t$constraint" + unset skippedBecause($constraint) } } - # report the names of test files in tcltest::createdNewFiles, and - # reset the array to be empty. + # report the names of test files in createdNewFiles, and reset + # the array to be empty. - set testFilesThatTurded [lsort [array names tcltest::createdNewFiles]] + set testFilesThatTurded [lsort [array names 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) + "\t$testFile:\t$createdNewFiles($testFile)" + unset createdNewFiles($testFile) } } # reset filesMade, filesExisted, and numTests - set tcltest::filesMade {} + set filesMade {} foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set tcltest::numTests($index) 0 + set 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]} { + if {![catch {package present Tk}] + && ![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 + # 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 + incr numTestFiles + if {$currentFailure \ + && ([lsearch -exact $failFiles $testFileName] == -1)} { + lappend failFiles $testFileName } - set tcltest::currentFailure false + set currentFailure false # restore the environment to the state it was in before this package # was loaded @@ -2619,20 +2451,20 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { set changedEnv {} set removedEnv {} foreach index [array names ::env] { - if {![info exists tcltest::originalEnv($index)]} { + if {![info exists originalEnv($index)]} { lappend newEnv $index unset ::env($index) } else { - if {$::env($index) != $tcltest::originalEnv($index)} { + if {$::env($index) != $originalEnv($index)} { lappend changedEnv $index - set ::env($index) $tcltest::originalEnv($index) + set ::env($index) $originalEnv($index) } } } - foreach index [array names tcltest::originalEnv] { + foreach index [array names originalEnv] { if {![info exists ::env($index)]} { lappend removedEnv $index - set ::env($index) $tcltest::originalEnv($index) + set ::env($index) $originalEnv($index) } } if {[llength $newEnv] > 0} { @@ -2649,45 +2481,44 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { } set changedTclPlatform {} - foreach index [array names tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $tcltest::originalTclPlatform($index)} { + foreach index [array names originalTclPlatform] { + if {$::tcl_platform($index) \ + != $originalTclPlatform($index)} { lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $tcltest::originalTclPlatform($index) + set ::tcl_platform($index) $originalTclPlatform($index) } } if {[llength $changedTclPlatform] > 0} { - puts [outputChannel] \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } + 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)" + if {[file exists [file join [workingDirectory] core]]} { + if {[preserveCore] > 1} { + puts "rename core file (> 1)" puts [outputChannel] "produced core file! \ Moving file to: \ - [file join $tcltest::temporaryDirectory core-$name]" + [file join [temporaryDirectory] core-$name]" catch {file rename -force \ - [file join [tcltest::workingDirectory] core] \ - [file join $tcltest::temporaryDirectory \ - core-$name]} msg + [file join [workingDirectory] core] \ + [file join [temporaryDirectory] core-$name] + } msg if {[string length $msg] > 0} { - tcltest::PrintError "Problem renaming file: $msg" + 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. + # 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]]} { + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [workingDirectory] core]]} { puts [outputChannel] "A core file was created!" } } else { puts [outputChannel] "A core file was created!" - } + } } } } @@ -2700,45 +2531,48 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { # Procs that determine which tests/test files to run -# tcltest::getMatchingFiles +# 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. +# 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. -# +# 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 ""} } { +proc tcltest::GetMatchingFiles { {searchDirectory ""} } { if {[llength [info level 0]] == 1} { - set searchDirectory [tcltest::testsDirectory] + set searchDirectory [testsDirectory] } set matchingFiles {} - # Find the matching files in the list of directories and then remove the - # ones that match the skip pattern. Passing a list to foreach is required - # so that a patch like D:\Foo\Bar does not get munged into D:FooBar. + # Find the matching files in the list of directories and then remove + # the ones that match the skip pattern. Passing a list to foreach is + # required so that a patch like D:\Foo\Bar does not get munged into + # D:FooBar. foreach directory [list $searchDirectory] { set matchFileList {} - foreach match $tcltest::matchFiles { + foreach match [matchFiles] { set matchFileList [concat $matchFileList \ [glob -directory $directory -nocomplain -- $match]] } if {[string compare {} $tcltest::skipFiles]} { set skipFileList {} - foreach skip $tcltest::skipFiles { + foreach skip [skipFiles] { set skipFileList [concat $skipFileList \ - [glob -directory $directory -nocomplain -- $skip]] + [glob -directory $directory \ + -nocomplain -- $skip]] } foreach file $matchFileList { - # Only include files that don't match the skip pattern and - # aren't SCCS lock files. + # 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 @@ -2749,51 +2583,51 @@ proc tcltest::getMatchingFiles { {searchDirectory ""} } { } } if {[string equal $matchingFiles {}]} { - tcltest::PrintError "No test files remain after applying \ - your match and skip patterns!" + PrintError "No test files remain after applying your match and\ + skip patterns!" } return $matchingFiles } -# tcltest::getMatchingDirectories -- +# 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.) +# 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: +# The constructed list is returned to the user. This is used in +# the primary all.tcl file. +# +# Side Effects: # None. -proc tcltest::getMatchingDirectories {rootdir} { +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 { + # Find the matching directories in testsDirectory and then remove + # the ones that match the skip pattern + foreach match [matchDirectories] { foreach file [glob -directory $rootdir -nocomplain -- $match] { - if {([file isdirectory $file]) && ($file != $rootdir)} { + if {[file isdirectory $file] + && [string compare $file $rootdir]} { set matchDirList [concat $matchDirList \ - [tcltest::getMatchingDirectories $file]] + [GetMatchingDirectories $file]] if {[file exists [file join $file all.tcl]]} { - set matchDirList [concat $matchDirList $file] + lappend matchDirList $file } } } } - if {$tcltest::skipDirectories != {}} { - set skipDirs {} - foreach skip $tcltest::skipDirectories { + if {[llength [skipDirectories]]} { + set skipDirs {} + foreach skip [skipDirectories] { set skipDirs [concat $skipDirs \ - [glob -nocomplain -directory $tcltest::testsDirectory $skip]] + [glob -nocomplain -directory [testsDirectory] $skip]] } foreach dir $matchDirList { # Only include directories that don't match the skip pattern @@ -2802,19 +2636,20 @@ proc tcltest::getMatchingDirectories {rootdir} { } } } else { - set matchingDirs [concat $matchingDirs $matchDirList] + set matchingDirs $matchDirList } - if {$matchingDirs == {}} { - DebugPuts 1 "No test directories remain after applying match and skip patterns!" + if {[llength $matchingDirs] == 0} { + 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. +# 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 @@ -2827,74 +2662,94 @@ proc tcltest::getMatchingDirectories {rootdir} { proc tcltest::runAllTests { {shell ""} } { global argv + variable testSingleFile + variable numTestFiles + variable numTests + variable failFiles if {[llength [info level 0]] == 1} { - set shell [tcltest::interpreter] + set shell [interpreter] } - set tcltest::testSingleFile false + set 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 {[package vcompare [package provide Tcl] 8.4] >= 0} { + puts [outputChannel] "Tests located in: [testsDirectory]" + puts [outputChannel] "Tests running in: [workingDirectory]" + puts [outputChannel] "Temporary files stored in\ + [temporaryDirectory]" + + # [file system] first available in Tcl 8.4 + if {![catch {file system [testsDirectory]} result] + && ![string equal native [lindex $result 0]]} { # If we aren't running in the native filesystem, then we must # run the tests in a single process (via 'source'), because # trying to run then via a pipe will fail since the files don't # really exist. - if {[lindex [file system [tcltest::testsDirectory]] 0] != "native"} { - tcltest::singleProcess 1 - } + singleProcess 1 } - if {[tcltest::singleProcess]} { - puts [outputChannel] "Test files sourced into current interpreter" + if {[singleProcess]} { + puts [outputChannel] \ + "Test files sourced into current interpreter" } else { - puts [outputChannel] "Test files run in separate interpreters" + puts [outputChannel] \ + "Test files run in separate interpreters" } - if {[llength $tcltest::skip] > 0} { - puts [outputChannel] "Skipping tests that match: $tcltest::skip" + if {[llength [skip]] > 0} { + puts [outputChannel] "Skipping tests that match: [skip]" } - if {[llength $tcltest::match] > 0} { - puts [outputChannel] "Only running tests that match: $tcltest::match" + if {[llength [match]] > 0} { + puts [outputChannel] "Only running tests that match: [match]" } - if {[llength $tcltest::skipFiles] > 0} { - puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles" + if {[llength [skipFiles]] > 0} { + puts [outputChannel] \ + "Skipping test files that match: [skipFiles]" } - if {[llength $tcltest::matchFiles] > 0} { - puts [outputChannel] "Only running test files that match: $tcltest::matchFiles" + if {[llength [matchFiles]] > 0} { + puts [outputChannel] \ + "Only running test files that match: [matchFiles]" } set timeCmd {clock format [clock seconds]} puts [outputChannel] "Tests began at [eval $timeCmd]" # Run each of the specified tests - foreach file [lsort [tcltest::getMatchingFiles]] { + foreach file [lsort [GetMatchingFiles]] { set tail [file tail $file] puts [outputChannel] $tail - if {$tcltest::singleProcess} { - incr tcltest::numTestFiles - uplevel [list source $file] + if {[singleProcess]} { + incr numTestFiles + uplevel 1 [list ::source $file] } else { - set cmd [concat [list | $shell $file] [split $argv]] + set cmd [linsert $argv 0 | $shell $file] if {[catch { - incr tcltest::numTestFiles - set pipeFd [open $cmd "r"] + incr 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 {[regexp [join { + {^([^:]+):\t} + {Total\t([0-9]+)\t} + {Passed\t([0-9]+)\t} + {Skipped\t([0-9]+)\t} + {Failed\t([0-9]+)} + } ""] $line null testFile \ + Total Passed Skipped Failed]} { + foreach index {Total Passed Skipped Failed} { + incr numTests($index) [set $index] } if {$Failed > 0} { - lappend tcltest::failFiles $testFile + lappend 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 + } elseif {[regexp [join { + {^Number of tests skipped } + {for each constraint:} + {|^\t(\d+)\t(.+)$} + } ""] $line match skipped constraint]} { + if {[string match \t* $match]} { + AddToSkippedBecause $constraint $skipped } } else { puts [outputChannel] $line @@ -2902,17 +2757,17 @@ proc tcltest::runAllTests { {shell ""} } { } 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 + # 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 + cleanupTests 1 if {[info exists testFileFailures]} { puts [outputChannel] "\nTest files exiting with errors: \n" foreach file $testFileFailures { @@ -2921,23 +2776,25 @@ proc tcltest::runAllTests { {shell ""} } { } # Checking for subdirectories in which to run tests - foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] { + foreach directory [GetMatchingDirectories [testsDirectory]] { set dir [file tail $directory] - puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + puts [outputChannel] [string repeat ~ 44] puts [outputChannel] "$dir test began at [eval $timeCmd]\n" - uplevel "source [file join $directory all.tcl]" + uplevel 1 "::source [file join $directory all.tcl]" set endTime [eval $timeCmd] puts [outputChannel] "\n$dir test ended at $endTime" - puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + puts [outputChannel] "" + puts [outputChannel] [string repeat ~ 44] } return } ##################################################################### -# Test utility procs - not used in tcltest, but may be useful for testing. +# Test utility procs - not used in tcltest, but may be useful for +# testing. # tcltest::loadTestedCommands -- # @@ -2950,16 +2807,17 @@ proc tcltest::runAllTests { {shell ""} } { # # Results # none -# -# Side Effects: +# +# Side Effects: # none. proc tcltest::loadTestedCommands {} { - if {$tcltest::loadScript == {}} { + variable l + if {[string equal {} [loadScript]]} { return } - - return [uplevel $tcltest::loadScript] + + return [uplevel 1 [loadScript]] } # tcltest::saveState -- @@ -2970,45 +2828,50 @@ proc tcltest::loadTestedCommands {} { # none # # Results: -# Modifies the variable tcltest::saveState +# Modifies the variable saveState # # Side effects: # None. proc tcltest::saveState {} { - uplevel {set tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "tcltest::saveState: $tcltest::saveState" + variable saveState + uplevel 1 [list ::set [namespace which -variable saveState]] \ + {[::list [::info procs] [::info vars]]} + DebugPuts 2 "[lindex [info level 0] 0]: $saveState" return } # tcltest::restoreState -- # # Remove procs and variables that didn't exist before the call to -# tcltest::saveState. +# [saveState]. # # Arguments: # none # # Results: -# Removes procs and variables from your environment if they don't exist -# in the tcltest::saveState variable. +# Removes procs and variables from your environment if they don't +# exist in the 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 {} + variable saveState + foreach p [uplevel 1 {::info procs}] { + if {([lsearch [lindex $saveState 0] $p] < 0) + && ![string equal [namespace current]::$p \ + [uplevel 1 [list ::namespace origin $p]]]} { + + DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p" + uplevel 1 [list ::catch [list ::rename $p {}]] } } - foreach p [uplevel {info vars}] { - if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} { - DebugPuts 2 "tcltest::restoreState: Removing variable $p" - uplevel "catch {unset $p}" + foreach p [uplevel 1 {::info vars}] { + if {[lsearch [lindex $saveState 1] $p] < 0} { + DebugPuts 2 "[lindex [info level 0] 0]:\ + Removing variable $p" + uplevel 1 [list ::catch [list ::unset $p]] } } return @@ -3039,13 +2902,13 @@ proc tcltest::normalizeMsg {msg} { # Create a new file with the name <name>, and write <contents> to it. # # If this file hasn't been created via makeFile since the last time -# cleanupTests was called, add it to the $filesMade list, so it will -# be removed by the next call to cleanupTests. +# 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 +# directory directory name for new file # # Results: # absolute path to the file created @@ -3055,14 +2918,16 @@ proc tcltest::normalizeMsg {msg} { proc tcltest::makeFile {contents name {directory ""}} { global tcl_platform + variable filesMade if {[llength [info level 0]] == 3} { - set directory [tcltest::temporaryDirectory] + set directory [temporaryDirectory] } - + set fullName [file join $directory $name] - DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" + DebugPuts 3 "[lindex [info level 0] 0]:\ + putting $contents into $fullName" set fd [open $fullName w] @@ -3075,8 +2940,8 @@ proc tcltest::makeFile {contents name {directory ""}} { } close $fd - if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { - lappend tcltest::filesMade $fullName + if {[lsearch -exact $filesMade $fullName] == -1} { + lappend filesMade $fullName } return $fullName } @@ -3097,10 +2962,10 @@ proc tcltest::makeFile {contents name {directory ""}} { proc tcltest::removeFile {name {directory ""}} { if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] + set directory [temporaryDirectory] } set fullName [file join $directory $name] - DebugPuts 3 "tcltest::removeFile: removing $fullName" + DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" return [file delete $fullName] } @@ -3109,8 +2974,8 @@ proc tcltest::removeFile {name {directory ""}} { # 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. +# 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 @@ -3123,14 +2988,15 @@ proc tcltest::removeFile {name {directory ""}} { # None. proc tcltest::makeDirectory {name {directory ""}} { + variable filesMade if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] + set directory [temporaryDirectory] } set fullName [file join $directory $name] - DebugPuts 3 "tcltest::makeDirectory: creating $fullName" + DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" file mkdir $fullName - if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { - lappend tcltest::filesMade $fullName + if {[lsearch -exact $filesMade $fullName] == -1} { + lappend filesMade $fullName } return $fullName } @@ -3151,10 +3017,10 @@ proc tcltest::makeDirectory {name {directory ""}} { proc tcltest::removeDirectory {name {directory ""}} { if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] + set directory [temporaryDirectory] } set fullName [file join $directory $name] - DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" + DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" return [file delete -force $fullName] } @@ -3175,11 +3041,11 @@ proc tcltest::removeDirectory {name {directory ""}} { proc tcltest::viewFile {name {directory ""}} { global tcl_platform if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] + set directory [temporaryDirectory] } set fullName [file join $directory $name] - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ([tcltest::testConstraint unixExecs] == 0)} { + if {[string equal $tcl_platform(platform) macintosh] + || ![testConstraint unixExecs]} { set f [open $fullName] set data [read -nonewline $f] close $f @@ -3193,13 +3059,14 @@ proc tcltest::viewFile {name {directory ""}} { # 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". +# 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 @@ -3218,7 +3085,7 @@ proc tcltest::bytestring {string} { return [encoding convertfrom identity $string] } -# tcltest::openfiles -- +# tcltest::OpenFiles -- # # used in io tests, uses testchannel # @@ -3231,14 +3098,14 @@ proc tcltest::bytestring {string} { # Side effects: # None. -proc tcltest::openfiles {} { +proc tcltest::OpenFiles {} { if {[catch {testchannel open} result]} { return {} } return $result } -# tcltest::leakfiles -- +# tcltest::LeakFiles -- # # used in io tests, uses testchannel # @@ -3251,7 +3118,7 @@ proc tcltest::openfiles {} { # Side effects: # None. -proc tcltest::leakfiles {old} { +proc tcltest::LeakFiles {old} { if {[catch {testchannel open} new]} { return {} } @@ -3268,7 +3135,7 @@ proc tcltest::leakfiles {old} { # Internationalization / ISO support procs -- dl # -# tcltest::set_iso8859_1_locale -- +# tcltest::SetIso8859_1_Locale -- # # used in cmdIL.test, uses testlocale # @@ -3281,16 +3148,17 @@ proc tcltest::leakfiles {old} { # Side effects: # None. -proc tcltest::set_iso8859_1_locale {} { +proc tcltest::SetIso8859_1_Locale {} { variable previousLocale + variable isoLocale if {[info commands testlocale] != ""} { set previousLocale [testlocale ctype] - testlocale ctype $tcltest::isoLocale + testlocale ctype $isoLocale } return } -# tcltest::restore_locale -- +# tcltest::RestoreLocale -- # # used in cmdIL.test, uses testlocale # @@ -3303,7 +3171,7 @@ proc tcltest::set_iso8859_1_locale {} { # Side effects: # None. -proc tcltest::restore_locale {} { +proc tcltest::RestoreLocale {} { variable previousLocale if {[info commands testlocale] != ""} { testlocale ctype $previousLocale @@ -3321,8 +3189,8 @@ proc tcltest::restore_locale {} { # # Results: # Returns the number of existing threads. -# -# Side Effects: +# +# Side Effects: # none. # @@ -3334,8 +3202,10 @@ proc tcltest::threadReap {} { testthread errorproc ThreadNullError while {[llength [testthread names]] > 1} { foreach tid [testthread names] { - if {$tid != $tcltest::mainThread} { - catch {testthread send -async $tid {testthread exit}} + if {$tid != [mainThread]} { + catch { + testthread send -async $tid {testthread exit} + } } } ## Enter a bit a sleep to give the threads enough breathing @@ -3352,7 +3222,7 @@ proc tcltest::threadReap {} { thread::errorproc ThreadNullError while {[llength [thread::names]] > 1} { foreach tid [thread::names] { - if {$tid != $tcltest::mainThread} { + if {$tid != [mainThread]} { catch {thread::send -async $tid {thread::exit}} } } @@ -3369,15 +3239,15 @@ proc tcltest::threadReap {} { return 0 } -# Initialize the constraints and set up command line arguments +# Initialize the constraints and set up command line arguments namespace eval tcltest { - initConstraints - processCmdLineArgs + InitConstraints + ProcessCmdLineArgs # Save the names of files that already exist in # the output directory. variable file {} - foreach file [glob -nocomplain -directory $temporaryDirectory *] { + foreach file [glob -nocomplain -directory [temporaryDirectory] *] { lappend filesExisted [file tail $file] } unset file |