diff options
| -rw-r--r-- | ChangeLog | 15 | ||||
| -rwxr-xr-x | doc/tcltest2.n | 124 | ||||
| -rw-r--r-- | generic/tcl.h | 5 | ||||
| -rwxr-xr-x | library/tcltest/tcltest2.tcl | 668 | ||||
| -rwxr-xr-x | library/tcltest1.0/tcltest2.tcl | 668 | ||||
| -rw-r--r-- | tests/basic.test | 10 | ||||
| -rwxr-xr-x | tests/tcltest2.test | 228 |
7 files changed, 1203 insertions, 515 deletions
@@ -1,3 +1,18 @@ +2000-10-19 Jennifer Hom <jenn@ajubasolutions.com> + + * library/tcltest1.0/tcltest2.tcl: + * tests/tcltest2.test + * doc/tcltest2.n: Code and documentation cleanup. Modified + -verbose to take list of keywords as well as string of letters. + Removed Tcl version information from tcltest. Removed + tcltest::grep from tcltest package. Added optional 3rd directory + argument to makeFile/makeDirectory and removeFile/removeDirectory. + + * tests/basic.test: Changed references to tcltest::tclVersion to + hardcoded numbers. + * generic/tcl.h: Changed reference to tcltest2.tcl and tcltest.tcl + in comments to tests/basic.test. + 2000-10-06 David Gravereaux <davygrvy@ajubasolutions.com> * win/tclWinChan.c: moved Win2K bug case test with GetStdHandle() diff --git a/doc/tcltest2.n b/doc/tcltest2.n index f012195..90c621f 100755 --- a/doc/tcltest2.n +++ b/doc/tcltest2.n @@ -7,7 +7,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tcltest2.n,v 1.2 2000/09/29 22:47:33 jenn Exp $ +'\" RCS: @(#) $Id: tcltest2.n,v 1.3 2000/10/19 18:00:55 jenn Exp $ '\" .so man.macros .TH "tcltest" n 8.4 Tcl "Tcl Built-In Commands" @@ -19,6 +19,7 @@ tcltest \- Test harness support code and utilities \fBpackage require tcltest ?2.0?\fP .sp \fBtcltest::test \fIname desc ?option value? ?option value? ...\fR +.br \fBtcltest::test \fIname desc {?option value? ?option value? ...}\fR .sp \fBtcltest::cleanupTests \fI?runningMultipleTests?\fR @@ -31,7 +32,7 @@ tcltest \- Test harness support code and utilities .sp \fBtcltest::debug \fI?level?\fR .sp -\fBtcltest::verbose \fI?level?\fR +\fBtcltest::verbose \fI?levelList?\fR .sp \fBtcltest::preserveCore \fI?level?\fR .sp @@ -71,15 +72,15 @@ tcltest \- Test harness support code and utilities .sp \fBtcltest::errorFile \fI?filename?\fR .sp -\fBtcltest::makeFile \fIcontents name\fR +\fBtcltest::makeFile \fIcontents name ?directory?\fR .sp -\fBtcltest::removeFile \fIname\fR +\fBtcltest::removeFile \fIname ?directory?\fR .sp -\fBtcltest::makeDirectory \fIname\fR +\fBtcltest::makeDirectory \fIname ?directory?\fR .sp -\fBtcltest::removeDirectory \fIname\fR +\fBtcltest::removeDirectory \fIname ?directory?\fR .sp -\fBtcltest::viewFile \fIname\fR +\fBtcltest::viewFile \fIname ?directory?\fR .sp \fBtcltest::normalizeMsg \fImsg\fR .sp @@ -179,20 +180,22 @@ Display information regarding what individual procs in the test harness are doing. .RE .TP -\fBtcltest::verbose\fR \fI?level?\fR -Sets or returns the current verbosity level. This level must be a -substring of "bpst". The default verbosity level is "b". See the -"Test output" section for a more detailed explanation of this -option. Levels are defined as: +\fBtcltest::verbose\fR \fI?levelList?\fR +Sets or returns the current verbosity level. The default verbosity +level is "body". See the "Test output" section for a more detailed +explanation of this option. Levels are defined as: .RS -.IP b +.IP body Display the body of failed tests -.IP p +.IP pass Print output when a test passes -.IP s +.IP skip Print output when a test is skipped -.IP t +.IP start Print output whenever a test starts +.IP error +Print errorInfo and errorCode, if they exist, when a test return code +does not match its expected return code .RE .TP \fBtcltest::preserveCore\fR \fI?level?\fR @@ -318,24 +321,20 @@ that output to \fItcltest::errorChannel\fR or \fItcltest::outputChannel\fR rather than letting that output default to stdout. .TP -\fBtcltest::mainThread\fR -Sets or returns the main thread ID. This defaults to 1. This is the -only thread that is not killed by tcltest::threadReap and is set -according to the return value of \fItestthread names\fR at -initialization. -.TP -\fBtcltest::makeFile\fP \fIcontents name\fR +\fBtcltest::makeFile\fP \fIcontents name ?directory?\fR Create a file that will be automatically be removed by \fBtcltest::cleanupTests\fR at the end of a test file. This file is -created relative to tcltest::temporaryDirectory. +created relative to \fIdirectory\fR. If left unspecified, +\fIdirectory\fR defaults to tcltest::temporaryDirectory. Returns the full path of the file created. .TP -\fBtcltest::removeFile\fP \fIname\fR +\fBtcltest::removeFile\fP \fIname ?directory?\fR Force the file referenced by \fIname\fR to be removed. This file name -should be relative to \fItcltest::temporaryDirectory\fR. This proc has no -defined return values. +should be relative to \fIdirectory\fR. If left unspecified, +\fIdirectory\fR defaults to tcltest::temporaryDirectory. This proc +has no defined return values. .TP -\fBtcltest::makeDirectory\fP \fIname\fR +\fBtcltest::makeDirectory\fP \fIname ?directory?\fR Create a directory named \fIname\fR that will automatically be removed by \fBtcltest::cleanupTests\fR at the end of a test file. This directory is created relative to tcltest::temporaryDirectory. @@ -343,11 +342,14 @@ Returns the full path of the directory created. .TP \fBtcltest::removeDirectory\fP \fIname\fR Force the directory referenced by \fIname\fR to be removed. This -directory should be relative to tcltest::temporaryDirectory. This proc +directory should be relative to \fIdirectory\fR. If left unspecified, +\fIdirectory\fR defaults to tcltest::temporaryDirectory. This proc has no defined return value. .TP -\fBtcltest::viewFile\fP \fIfile\fR -Returns the contents of \fIfile\fR. +\fBtcltest::viewFile\fP \fIfile ?directory?\fR +Returns the contents of \fIfile\fR. This file name +should be relative to \fIdirectory\fR. If left unspecified, +\fIdirectory\fR defaults to tcltest::temporaryDirectory. .TP \fBtcltest::normalizeMsg\fP \fImsg\fR Remove extra newlines from \fImsg\fR. @@ -385,6 +387,12 @@ main thread. It gets the ID of the main thread by calling \fItestthread names\fR during initialization. This value is stored in \fItcltest::mainThread\fR. \fBtcltest::threadReap\fR returns the number of existing threads at completion. +.TP +\fBtcltest::mainThread\fR +Sets or returns the main thread ID. This defaults to 1. This is the +only thread that is not killed by tcltest::threadReap and is set +according to the return value of \fItestthread names\fR at +initialization. .SH TESTS The \fBtest\fR procedure runs a test script and prints an error message if the script's result does not match the expected result. @@ -530,7 +538,7 @@ test can only be run if all test files are sourced into a single interpreter \fIunix\fR test can only be run on any UNIX platform .TP -\fIpc\fR +\fIwin\fR test can only be run on any Windows platform .TP \fInt\fR @@ -545,16 +553,16 @@ test can only be run on any Windows 98 platform \fImac\fR test can only be run on any Mac platform .TP -\fIunixOrPc\fR -test can only be run on a UNIX or PC platform +\fIunixOrWin\fR +test can only be run on a UNIX or Windows platform .TP -\fImacOrPc\fR -test can only be run on a Mac or PC platform +\fImacOrWin\fR +test can only be run on a Mac or Windows platform .TP \fImacOrUnix\fR test can only be run on a Mac or UNIX platform .TP -\fItempNotPc\fR +\fItempNotWin\fR test can not be run on Windows. This flag is used to temporarily disable a test. .TP @@ -566,7 +574,7 @@ to temporarily disable a test. test crashes if it's run on UNIX. This flag is used to temporarily disable a test. .TP -\fIpcCrash\fR +\fIwinCrash\fR test crashes if it's run on Windows. This flag is used to temporarily disable a test. .TP @@ -609,8 +617,8 @@ test can only be run if platform supports async flush and async close on a pipe .TP \fIunixExecs\fR -test can only be run if this machine has commands such as 'cat', 'echo', -etc. available. +test can only be run if this machine has Unix-style commands 'cat', 'echo', +'sh', 'wc', 'rm', 'sleep', 'fgrep', 'ps', 'chmod', and 'mkdir' available .TP \fIhasIsoLocale\fR test can only be run if can switch to an ISO locale @@ -645,9 +653,10 @@ display usage information. if <bool> is 0, run test files in separate interpreters. if 1, source test files into the current intpreter. (tcltest::singleProcess) .TP -\fB-verbose <level>\fR -set the level of verbosity to a substring of "bpst". See the "Test -output" section for an explanation of this option. (tcltest::verbose) +\fB-verbose <levelList>\fR +set the level of verbosity to a list containing 0 or more of "body", +"pass", "skip", "start", and "error". See the "Test output" section +for an explanation of this option. (tcltest::verbose) .TP \fB-match <matchList>\fR only run tests that match one or more of the glob patterns in @@ -748,9 +757,9 @@ defaults to stderr. (tcltest::errorFile) .PP You can specify any of the above options on the command line or by defining an environment variable named TCLTEST_OPTIONS containing a -list of options (e.g. "-debug 3 -verbose 'ps'"). This environment -variable is evaluated before the command line arguments. Options -specified on the command line override those specified in +list of options (e.g. "-debug 3 -verbose 'pass skip'"). This +environment variable is evaluated before the command line arguments. +Options specified on the command line override those specified in TCLTEST_OPTIONS. .PP A second way to run tets is to start up a shell, load the @@ -783,25 +792,26 @@ passed, skipped, and failed is printed to statistical information, output can be controlled on a per-test basis by the \fBtcltest::verbose\fR variable. .PP -\fBtcltest::verbose\fR can be set to any substring or permutation -of "bpst". In the string "bpst", the 'b' stands for a test's "body", -the 'p' stands for "passed" tests, the 's' stands for "skipped" -tests, and the 't' indicates when a test "starts". -The default value of \fBtcltest::verbose\fR is "b". If 'b' -is present, then the entire body of the test is printed for each -failed test, otherwise only the test's name, desired output, and -actual output, are printed for each failed test. If 'p' is present, +\fBtcltest::verbose\fR can be set to any combination of "body", +"skip", "pass", "start", or "error". The default value of +\fBtcltest::verbose\fR is "body". If "body" is present, then the +entire body of the test is printed for each failed test, otherwise +only the test's name, desired output, and +actual output, are printed for each failed test. If "pass" is present, then a line is printed for each passed test, otherwise no line is -printed for passed tests. If 's' is present, then a line (containing +printed for passed tests. If "skip" is present, then a line (containing the consraints that cause the test to be skipped) is printed for each -skipped test, otherwise no line is printed for skipped tests. If 't' +skipped test, otherwise no line is printed for skipped tests. If "start" is present, then a line is printed each time a new test starts. +If "error" is present, then the content of errorInfo and errorCode (if +they are defined) is printed for each test whose return code doesn't +match its expected return code. .PP You can set \fBtcltest::verbose\fR either interactively (after the \fBtcltest\fR package has been loaded) or by using the command line argument \fB-verbose\fR, for example: .DS -tclsh socket.test -verbose bps +tclsh socket.test -verbose 'body pass skip' .DE .SH "CONTENTS OF A TEST FILE" Test files should begin by loading the \fBtcltest\fR package: diff --git a/generic/tcl.h b/generic/tcl.h index 509abce..9349b15 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.81 2000/09/28 06:38:19 hobbs Exp $ + * RCS: @(#) $Id: tcl.h,v 1.82 2000/10/19 18:00:56 jenn Exp $ */ #ifndef _TCL @@ -50,8 +50,7 @@ extern "C" { * win/README (not patchlevel) (sections 0 and 2) * unix/README (not patchlevel) (part (h)) * unix/tcl.spec (2 LOC Major/Minor, 1 LOC patch) - * library/tcltest1.0/tcltest.tcl (1 LOC M/M, 1 LOC patch) - * library/tcltest1.0/tcltest2.tcl (1 LOC M/M, 1 LOC patch) + * tests/basic.test (1 LOC M/M) * tools/tcl.hpj.in (not patchlevel, for windows installer) * tools/tcl.wse.in (for windows installer) * tools/tclSplash.bmp (not patchlevel) diff --git a/library/tcltest/tcltest2.tcl b/library/tcltest/tcltest2.tcl index da793ad..c05732d 100755 --- a/library/tcltest/tcltest2.tcl +++ b/library/tcltest/tcltest2.tcl @@ -13,7 +13,7 @@ # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest2.tcl,v 1.3 2000/09/29 23:26:11 jenn Exp $ +# RCS: @(#) $Id: tcltest2.tcl,v 1.4 2000/10/19 18:00:58 jenn Exp $ # create the "tcltest" namespace for all testing variables and procedures @@ -33,9 +33,9 @@ namespace eval tcltest { namespace export $proc } - # tcltest::verbose defaults to "b" + # tcltest::verbose defaults to {body} if {![info exists verbose]} { - variable verbose "b" + variable verbose {body} } # Match and skip patterns default to the empty list, except for @@ -243,14 +243,15 @@ namespace eval tcltest { variable saveState {} } - # Internationalization support + # Internationalization support -- used in tcltest::set_iso8859_1_locale + # and tcltest::restore_locale. Those commands are used in cmdIL.test. if {![info exists previousLocale]} { variable previousLocale } if {![info exists isoLocale]} { variable isoLocale fr - switch -- $tcl_platform(platform) { + switch -- $tcl_platform(platform) { "unix" { # Try some 'known' values for some platforms: @@ -300,14 +301,6 @@ namespace eval tcltest { } } - # Tcl version numbers - if {![info exists version]} { - variable version 8.4 - } - if {![info exists patchLevel]} { - variable patchLevel 8.4a1 - } - # stdout and stderr buffers for use when we want to store them if {![info exists outData]} { variable outData {} @@ -341,12 +334,16 @@ namespace eval tcltest { # Results: # Prints the string. Nothing else is allowed. # +# Side Effects: +# None. +# proc tcltest::DebugPuts {level string} { variable debug if {$debug >= $level} { puts $string } + return } # tcltest::DebugPArray -- @@ -361,6 +358,9 @@ proc tcltest::DebugPuts {level string} { # Results: # Prints the contents of the array. Nothing else is allowed. # +# Side Effects: +# None. +# proc tcltest::DebugPArray {level arrayvar} { variable debug @@ -369,6 +369,7 @@ proc tcltest::DebugPArray {level arrayvar} { catch {upvar $arrayvar $arrayvar} parray $arrayvar } + return } # tcltest::DebugDo -- @@ -383,6 +384,9 @@ proc tcltest::DebugPArray {level arrayvar} { # Results: # Arbitrary side effects, dependent on the executed script. # +# Side Effects: +# None. +# proc tcltest::DebugDo {level script} { variable debug @@ -390,6 +394,7 @@ proc tcltest::DebugDo {level script} { if {$debug >= $level} { uplevel $script } + return } ##################################################################### @@ -413,6 +418,9 @@ proc tcltest::DebugDo {level script} { # Results # none # +# Side Effects: +# None. +# proc tcltest::CheckDirectory {rw dir errMsg} { # Allowed values for 'rw': r, w, rw, wr @@ -442,6 +450,9 @@ proc tcltest::CheckDirectory {rw dir errMsg} { # Results # The path is modified in place. # +# Side Effects: +# None. +# proc tcltest::normalizePath {pathVar} { upvar $pathVar path @@ -468,6 +479,9 @@ proc tcltest::normalizePath {pathVar} { # Results # The path is modified in place. # +# Side Effects: +# None. +# proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { upvar $pathVar path @@ -494,28 +508,69 @@ proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { # # 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. +# 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 'pbst'. -# p = print output whenever a test passes -# b = print the body of the test when it fails -# s = print when a test is skipped -# t = print when a test starts +# A string containing any combination of 'pbste' or a list of keywords +# (listed in parens) +# p = print output whenever a test passes (pass) +# b = print the body of the test when it fails (body) +# s = print when a test is skipped (skip) +# t = print when a test starts (start) +# e = print errorInfo and errorCode when a test encounters an error +# (error) # # Results: -# content of tcltest::verbose +# content of tcltest::verbose - this is always the character combination +# (pbste) instead of the list form. # # Side effects: # None. -proc tcltest::verbose { {level __QUERY} } { - if {$level == "__QUERY"} { +proc tcltest::verbose { {level ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::verbose } - set tcltest::verbose $level + if {[llength $level] > 1} { + set tcltest::verbose $level + } else { + if {[regexp {pass|body|skip|start|error} $level]} { + set tcltest::verbose $level + } else { + set levelList [split $level {}] + set tcltest::verbose [string map {p pass b body s skip t start e + error} $levelList] + } + } + return $tcltest::verbose +} + +# tcltest::isVerbose -- +# +# Returns true if argument is one of the verbosity levels currently being +# used; returns false otherwise. +# +# Arguments: +# level +# +# Results: +# boolean 1 (true) or 0 (false), depending on whether or not the level +# provided is one of the ones stored in tcltest::verbose. +# +# Side effects: +# None. + +proc tcltest::isVerbose {level} { + if {[lsearch -exact [tcltest::verbose] $level] == -1} { + return 0 + } + return 1 } + + # tcltest::match -- # # Set or return the match patterns (tcltest::match) that determine which @@ -530,8 +585,8 @@ proc tcltest::verbose { {level __QUERY} } { # Side effects: # none -proc tcltest::match { {matchList __QUERY} } { - if {$matchList == "__QUERY"} { +proc tcltest::match { {matchList ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::match } set tcltest::match $matchList @@ -551,8 +606,8 @@ proc tcltest::match { {matchList __QUERY} } { # Side effects: # None. -proc tcltest::skip { {skipList __QUERY} } { - if {$skipList == "__QUERY"} { +proc tcltest::skip { {skipList ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::skip } set tcltest::skip $skipList @@ -571,8 +626,8 @@ proc tcltest::skip { {skipList __QUERY} } { # Side effects: # None. -proc tcltest::matchFiles { {matchFileList __QUERY} } { - if {$matchFileList == "__QUERY"} { +proc tcltest::matchFiles { {matchFileList ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::matchFiles } set tcltest::matchFiles $matchFileList @@ -591,8 +646,8 @@ proc tcltest::matchFiles { {matchFileList __QUERY} } { # Side effects: # None. -proc tcltest::skipFiles { {skipFileList __QUERY} } { - if {$skipFileList == "__QUERY"} { +proc tcltest::skipFiles { {skipFileList ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::skipFiles } set tcltest::skipFiles $skipFileList @@ -613,8 +668,8 @@ proc tcltest::skipFiles { {skipFileList __QUERY} } { # Side effects: # None. -proc tcltest::matchDirectories { {dirlist __QUERY} } { - if {$dirlist == "__QUERY"} { +proc tcltest::matchDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::matchDirectories } set tcltest::matchDirectories $dirlist @@ -634,8 +689,8 @@ proc tcltest::matchDirectories { {dirlist __QUERY} } { # Side effects: # None. -proc tcltest::skipDirectories { {dirlist __QUERY} } { - if {$dirlist == "__QUERY"} { +proc tcltest::skipDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::skipDirectories } set tcltest::skipDirectories $dirlist @@ -659,8 +714,8 @@ proc tcltest::skipDirectories { {dirlist __QUERY} } { # Side effects: # None. -proc tcltest::preserveCore { {coreLevel __QUERY} } { - if {$coreLevel == "__QUERY"} { +proc tcltest::preserveCore { {coreLevel ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::preserveCore } set tcltest::preserveCore $coreLevel @@ -682,8 +737,8 @@ proc tcltest::preserveCore { {coreLevel __QUERY} } { # Side effects: # None. -proc tcltest::outputChannel { {filename __QUERY} } { - if {$filename == "__QUERY"} { +proc tcltest::outputChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::outputChannel } if {($filename == "stderr") || ($filename == "stdout")} { @@ -712,8 +767,8 @@ proc tcltest::outputChannel { {filename __QUERY} } { # if the file name supplied is relative, it will be made absolute with # respect to the predefined temporaryDirectory -proc tcltest::outputFile { {filename __QUERY} } { - if {$filename == "__QUERY"} { +proc tcltest::outputFile { {filename ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::outputFile } if {($filename != "stderr") && ($filename != "stdout")} { @@ -740,8 +795,8 @@ proc tcltest::outputFile { {filename __QUERY} } { # opens the descriptor in w mode unless the filename is set to stderr or # stdout -proc tcltest::errorChannel { {filename __QUERY} } { - if {$filename == "__QUERY"} { +proc tcltest::errorChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::errorChannel } if {($filename == "stderr") || ($filename == "stdout")} { @@ -767,8 +822,8 @@ proc tcltest::errorChannel { {filename __QUERY} } { # if the file name supplied is relative, it will be made absolute with # respect to the predefined temporaryDirectory -proc tcltest::errorFile { {filename __QUERY} } { - if {$filename == "__QUERY"} { +proc tcltest::errorFile { {filename ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::errorFile } if {($filename != "stderr") && ($filename != "stdout")} { @@ -797,8 +852,8 @@ proc tcltest::errorFile { {filename __QUERY} } { # Side effects: # None. -proc tcltest::debug { {debugLevel __QUERY} } { - if {$debugLevel == "__QUERY"} { +proc tcltest::debug { {debugLevel ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::debug } set tcltest::debug $debugLevel @@ -821,9 +876,9 @@ proc tcltest::debug { {debugLevel __QUERY} } { # Side effects: # appends the constraint name to tcltest::constraintsSpecified -proc tcltest::testConstraint {constraint {value __QUERY}} { +proc tcltest::testConstraint {constraint {value ""}} { DebugPuts 3 "entering testConstraint $constraint $value" - if {$value == "__QUERY"} { + if {[llength [info level 0]] == 2} { return $tcltest::testConstraints($constraint) } lappend tcltest::constraintsSpecified $constraint @@ -878,9 +933,9 @@ proc tcltest::constraintList {} { # Side effects: # None. -proc tcltest::limitConstraints { {constraintList __QUERY} } { +proc tcltest::limitConstraints { {constraintList ""} } { DebugPuts 3 "entering limitConstraints $constraintList" - if {$constraintList == "__QUERY"} { + if {[llength [info level 0]] == 1} { return $tcltest::limitConstraints } set tcltest::limitConstraints $constraintList @@ -905,8 +960,8 @@ proc tcltest::limitConstraints { {constraintList __QUERY} } { # Side effects: # None. -proc tcltest::loadScript { {script __QUERY} } { - if {$script == "__QUERY"} { +proc tcltest::loadScript { {script ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::loadScript } set tcltest::loadScript $script @@ -926,8 +981,8 @@ proc tcltest::loadScript { {script __QUERY} } { # Side effects: # None. -proc tcltest::loadFile { {scriptFile __QUERY} } { - if {$scriptFile == "__QUERY"} { +proc tcltest::loadFile { {scriptFile ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::loadFile } MakeAbsolutePath scriptFile $tcltest::temporaryDirectory @@ -953,8 +1008,8 @@ proc tcltest::loadFile { {scriptFile __QUERY} } { # Side effects: # None. -proc tcltest::workingDirectory { {dir __QUERY} } { - if {$dir == "__QUERY"} { +proc tcltest::workingDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::workingDirectory } set tcltest::workingDirectory $dir @@ -982,8 +1037,8 @@ proc tcltest::workingDirectory { {dir __QUERY} } { # Side effects: # None. -proc tcltest::temporaryDirectory { {dir __QUERY} } { - if {$dir == "__QUERY"} { +proc tcltest::temporaryDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::temporaryDirectory } set tcltest::temporaryDirectory $dir @@ -1017,8 +1072,8 @@ proc tcltest::temporaryDirectory { {dir __QUERY} } { # Side effects: # None. -proc tcltest::testsDirectory { {dir __QUERY} } { - if {$dir == "__QUERY"} { +proc tcltest::testsDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::testsDirectory } @@ -1043,8 +1098,8 @@ proc tcltest::testsDirectory { {dir __QUERY} } { # # Arguments: # value for singleProcess: -# 0 = source each test file -# 1 = run each test file in its own process +# 1 = source each test file into the current process +# 0 = run each test file in its own process # # Results: # content of tcltest::singleProcess @@ -1052,8 +1107,8 @@ proc tcltest::testsDirectory { {dir __QUERY} } { # Side effects: # None. -proc tcltest::singleProcess { {value __QUERY} } { - if {$value == "__QUERY"} { +proc tcltest::singleProcess { {value ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::singleProcess } set tcltest::singleProcess $value @@ -1072,8 +1127,8 @@ proc tcltest::singleProcess { {value __QUERY} } { # Side effects: # None. -proc tcltest::interpreter { {interp __QUERY} } { - if {$interp == "__QUERY"} { +proc tcltest::interpreter { {interp ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::tcltest } set tcltest::tcltest $interp @@ -1092,8 +1147,8 @@ proc tcltest::interpreter { {interp __QUERY} } { # Side effects: # None. -proc tcltest::mainThread { {threadid __QUERY} } { - if {$threadid == "__QUERY"} { +proc tcltest::mainThread { {threadid ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::mainThread } set tcltest::mainThread $threadid @@ -1112,6 +1167,9 @@ proc tcltest::mainThread { {threadid __QUERY} } { # Results: # Modifies tcltest::skippedBecause; sets the variable to 1 if didn't # previously exist - otherwise, it just increments it. +# +# Side effects: +# None. proc tcltest::AddToSkippedBecause { constraint {value 1}} { # add the constraint to the list of constraints that kept tests @@ -1133,6 +1191,12 @@ proc tcltest::AddToSkippedBecause { constraint {value 1}} { # Arguments: # errorMsg String containing the error to be printed # +# +# Results: +# None. +# +# Side effects: +# None. proc tcltest::PrintError {errorMsg} { set InitialMessage "Error: " @@ -1181,6 +1245,33 @@ if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { proc tcltest::initConstraintsHook {} {} } +# tcltest::safeFetch -- +# +# The following trace procedure makes it so that we can safely refer to +# non-existent members of the tcltest::testConstraints array without +# causing an error. Instead, reading a non-existent member will return +# 0. This is necessary because tests are allowed to use constraint "X" +# without ensuring that tcltest::testConstraints("X") is defined. +# +# Arguments: +# n1 - name of the array (tcltest::testConstraints) +# n2 - array key value (constraint name) +# op - operation performed on tcltest::testConstraints (generally r) +# +# Results: +# none +# +# Side effects: +# sets tcltest::testConstraints($n2) to 0 if it's referenced but never +# before used + +proc tcltest::safeFetch {n1 n2 op} { + DebugPuts 3 "entering safeFetch $n1 $n2 $op" + if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { + tcltest::testConstraint $n2 0 + } +} + # tcltest::initConstraints -- # # Check constraint information that will determine which tests @@ -1196,39 +1287,38 @@ if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { # Results: # The tcltest::testConstraints array is reset to have an index for # each built-in test constraint. - -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 - } -} +# +# Side Effects: +# None. +# proc tcltest::initConstraints {} { global tcl_platform tcl_interactive tk_version - # The following trace procedure makes it so that we can safely refer to - # non-existent members of the tcltest::testConstraints array without - # causing an error. Instead, reading a non-existent member will return 0. - # This is necessary because tests are allowed to use constraint "X" without - # ensuring that tcltest::testConstraints("X") is defined. - + # Safely refer to non-existent members of the tcltest::testConstraints + # array without causing an error. trace variable tcltest::testConstraints r tcltest::safeFetch 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] \ @@ -1236,6 +1326,12 @@ proc tcltest::initConstraints {} { 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]}] @@ -1251,6 +1347,8 @@ proc tcltest::initConstraints {} { tcltest::testConstraint tempNotPc \ [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint tempNotWin \ + [expr {![tcltest::testConstraint win]}] tcltest::testConstraint tempNotMac \ [expr {![tcltest::testConstraint mac]}] tcltest::testConstraint tempNotUnix \ @@ -1262,6 +1360,8 @@ proc tcltest::initConstraints {} { tcltest::testConstraint pcCrash \ [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint winCrash \ + [expr {![tcltest::testConstraint win]}] tcltest::testConstraint macCrash \ [expr {![tcltest::testConstraint mac]}] tcltest::testConstraint unixCrash \ @@ -1475,6 +1575,11 @@ if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} { # Arguments: # none # +# Results: +# none +# +# Side Effects: +# none proc tcltest::PrintUsageInfo {} { puts [format "Usage: [file tail [info nameofexecutable]] \ @@ -1482,12 +1587,13 @@ proc tcltest::PrintUsageInfo {} { 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' and 't'. Test suite will \n\ + \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\ \t display all passed tests if 'p' is \n\ \t specified, all skipped tests if 's' \n\ \t is specified, 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\ @@ -1702,6 +1808,7 @@ proc tcltest::ProcessFlags {flagArray} { # Call the hook tcltest::processCmdLineArgsHook [array get flag] + return } # tcltest::processCmdLineArgs -- @@ -1720,6 +1827,10 @@ proc tcltest::ProcessFlags {flagArray} { # # Results: # Sets the above-named variables in the tcltest namespace. +# +# Side Effects: +# None. +# proc tcltest::processCmdLineArgs {} { global argv @@ -1760,6 +1871,7 @@ proc tcltest::processCmdLineArgs {} { DebugPArray 2 tcltest::originalEnv DebugPuts 2 "Constraints:" DebugPArray 2 tcltest::testConstraints + return } ##################################################################### @@ -1819,7 +1931,7 @@ proc tcltest::testPuts {args} { # If we haven't returned by now, we don't know how to handle the input. # Let puts handle it. - eval tcltest::normalPuts $args + return [eval tcltest::normalPuts $args] } # tcltest::testEval -- @@ -1908,13 +2020,17 @@ proc tcltest::compareStrings {actual expected mode} { # # http://purl.org/thecliff/tcl/wiki/858.html # -# Returns: +# Results: # a list containing the result of the substitution # # Exceptions: # An error may occur if the list containing unbalanced quote or # unknown variable. # +# Side Effects: +# None. +# + proc tcltest::substArguments {argList} { # We need to split the argList up into tokens but cannot use @@ -1985,7 +2101,7 @@ proc tcltest::substArguments {argList} { } -# test -- +# 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 @@ -2036,7 +2152,9 @@ proc tcltest::substArguments {argList} { # 0 if the command ran successfully; 1 otherwise. # # Side effects: +# None. # + proc tcltest::test {name description args} { DebugPuts 3 "Test $name $args" @@ -2057,10 +2175,6 @@ proc tcltest::test {name description args} { # the test script). set returnCodes [list 0 2] - # if the commands are embedded within an outer set of braces, we have to do - # evaluate them before we can run or compare them - set doSubst false - # The old test format can't have a 3rd argument (constraints or script) # that starts with '-'. if {[llength $args] == 0} { @@ -2074,7 +2188,13 @@ proc tcltest::test {name description args} { foreach {element value} $list { set testAttributes($element) $value } - set doSubst true + foreach item {constraints match setup body cleanup \ + result returnCodes output errorOutput} { + if {[info exists testAttributes([subst -$item])]} { + set testAttributes([subst -$item]) \ + [uplevel concat $testAttributes([subst -$item])] + } + } } else { array set testAttributes $args } @@ -2128,18 +2248,11 @@ proc tcltest::test {name description args} { set cleanupFailure 0 # Run the setup script - if {$doSubst} { - set setup [uplevel concat $setup] - } if {[catch {uplevel $setup} setupMsg]} { set setupFailure 1 } # run the test script - if {$doSubst} { - set constraints [uplevel concat $constraints] - set body [uplevel concat $body] - } set command [list tcltest::runTest $name $description $body \ $result $constraints] if {!$setupFailure} { @@ -2153,25 +2266,10 @@ proc tcltest::test {name description args} { } # Run the cleanup code - if {$doSubst} { - set cleanup [uplevel concat $cleanup] - } if {[catch {uplevel $cleanup} cleanupMsg]} { set cleanupFailure 1 } - if {$doSubst} { - foreach item {result returnCodes match} { - set $item [uplevel concat [subst $$item]] - } - if {[info exists output]} { - set output [uplevel concat $output] - } - if {[info exists errorOutput]} { - set errorOutput [uplevel concat $errorOutput] - } - } - # If testResult is an empty list, then the test was skipped if {$testResult != {}} { set coreFailure 0 @@ -2243,7 +2341,7 @@ proc tcltest::test {name description args} { $scriptFailure)} { if {$tcltest::testLevel == 1} { incr tcltest::numTests(Passed) - if {[string first p $tcltest::verbose] != -1} { + if {[tcltest::isVerbose pass]} { puts [outputChannel] "++++ $name PASSED" } } @@ -2255,7 +2353,7 @@ proc tcltest::test {name description args} { incr tcltest::numTests(Failed) } set tcltest::currentFailure true - if {[string first b $tcltest::verbose] == -1} { + if {![tcltest::isVerbose body]} { set body "" } puts [outputChannel] "\n==== $name [string trim $description] FAILED" @@ -2281,6 +2379,12 @@ proc tcltest::test {name description args} { } puts [outputChannel] "---- $msg; Return code was: $code" puts [outputChannel] "---- Return code should have been one of: $returnCodes" + if {[tcltest::isVerbose error]} { + if {[info exists ::errorInfo]} { + puts [outputChannel] "---- errorInfo: $::errorInfo" + puts [outputChannel] "---- errorCode: $::errorCode" + } + } } if {$outputFailure} { puts [outputChannel] "---- Output was:\n$tcltest::outData" @@ -2337,9 +2441,13 @@ proc tcltest::test {name description args} { # then events are logged and we track the number of tests run/skipped and why. # Otherwise, we don't track this information. # -# Returns: +# 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} { @@ -2418,7 +2526,7 @@ proc tcltest::runTest {name description script expectedAnswer constraints} { } if {$doTest == 0} { - if {[string first s $tcltest::verbose] != -1} { + if {[tcltest::isVerbose skip]} { puts [outputChannel] "++++ $name SKIPPED: $constraints" } @@ -2451,7 +2559,7 @@ proc tcltest::runTest {name description script expectedAnswer constraints} { memory tag $name } - if {[string first t $tcltest::verbose] != -1} { + if {[tcltest::isVerbose start]} { puts [outputChannel] "---- $name start" flush [outputChannel] } @@ -2485,6 +2593,20 @@ if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} { # tests were invoked. # # Restore original environment (as reported by special variable env). +# +# Arguments: +# calledFromAllFile - if 0, behave as if we are running a single test file +# within an entire suite of tests. if we aren't running a single test +# file, then don't report status. check for new files created during the +# test run and report on them. if 1, report collated status from all the +# test file runs. +# +# Results: +# None. +# +# Side Effects: +# None +# proc tcltest::cleanupTests {{calledFromAllFile 0}} { @@ -2680,6 +2802,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { } flush [outputChannel] flush [errorChannel] + return } ##################################################################### @@ -2692,19 +2815,21 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { # and uses them to put together a list of the tests that will be run. # # Arguments: -# none +# directory to search # # Results: # The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. +# be used in 'all.tcl' files. It is used in runAllTests. +# +# Side Effects: +# None -proc tcltest::getMatchingFiles {args} { - set matchingFiles {} - if {[llength $args]} { - set searchDirectory $args - } else { - set searchDirectory [list $tcltest::testsDirectory] +proc tcltest::getMatchingFiles { {searchDirectory ""} } { + if {[llength [info level 0]] == 1} { + set searchDirectory [tcltest::testsDirectory] } + set matchingFiles {} + # Find the matching files in the list of directories and then remove the # ones that match the skip pattern foreach directory $searchDirectory { @@ -2746,12 +2871,15 @@ proc tcltest::getMatchingFiles {args} { # the list.) # # Arguments: -# none +# root directory from which to search # # Results: # The constructed list is returned to the user. This is used in the # primary all.tcl file. Lower-level all.tcl files should use the # tcltest::testAllFiles proc instead. +# +# Side Effects: +# None. proc tcltest::getMatchingDirectories {rootdir} { set matchingDirs {} @@ -2806,15 +2934,24 @@ proc tcltest::getMatchingDirectories {rootdir} { # Side effects: # None. -proc tcltest::runAllTests [list [list shell [tcltest::interpreter]]] { +proc tcltest::runAllTests { {shell ""} } { global argv + if {[llength [info level 0]] == 1} { + set shell [tcltest::interpreter] + } + set tcltest::testSingleFile false puts [outputChannel] "Tests running in interp: $shell" puts [outputChannel] "Tests located in: $tcltest::testsDirectory" puts [outputChannel] "Tests running in: [tcltest::workingDirectory]" puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory" + if {[tcltest::singleProcess]} { + puts [outputChannel] "Test files sourced into current interpreter" + } else { + puts [outputChannel] "Test files run in separate interpreters" + } if {[llength $tcltest::skip] > 0} { puts [outputChannel] "Skipping tests that match: $tcltest::skip" } @@ -2838,6 +2975,7 @@ proc tcltest::runAllTests [list [list shell [tcltest::interpreter]]] { puts [outputChannel] $tail if {$tcltest::singleProcess} { + incr tcltest::numTestFiles uplevel [list source $file] } else { # Change to the tests directory so the value of the following @@ -2845,13 +2983,13 @@ proc tcltest::runAllTests [list [list shell [tcltest::interpreter]]] { cd $tcltest::testsDirectory set cmd [concat [list | $shell $file] [split $argv]] if {[catch { + incr tcltest::numTestFiles set pipeFd [open $cmd "r"] while {[gets $pipeFd line] >= 0} { if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { foreach index [list "Total" "Passed" "Skipped" "Failed"] { incr tcltest::numTests($index) [set $index] } - incr tcltest::numTestFiles if {$Failed > 0} { lappend tcltest::failFiles $testFile } @@ -2913,35 +3051,16 @@ proc tcltest::runAllTests [list [list shell [tcltest::interpreter]]] { # # Results # none +# +# Side Effects: +# none. proc tcltest::loadTestedCommands {} { if {$tcltest::loadScript == {}} { return } - uplevel $tcltest::loadScript -} - -# The following two procs are used in the io tests. - -proc tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} - } - return $result -} - -proc tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} - } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p - } - } - return $leak + return [uplevel $tcltest::loadScript] } # tcltest::saveState -- @@ -2953,10 +3072,14 @@ proc tcltest::leakfiles {old} { # # Results: # Modifies the variable tcltest::saveState +# +# Side effects: +# None. proc tcltest::saveState {} { uplevel {set tcltest::saveState [list [info procs] [info vars]]} DebugPuts 2 "tcltest::saveState: $tcltest::saveState" + return } # tcltest::restoreState -- @@ -2970,6 +3093,9 @@ proc tcltest::saveState {} { # Results: # Removes procs and variables from your environment if they don't exist # in the tcltest::saveState variable. +# +# Side effects: +# None. proc tcltest::restoreState {} { foreach p [info procs] { @@ -2986,6 +3112,7 @@ proc tcltest::restoreState {} { uplevel "catch {unset $p}" } } + return } # tcltest::normalizeMsg -- @@ -2995,6 +3122,11 @@ proc tcltest::restoreState {} { # Arguments: # msg String to be modified # +# Results: +# string with extra newlines removed +# +# Side effects: +# None. proc tcltest::normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg @@ -3003,7 +3135,7 @@ proc tcltest::normalizeMsg {msg} { return $msg } -# makeFile -- +# tcltest::makeFile -- # # Create a new file with the name <name>, and write <contents> to it. # @@ -3011,12 +3143,28 @@ proc tcltest::normalizeMsg {msg} { # cleanupTests was called, add it to the $filesMade list, so it will # be removed by the next call to cleanupTests. # -proc tcltest::makeFile {contents name} { +# Arguments: +# contents content of the new file +# name name of the new file +# directory directory name for new file +# +# Results: +# absolute path to the file created +# +# Side effects: +# None. + +proc tcltest::makeFile {contents name {directory ""}} { global tcl_platform + + if {[llength [info level 0]] == 3} { + set directory [tcltest::temporaryDirectory] + } - DebugPuts 3 "tcltest::makeFile: putting $contents into $name" + set fullName [file join $directory $name] + + DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" - set fullName [file join $tcltest::temporaryDirectory $name] set fd [open $fullName w] fconfigure $fd -translation lf @@ -3039,15 +3187,25 @@ proc tcltest::makeFile {contents name} { # Removes the named file from the filesystem # # Arguments: -# name file to be removed +# name file to be removed +# directory directory from which to remove file +# +# Results: +# return value from [file delete] # +# Side effects: +# None. -proc tcltest::removeFile {name} { - DebugPuts 3 "tcltest::removeFile: removing $name" - file delete [file join $tcltest::temporaryDirectory $name] +proc tcltest::removeFile {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeFile: removing $fullName" + return [file delete $fullName] } -# makeDirectory -- +# tcltest::makeDirectory -- # # Create a new dir with the name <name>. # @@ -3055,9 +3213,22 @@ proc tcltest::removeFile {name} { # cleanupTests was called, add it to the $directoriesMade list, so it will # be removed by the next call to cleanupTests. # -proc tcltest::makeDirectory {name} { - DebugPuts 3 "tcltest::makeDirectory: creating $name" - set fullName [file join $tcltest::temporaryDirectory $name] +# Arguments: +# name name of the new directory +# directory directory in which to create new dir +# +# Results: +# absolute path to the directory created +# +# Side effects: +# None. + +proc tcltest::makeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::makeDirectory: creating $fullName" file mkdir $fullName if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { lappend tcltest::filesMade $fullName @@ -3070,62 +3241,57 @@ proc tcltest::makeDirectory {name} { # Removes a named directory from the file system. # # Arguments: -# name Name of the directory to remove +# name Name of the directory to remove +# directory Directory from which to remove # +# Results: +# return value from [file delete] +# +# Side effects: +# None -proc tcltest::removeDirectory {name} { - DebugPuts 3 "tcltest::removeDirectory: deleting $name" - file delete -force [file join $tcltest::temporaryDirectory $name] +proc tcltest::removeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" + return [file delete -force $fullName] } -proc tcltest::viewFile {name} { +# tcltest::viewFile -- +# +# reads the content of a file and returns it +# +# Arguments: +# name of the file to read +# directory in which file is located +# +# Results: +# content of the named file +# +# Side effects: +# None. + +proc tcltest::viewFile {name {directory ""}} { global tcl_platform + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] if {([string equal $tcl_platform(platform) "macintosh"]) || \ ([tcltest::testConstraint unixExecs] == 0)} { - set f [open [file join $tcltest::temporaryDirectory $name]] + set f [open $fullName] set data [read -nonewline $f] close $f return $data } else { - exec cat [file join $tcltest::temporaryDirectory $name] - } -} - -# grep -- -# -# Evaluate a given expression against each element of a list and return all -# elements for which the expression evaluates to true. For the purposes of -# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the -# value of the current element within the expression. This is equivalent to -# the perl grep command where CURRENT_ELEMENT would be the name for the special -# variable $_. -# -# Examples of usage would be: -# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] -# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] -# -# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is -# assumed to be the final argument to the expression provided. -# -# Example: -# grep {regexp a} $someList -# -proc tcltest::grep { expression searchList } { - foreach element $searchList { - if {[regsub -all CURRENT_ELEMENT $expression $element \ - newExpression] == 0} { - set newExpression "$expression {$element}" - } - if {[eval $newExpression] == 1} { - lappend returnList $element - } - } - if {[info exists returnList]} { - return $returnList + return [exec cat $fullName] } return } +# tcltest::bytestring -- # # Construct a string that consists of the requested sequence of bytes, # as opposed to a string of properly formed UTF-8 characters. @@ -3139,14 +3305,83 @@ proc tcltest::grep { expression searchList } { # Generally, it's a bad idea to examine the bytes in a Tcl string or to # construct improperly formed strings in this manner, because it involves # exposing that Tcl uses UTF-8 internally. +# +# Arguments: +# string being converted +# +# Results: +# result fom encoding +# +# Side effects: +# None proc tcltest::bytestring {string} { - encoding convertfrom identity $string + return [encoding convertfrom identity $string] +} + +# tcltest::openfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +# tcltest::leakfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak } # # Internationalization / ISO support procs -- dl # + +# tcltest::set_iso8859_1_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + proc tcltest::set_iso8859_1_locale {} { if {[info commands testlocale] != ""} { set tcltest::previousLocale [testlocale ctype] @@ -3155,6 +3390,19 @@ proc tcltest::set_iso8859_1_locale {} { return } +# tcltest::restore_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + proc tcltest::restore_locale {} { if {[info commands testlocale] != ""} { testlocale ctype $tcltest::previousLocale @@ -3162,7 +3410,7 @@ proc tcltest::restore_locale {} { return } -# threadReap -- +# tcltest::threadReap -- # # Kill all threads except for the main thread. # Do nothing if testthread is not defined. @@ -3172,6 +3420,11 @@ proc tcltest::restore_locale {} { # # Results: # Returns the number of existing threads. +# +# Side Effects: +# none. +# + proc tcltest::threadReap {} { if {[info commands testthread] != {}} { @@ -3212,6 +3465,7 @@ proc tcltest::threadReap {} { } else { return 1 } + return 0 } # Initialize the constraints and set up command line arguments diff --git a/library/tcltest1.0/tcltest2.tcl b/library/tcltest1.0/tcltest2.tcl index da793ad..c05732d 100755 --- a/library/tcltest1.0/tcltest2.tcl +++ b/library/tcltest1.0/tcltest2.tcl @@ -13,7 +13,7 @@ # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest2.tcl,v 1.3 2000/09/29 23:26:11 jenn Exp $ +# RCS: @(#) $Id: tcltest2.tcl,v 1.4 2000/10/19 18:00:58 jenn Exp $ # create the "tcltest" namespace for all testing variables and procedures @@ -33,9 +33,9 @@ namespace eval tcltest { namespace export $proc } - # tcltest::verbose defaults to "b" + # tcltest::verbose defaults to {body} if {![info exists verbose]} { - variable verbose "b" + variable verbose {body} } # Match and skip patterns default to the empty list, except for @@ -243,14 +243,15 @@ namespace eval tcltest { variable saveState {} } - # Internationalization support + # Internationalization support -- used in tcltest::set_iso8859_1_locale + # and tcltest::restore_locale. Those commands are used in cmdIL.test. if {![info exists previousLocale]} { variable previousLocale } if {![info exists isoLocale]} { variable isoLocale fr - switch -- $tcl_platform(platform) { + switch -- $tcl_platform(platform) { "unix" { # Try some 'known' values for some platforms: @@ -300,14 +301,6 @@ namespace eval tcltest { } } - # Tcl version numbers - if {![info exists version]} { - variable version 8.4 - } - if {![info exists patchLevel]} { - variable patchLevel 8.4a1 - } - # stdout and stderr buffers for use when we want to store them if {![info exists outData]} { variable outData {} @@ -341,12 +334,16 @@ namespace eval tcltest { # Results: # Prints the string. Nothing else is allowed. # +# Side Effects: +# None. +# proc tcltest::DebugPuts {level string} { variable debug if {$debug >= $level} { puts $string } + return } # tcltest::DebugPArray -- @@ -361,6 +358,9 @@ proc tcltest::DebugPuts {level string} { # Results: # Prints the contents of the array. Nothing else is allowed. # +# Side Effects: +# None. +# proc tcltest::DebugPArray {level arrayvar} { variable debug @@ -369,6 +369,7 @@ proc tcltest::DebugPArray {level arrayvar} { catch {upvar $arrayvar $arrayvar} parray $arrayvar } + return } # tcltest::DebugDo -- @@ -383,6 +384,9 @@ proc tcltest::DebugPArray {level arrayvar} { # Results: # Arbitrary side effects, dependent on the executed script. # +# Side Effects: +# None. +# proc tcltest::DebugDo {level script} { variable debug @@ -390,6 +394,7 @@ proc tcltest::DebugDo {level script} { if {$debug >= $level} { uplevel $script } + return } ##################################################################### @@ -413,6 +418,9 @@ proc tcltest::DebugDo {level script} { # Results # none # +# Side Effects: +# None. +# proc tcltest::CheckDirectory {rw dir errMsg} { # Allowed values for 'rw': r, w, rw, wr @@ -442,6 +450,9 @@ proc tcltest::CheckDirectory {rw dir errMsg} { # Results # The path is modified in place. # +# Side Effects: +# None. +# proc tcltest::normalizePath {pathVar} { upvar $pathVar path @@ -468,6 +479,9 @@ proc tcltest::normalizePath {pathVar} { # Results # The path is modified in place. # +# Side Effects: +# None. +# proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { upvar $pathVar path @@ -494,28 +508,69 @@ proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { # # 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. +# 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 'pbst'. -# p = print output whenever a test passes -# b = print the body of the test when it fails -# s = print when a test is skipped -# t = print when a test starts +# A string containing any combination of 'pbste' or a list of keywords +# (listed in parens) +# p = print output whenever a test passes (pass) +# b = print the body of the test when it fails (body) +# s = print when a test is skipped (skip) +# t = print when a test starts (start) +# e = print errorInfo and errorCode when a test encounters an error +# (error) # # Results: -# content of tcltest::verbose +# content of tcltest::verbose - this is always the character combination +# (pbste) instead of the list form. # # Side effects: # None. -proc tcltest::verbose { {level __QUERY} } { - if {$level == "__QUERY"} { +proc tcltest::verbose { {level ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::verbose } - set tcltest::verbose $level + if {[llength $level] > 1} { + set tcltest::verbose $level + } else { + if {[regexp {pass|body|skip|start|error} $level]} { + set tcltest::verbose $level + } else { + set levelList [split $level {}] + set tcltest::verbose [string map {p pass b body s skip t start e + error} $levelList] + } + } + return $tcltest::verbose +} + +# tcltest::isVerbose -- +# +# Returns true if argument is one of the verbosity levels currently being +# used; returns false otherwise. +# +# Arguments: +# level +# +# Results: +# boolean 1 (true) or 0 (false), depending on whether or not the level +# provided is one of the ones stored in tcltest::verbose. +# +# Side effects: +# None. + +proc tcltest::isVerbose {level} { + if {[lsearch -exact [tcltest::verbose] $level] == -1} { + return 0 + } + return 1 } + + # tcltest::match -- # # Set or return the match patterns (tcltest::match) that determine which @@ -530,8 +585,8 @@ proc tcltest::verbose { {level __QUERY} } { # Side effects: # none -proc tcltest::match { {matchList __QUERY} } { - if {$matchList == "__QUERY"} { +proc tcltest::match { {matchList ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::match } set tcltest::match $matchList @@ -551,8 +606,8 @@ proc tcltest::match { {matchList __QUERY} } { # Side effects: # None. -proc tcltest::skip { {skipList __QUERY} } { - if {$skipList == "__QUERY"} { +proc tcltest::skip { {skipList ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::skip } set tcltest::skip $skipList @@ -571,8 +626,8 @@ proc tcltest::skip { {skipList __QUERY} } { # Side effects: # None. -proc tcltest::matchFiles { {matchFileList __QUERY} } { - if {$matchFileList == "__QUERY"} { +proc tcltest::matchFiles { {matchFileList ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::matchFiles } set tcltest::matchFiles $matchFileList @@ -591,8 +646,8 @@ proc tcltest::matchFiles { {matchFileList __QUERY} } { # Side effects: # None. -proc tcltest::skipFiles { {skipFileList __QUERY} } { - if {$skipFileList == "__QUERY"} { +proc tcltest::skipFiles { {skipFileList ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::skipFiles } set tcltest::skipFiles $skipFileList @@ -613,8 +668,8 @@ proc tcltest::skipFiles { {skipFileList __QUERY} } { # Side effects: # None. -proc tcltest::matchDirectories { {dirlist __QUERY} } { - if {$dirlist == "__QUERY"} { +proc tcltest::matchDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::matchDirectories } set tcltest::matchDirectories $dirlist @@ -634,8 +689,8 @@ proc tcltest::matchDirectories { {dirlist __QUERY} } { # Side effects: # None. -proc tcltest::skipDirectories { {dirlist __QUERY} } { - if {$dirlist == "__QUERY"} { +proc tcltest::skipDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::skipDirectories } set tcltest::skipDirectories $dirlist @@ -659,8 +714,8 @@ proc tcltest::skipDirectories { {dirlist __QUERY} } { # Side effects: # None. -proc tcltest::preserveCore { {coreLevel __QUERY} } { - if {$coreLevel == "__QUERY"} { +proc tcltest::preserveCore { {coreLevel ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::preserveCore } set tcltest::preserveCore $coreLevel @@ -682,8 +737,8 @@ proc tcltest::preserveCore { {coreLevel __QUERY} } { # Side effects: # None. -proc tcltest::outputChannel { {filename __QUERY} } { - if {$filename == "__QUERY"} { +proc tcltest::outputChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::outputChannel } if {($filename == "stderr") || ($filename == "stdout")} { @@ -712,8 +767,8 @@ proc tcltest::outputChannel { {filename __QUERY} } { # if the file name supplied is relative, it will be made absolute with # respect to the predefined temporaryDirectory -proc tcltest::outputFile { {filename __QUERY} } { - if {$filename == "__QUERY"} { +proc tcltest::outputFile { {filename ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::outputFile } if {($filename != "stderr") && ($filename != "stdout")} { @@ -740,8 +795,8 @@ proc tcltest::outputFile { {filename __QUERY} } { # opens the descriptor in w mode unless the filename is set to stderr or # stdout -proc tcltest::errorChannel { {filename __QUERY} } { - if {$filename == "__QUERY"} { +proc tcltest::errorChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::errorChannel } if {($filename == "stderr") || ($filename == "stdout")} { @@ -767,8 +822,8 @@ proc tcltest::errorChannel { {filename __QUERY} } { # if the file name supplied is relative, it will be made absolute with # respect to the predefined temporaryDirectory -proc tcltest::errorFile { {filename __QUERY} } { - if {$filename == "__QUERY"} { +proc tcltest::errorFile { {filename ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::errorFile } if {($filename != "stderr") && ($filename != "stdout")} { @@ -797,8 +852,8 @@ proc tcltest::errorFile { {filename __QUERY} } { # Side effects: # None. -proc tcltest::debug { {debugLevel __QUERY} } { - if {$debugLevel == "__QUERY"} { +proc tcltest::debug { {debugLevel ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::debug } set tcltest::debug $debugLevel @@ -821,9 +876,9 @@ proc tcltest::debug { {debugLevel __QUERY} } { # Side effects: # appends the constraint name to tcltest::constraintsSpecified -proc tcltest::testConstraint {constraint {value __QUERY}} { +proc tcltest::testConstraint {constraint {value ""}} { DebugPuts 3 "entering testConstraint $constraint $value" - if {$value == "__QUERY"} { + if {[llength [info level 0]] == 2} { return $tcltest::testConstraints($constraint) } lappend tcltest::constraintsSpecified $constraint @@ -878,9 +933,9 @@ proc tcltest::constraintList {} { # Side effects: # None. -proc tcltest::limitConstraints { {constraintList __QUERY} } { +proc tcltest::limitConstraints { {constraintList ""} } { DebugPuts 3 "entering limitConstraints $constraintList" - if {$constraintList == "__QUERY"} { + if {[llength [info level 0]] == 1} { return $tcltest::limitConstraints } set tcltest::limitConstraints $constraintList @@ -905,8 +960,8 @@ proc tcltest::limitConstraints { {constraintList __QUERY} } { # Side effects: # None. -proc tcltest::loadScript { {script __QUERY} } { - if {$script == "__QUERY"} { +proc tcltest::loadScript { {script ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::loadScript } set tcltest::loadScript $script @@ -926,8 +981,8 @@ proc tcltest::loadScript { {script __QUERY} } { # Side effects: # None. -proc tcltest::loadFile { {scriptFile __QUERY} } { - if {$scriptFile == "__QUERY"} { +proc tcltest::loadFile { {scriptFile ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::loadFile } MakeAbsolutePath scriptFile $tcltest::temporaryDirectory @@ -953,8 +1008,8 @@ proc tcltest::loadFile { {scriptFile __QUERY} } { # Side effects: # None. -proc tcltest::workingDirectory { {dir __QUERY} } { - if {$dir == "__QUERY"} { +proc tcltest::workingDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::workingDirectory } set tcltest::workingDirectory $dir @@ -982,8 +1037,8 @@ proc tcltest::workingDirectory { {dir __QUERY} } { # Side effects: # None. -proc tcltest::temporaryDirectory { {dir __QUERY} } { - if {$dir == "__QUERY"} { +proc tcltest::temporaryDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::temporaryDirectory } set tcltest::temporaryDirectory $dir @@ -1017,8 +1072,8 @@ proc tcltest::temporaryDirectory { {dir __QUERY} } { # Side effects: # None. -proc tcltest::testsDirectory { {dir __QUERY} } { - if {$dir == "__QUERY"} { +proc tcltest::testsDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::testsDirectory } @@ -1043,8 +1098,8 @@ proc tcltest::testsDirectory { {dir __QUERY} } { # # Arguments: # value for singleProcess: -# 0 = source each test file -# 1 = run each test file in its own process +# 1 = source each test file into the current process +# 0 = run each test file in its own process # # Results: # content of tcltest::singleProcess @@ -1052,8 +1107,8 @@ proc tcltest::testsDirectory { {dir __QUERY} } { # Side effects: # None. -proc tcltest::singleProcess { {value __QUERY} } { - if {$value == "__QUERY"} { +proc tcltest::singleProcess { {value ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::singleProcess } set tcltest::singleProcess $value @@ -1072,8 +1127,8 @@ proc tcltest::singleProcess { {value __QUERY} } { # Side effects: # None. -proc tcltest::interpreter { {interp __QUERY} } { - if {$interp == "__QUERY"} { +proc tcltest::interpreter { {interp ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::tcltest } set tcltest::tcltest $interp @@ -1092,8 +1147,8 @@ proc tcltest::interpreter { {interp __QUERY} } { # Side effects: # None. -proc tcltest::mainThread { {threadid __QUERY} } { - if {$threadid == "__QUERY"} { +proc tcltest::mainThread { {threadid ""} } { + if {[llength [info level 0]] == 1} { return $tcltest::mainThread } set tcltest::mainThread $threadid @@ -1112,6 +1167,9 @@ proc tcltest::mainThread { {threadid __QUERY} } { # Results: # Modifies tcltest::skippedBecause; sets the variable to 1 if didn't # previously exist - otherwise, it just increments it. +# +# Side effects: +# None. proc tcltest::AddToSkippedBecause { constraint {value 1}} { # add the constraint to the list of constraints that kept tests @@ -1133,6 +1191,12 @@ proc tcltest::AddToSkippedBecause { constraint {value 1}} { # Arguments: # errorMsg String containing the error to be printed # +# +# Results: +# None. +# +# Side effects: +# None. proc tcltest::PrintError {errorMsg} { set InitialMessage "Error: " @@ -1181,6 +1245,33 @@ if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { proc tcltest::initConstraintsHook {} {} } +# tcltest::safeFetch -- +# +# The following trace procedure makes it so that we can safely refer to +# non-existent members of the tcltest::testConstraints array without +# causing an error. Instead, reading a non-existent member will return +# 0. This is necessary because tests are allowed to use constraint "X" +# without ensuring that tcltest::testConstraints("X") is defined. +# +# Arguments: +# n1 - name of the array (tcltest::testConstraints) +# n2 - array key value (constraint name) +# op - operation performed on tcltest::testConstraints (generally r) +# +# Results: +# none +# +# Side effects: +# sets tcltest::testConstraints($n2) to 0 if it's referenced but never +# before used + +proc tcltest::safeFetch {n1 n2 op} { + DebugPuts 3 "entering safeFetch $n1 $n2 $op" + if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { + tcltest::testConstraint $n2 0 + } +} + # tcltest::initConstraints -- # # Check constraint information that will determine which tests @@ -1196,39 +1287,38 @@ if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { # Results: # The tcltest::testConstraints array is reset to have an index for # each built-in test constraint. - -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 - } -} +# +# Side Effects: +# None. +# proc tcltest::initConstraints {} { global tcl_platform tcl_interactive tk_version - # The following trace procedure makes it so that we can safely refer to - # non-existent members of the tcltest::testConstraints array without - # causing an error. Instead, reading a non-existent member will return 0. - # This is necessary because tests are allowed to use constraint "X" without - # ensuring that tcltest::testConstraints("X") is defined. - + # Safely refer to non-existent members of the tcltest::testConstraints + # array without causing an error. trace variable tcltest::testConstraints r tcltest::safeFetch 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] \ @@ -1236,6 +1326,12 @@ proc tcltest::initConstraints {} { 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]}] @@ -1251,6 +1347,8 @@ proc tcltest::initConstraints {} { tcltest::testConstraint tempNotPc \ [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint tempNotWin \ + [expr {![tcltest::testConstraint win]}] tcltest::testConstraint tempNotMac \ [expr {![tcltest::testConstraint mac]}] tcltest::testConstraint tempNotUnix \ @@ -1262,6 +1360,8 @@ proc tcltest::initConstraints {} { tcltest::testConstraint pcCrash \ [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint winCrash \ + [expr {![tcltest::testConstraint win]}] tcltest::testConstraint macCrash \ [expr {![tcltest::testConstraint mac]}] tcltest::testConstraint unixCrash \ @@ -1475,6 +1575,11 @@ if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} { # Arguments: # none # +# Results: +# none +# +# Side Effects: +# none proc tcltest::PrintUsageInfo {} { puts [format "Usage: [file tail [info nameofexecutable]] \ @@ -1482,12 +1587,13 @@ proc tcltest::PrintUsageInfo {} { 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' and 't'. Test suite will \n\ + \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\ \t display all passed tests if 'p' is \n\ \t specified, all skipped tests if 's' \n\ \t is specified, 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\ @@ -1702,6 +1808,7 @@ proc tcltest::ProcessFlags {flagArray} { # Call the hook tcltest::processCmdLineArgsHook [array get flag] + return } # tcltest::processCmdLineArgs -- @@ -1720,6 +1827,10 @@ proc tcltest::ProcessFlags {flagArray} { # # Results: # Sets the above-named variables in the tcltest namespace. +# +# Side Effects: +# None. +# proc tcltest::processCmdLineArgs {} { global argv @@ -1760,6 +1871,7 @@ proc tcltest::processCmdLineArgs {} { DebugPArray 2 tcltest::originalEnv DebugPuts 2 "Constraints:" DebugPArray 2 tcltest::testConstraints + return } ##################################################################### @@ -1819,7 +1931,7 @@ proc tcltest::testPuts {args} { # If we haven't returned by now, we don't know how to handle the input. # Let puts handle it. - eval tcltest::normalPuts $args + return [eval tcltest::normalPuts $args] } # tcltest::testEval -- @@ -1908,13 +2020,17 @@ proc tcltest::compareStrings {actual expected mode} { # # http://purl.org/thecliff/tcl/wiki/858.html # -# Returns: +# Results: # a list containing the result of the substitution # # Exceptions: # An error may occur if the list containing unbalanced quote or # unknown variable. # +# Side Effects: +# None. +# + proc tcltest::substArguments {argList} { # We need to split the argList up into tokens but cannot use @@ -1985,7 +2101,7 @@ proc tcltest::substArguments {argList} { } -# test -- +# 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 @@ -2036,7 +2152,9 @@ proc tcltest::substArguments {argList} { # 0 if the command ran successfully; 1 otherwise. # # Side effects: +# None. # + proc tcltest::test {name description args} { DebugPuts 3 "Test $name $args" @@ -2057,10 +2175,6 @@ proc tcltest::test {name description args} { # the test script). set returnCodes [list 0 2] - # if the commands are embedded within an outer set of braces, we have to do - # evaluate them before we can run or compare them - set doSubst false - # The old test format can't have a 3rd argument (constraints or script) # that starts with '-'. if {[llength $args] == 0} { @@ -2074,7 +2188,13 @@ proc tcltest::test {name description args} { foreach {element value} $list { set testAttributes($element) $value } - set doSubst true + foreach item {constraints match setup body cleanup \ + result returnCodes output errorOutput} { + if {[info exists testAttributes([subst -$item])]} { + set testAttributes([subst -$item]) \ + [uplevel concat $testAttributes([subst -$item])] + } + } } else { array set testAttributes $args } @@ -2128,18 +2248,11 @@ proc tcltest::test {name description args} { set cleanupFailure 0 # Run the setup script - if {$doSubst} { - set setup [uplevel concat $setup] - } if {[catch {uplevel $setup} setupMsg]} { set setupFailure 1 } # run the test script - if {$doSubst} { - set constraints [uplevel concat $constraints] - set body [uplevel concat $body] - } set command [list tcltest::runTest $name $description $body \ $result $constraints] if {!$setupFailure} { @@ -2153,25 +2266,10 @@ proc tcltest::test {name description args} { } # Run the cleanup code - if {$doSubst} { - set cleanup [uplevel concat $cleanup] - } if {[catch {uplevel $cleanup} cleanupMsg]} { set cleanupFailure 1 } - if {$doSubst} { - foreach item {result returnCodes match} { - set $item [uplevel concat [subst $$item]] - } - if {[info exists output]} { - set output [uplevel concat $output] - } - if {[info exists errorOutput]} { - set errorOutput [uplevel concat $errorOutput] - } - } - # If testResult is an empty list, then the test was skipped if {$testResult != {}} { set coreFailure 0 @@ -2243,7 +2341,7 @@ proc tcltest::test {name description args} { $scriptFailure)} { if {$tcltest::testLevel == 1} { incr tcltest::numTests(Passed) - if {[string first p $tcltest::verbose] != -1} { + if {[tcltest::isVerbose pass]} { puts [outputChannel] "++++ $name PASSED" } } @@ -2255,7 +2353,7 @@ proc tcltest::test {name description args} { incr tcltest::numTests(Failed) } set tcltest::currentFailure true - if {[string first b $tcltest::verbose] == -1} { + if {![tcltest::isVerbose body]} { set body "" } puts [outputChannel] "\n==== $name [string trim $description] FAILED" @@ -2281,6 +2379,12 @@ proc tcltest::test {name description args} { } puts [outputChannel] "---- $msg; Return code was: $code" puts [outputChannel] "---- Return code should have been one of: $returnCodes" + if {[tcltest::isVerbose error]} { + if {[info exists ::errorInfo]} { + puts [outputChannel] "---- errorInfo: $::errorInfo" + puts [outputChannel] "---- errorCode: $::errorCode" + } + } } if {$outputFailure} { puts [outputChannel] "---- Output was:\n$tcltest::outData" @@ -2337,9 +2441,13 @@ proc tcltest::test {name description args} { # then events are logged and we track the number of tests run/skipped and why. # Otherwise, we don't track this information. # -# Returns: +# 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} { @@ -2418,7 +2526,7 @@ proc tcltest::runTest {name description script expectedAnswer constraints} { } if {$doTest == 0} { - if {[string first s $tcltest::verbose] != -1} { + if {[tcltest::isVerbose skip]} { puts [outputChannel] "++++ $name SKIPPED: $constraints" } @@ -2451,7 +2559,7 @@ proc tcltest::runTest {name description script expectedAnswer constraints} { memory tag $name } - if {[string first t $tcltest::verbose] != -1} { + if {[tcltest::isVerbose start]} { puts [outputChannel] "---- $name start" flush [outputChannel] } @@ -2485,6 +2593,20 @@ if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} { # tests were invoked. # # Restore original environment (as reported by special variable env). +# +# Arguments: +# calledFromAllFile - if 0, behave as if we are running a single test file +# within an entire suite of tests. if we aren't running a single test +# file, then don't report status. check for new files created during the +# test run and report on them. if 1, report collated status from all the +# test file runs. +# +# Results: +# None. +# +# Side Effects: +# None +# proc tcltest::cleanupTests {{calledFromAllFile 0}} { @@ -2680,6 +2802,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { } flush [outputChannel] flush [errorChannel] + return } ##################################################################### @@ -2692,19 +2815,21 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { # and uses them to put together a list of the tests that will be run. # # Arguments: -# none +# directory to search # # Results: # The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. +# be used in 'all.tcl' files. It is used in runAllTests. +# +# Side Effects: +# None -proc tcltest::getMatchingFiles {args} { - set matchingFiles {} - if {[llength $args]} { - set searchDirectory $args - } else { - set searchDirectory [list $tcltest::testsDirectory] +proc tcltest::getMatchingFiles { {searchDirectory ""} } { + if {[llength [info level 0]] == 1} { + set searchDirectory [tcltest::testsDirectory] } + set matchingFiles {} + # Find the matching files in the list of directories and then remove the # ones that match the skip pattern foreach directory $searchDirectory { @@ -2746,12 +2871,15 @@ proc tcltest::getMatchingFiles {args} { # the list.) # # Arguments: -# none +# root directory from which to search # # Results: # The constructed list is returned to the user. This is used in the # primary all.tcl file. Lower-level all.tcl files should use the # tcltest::testAllFiles proc instead. +# +# Side Effects: +# None. proc tcltest::getMatchingDirectories {rootdir} { set matchingDirs {} @@ -2806,15 +2934,24 @@ proc tcltest::getMatchingDirectories {rootdir} { # Side effects: # None. -proc tcltest::runAllTests [list [list shell [tcltest::interpreter]]] { +proc tcltest::runAllTests { {shell ""} } { global argv + if {[llength [info level 0]] == 1} { + set shell [tcltest::interpreter] + } + set tcltest::testSingleFile false puts [outputChannel] "Tests running in interp: $shell" puts [outputChannel] "Tests located in: $tcltest::testsDirectory" puts [outputChannel] "Tests running in: [tcltest::workingDirectory]" puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory" + if {[tcltest::singleProcess]} { + puts [outputChannel] "Test files sourced into current interpreter" + } else { + puts [outputChannel] "Test files run in separate interpreters" + } if {[llength $tcltest::skip] > 0} { puts [outputChannel] "Skipping tests that match: $tcltest::skip" } @@ -2838,6 +2975,7 @@ proc tcltest::runAllTests [list [list shell [tcltest::interpreter]]] { puts [outputChannel] $tail if {$tcltest::singleProcess} { + incr tcltest::numTestFiles uplevel [list source $file] } else { # Change to the tests directory so the value of the following @@ -2845,13 +2983,13 @@ proc tcltest::runAllTests [list [list shell [tcltest::interpreter]]] { cd $tcltest::testsDirectory set cmd [concat [list | $shell $file] [split $argv]] if {[catch { + incr tcltest::numTestFiles set pipeFd [open $cmd "r"] while {[gets $pipeFd line] >= 0} { if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { foreach index [list "Total" "Passed" "Skipped" "Failed"] { incr tcltest::numTests($index) [set $index] } - incr tcltest::numTestFiles if {$Failed > 0} { lappend tcltest::failFiles $testFile } @@ -2913,35 +3051,16 @@ proc tcltest::runAllTests [list [list shell [tcltest::interpreter]]] { # # Results # none +# +# Side Effects: +# none. proc tcltest::loadTestedCommands {} { if {$tcltest::loadScript == {}} { return } - uplevel $tcltest::loadScript -} - -# The following two procs are used in the io tests. - -proc tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} - } - return $result -} - -proc tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} - } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p - } - } - return $leak + return [uplevel $tcltest::loadScript] } # tcltest::saveState -- @@ -2953,10 +3072,14 @@ proc tcltest::leakfiles {old} { # # Results: # Modifies the variable tcltest::saveState +# +# Side effects: +# None. proc tcltest::saveState {} { uplevel {set tcltest::saveState [list [info procs] [info vars]]} DebugPuts 2 "tcltest::saveState: $tcltest::saveState" + return } # tcltest::restoreState -- @@ -2970,6 +3093,9 @@ proc tcltest::saveState {} { # Results: # Removes procs and variables from your environment if they don't exist # in the tcltest::saveState variable. +# +# Side effects: +# None. proc tcltest::restoreState {} { foreach p [info procs] { @@ -2986,6 +3112,7 @@ proc tcltest::restoreState {} { uplevel "catch {unset $p}" } } + return } # tcltest::normalizeMsg -- @@ -2995,6 +3122,11 @@ proc tcltest::restoreState {} { # Arguments: # msg String to be modified # +# Results: +# string with extra newlines removed +# +# Side effects: +# None. proc tcltest::normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg @@ -3003,7 +3135,7 @@ proc tcltest::normalizeMsg {msg} { return $msg } -# makeFile -- +# tcltest::makeFile -- # # Create a new file with the name <name>, and write <contents> to it. # @@ -3011,12 +3143,28 @@ proc tcltest::normalizeMsg {msg} { # cleanupTests was called, add it to the $filesMade list, so it will # be removed by the next call to cleanupTests. # -proc tcltest::makeFile {contents name} { +# Arguments: +# contents content of the new file +# name name of the new file +# directory directory name for new file +# +# Results: +# absolute path to the file created +# +# Side effects: +# None. + +proc tcltest::makeFile {contents name {directory ""}} { global tcl_platform + + if {[llength [info level 0]] == 3} { + set directory [tcltest::temporaryDirectory] + } - DebugPuts 3 "tcltest::makeFile: putting $contents into $name" + set fullName [file join $directory $name] + + DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" - set fullName [file join $tcltest::temporaryDirectory $name] set fd [open $fullName w] fconfigure $fd -translation lf @@ -3039,15 +3187,25 @@ proc tcltest::makeFile {contents name} { # Removes the named file from the filesystem # # Arguments: -# name file to be removed +# name file to be removed +# directory directory from which to remove file +# +# Results: +# return value from [file delete] # +# Side effects: +# None. -proc tcltest::removeFile {name} { - DebugPuts 3 "tcltest::removeFile: removing $name" - file delete [file join $tcltest::temporaryDirectory $name] +proc tcltest::removeFile {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeFile: removing $fullName" + return [file delete $fullName] } -# makeDirectory -- +# tcltest::makeDirectory -- # # Create a new dir with the name <name>. # @@ -3055,9 +3213,22 @@ proc tcltest::removeFile {name} { # cleanupTests was called, add it to the $directoriesMade list, so it will # be removed by the next call to cleanupTests. # -proc tcltest::makeDirectory {name} { - DebugPuts 3 "tcltest::makeDirectory: creating $name" - set fullName [file join $tcltest::temporaryDirectory $name] +# Arguments: +# name name of the new directory +# directory directory in which to create new dir +# +# Results: +# absolute path to the directory created +# +# Side effects: +# None. + +proc tcltest::makeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::makeDirectory: creating $fullName" file mkdir $fullName if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { lappend tcltest::filesMade $fullName @@ -3070,62 +3241,57 @@ proc tcltest::makeDirectory {name} { # Removes a named directory from the file system. # # Arguments: -# name Name of the directory to remove +# name Name of the directory to remove +# directory Directory from which to remove # +# Results: +# return value from [file delete] +# +# Side effects: +# None -proc tcltest::removeDirectory {name} { - DebugPuts 3 "tcltest::removeDirectory: deleting $name" - file delete -force [file join $tcltest::temporaryDirectory $name] +proc tcltest::removeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" + return [file delete -force $fullName] } -proc tcltest::viewFile {name} { +# tcltest::viewFile -- +# +# reads the content of a file and returns it +# +# Arguments: +# name of the file to read +# directory in which file is located +# +# Results: +# content of the named file +# +# Side effects: +# None. + +proc tcltest::viewFile {name {directory ""}} { global tcl_platform + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] if {([string equal $tcl_platform(platform) "macintosh"]) || \ ([tcltest::testConstraint unixExecs] == 0)} { - set f [open [file join $tcltest::temporaryDirectory $name]] + set f [open $fullName] set data [read -nonewline $f] close $f return $data } else { - exec cat [file join $tcltest::temporaryDirectory $name] - } -} - -# grep -- -# -# Evaluate a given expression against each element of a list and return all -# elements for which the expression evaluates to true. For the purposes of -# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the -# value of the current element within the expression. This is equivalent to -# the perl grep command where CURRENT_ELEMENT would be the name for the special -# variable $_. -# -# Examples of usage would be: -# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] -# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] -# -# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is -# assumed to be the final argument to the expression provided. -# -# Example: -# grep {regexp a} $someList -# -proc tcltest::grep { expression searchList } { - foreach element $searchList { - if {[regsub -all CURRENT_ELEMENT $expression $element \ - newExpression] == 0} { - set newExpression "$expression {$element}" - } - if {[eval $newExpression] == 1} { - lappend returnList $element - } - } - if {[info exists returnList]} { - return $returnList + return [exec cat $fullName] } return } +# tcltest::bytestring -- # # Construct a string that consists of the requested sequence of bytes, # as opposed to a string of properly formed UTF-8 characters. @@ -3139,14 +3305,83 @@ proc tcltest::grep { expression searchList } { # Generally, it's a bad idea to examine the bytes in a Tcl string or to # construct improperly formed strings in this manner, because it involves # exposing that Tcl uses UTF-8 internally. +# +# Arguments: +# string being converted +# +# Results: +# result fom encoding +# +# Side effects: +# None proc tcltest::bytestring {string} { - encoding convertfrom identity $string + return [encoding convertfrom identity $string] +} + +# tcltest::openfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +# tcltest::leakfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak } # # Internationalization / ISO support procs -- dl # + +# tcltest::set_iso8859_1_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + proc tcltest::set_iso8859_1_locale {} { if {[info commands testlocale] != ""} { set tcltest::previousLocale [testlocale ctype] @@ -3155,6 +3390,19 @@ proc tcltest::set_iso8859_1_locale {} { return } +# tcltest::restore_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + proc tcltest::restore_locale {} { if {[info commands testlocale] != ""} { testlocale ctype $tcltest::previousLocale @@ -3162,7 +3410,7 @@ proc tcltest::restore_locale {} { return } -# threadReap -- +# tcltest::threadReap -- # # Kill all threads except for the main thread. # Do nothing if testthread is not defined. @@ -3172,6 +3420,11 @@ proc tcltest::restore_locale {} { # # Results: # Returns the number of existing threads. +# +# Side Effects: +# none. +# + proc tcltest::threadReap {} { if {[info commands testthread] != {}} { @@ -3212,6 +3465,7 @@ proc tcltest::threadReap {} { } else { return 1 } + return 0 } # Initialize the constraints and set up command line arguments diff --git a/tests/basic.test b/tests/basic.test index b30f705..cb97c24 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -15,7 +15,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: basic.test,v 1.10 2000/04/10 17:18:57 ericm Exp $ +# RCS: @(#) $Id: basic.test,v 1.11 2000/10/19 18:01:00 jenn Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -23,6 +23,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +# This variable needs to be changed when the major or minor version number for +# Tcl changes. +set tclvers 8.4 + catch {namespace delete test_ns_basic} catch {interp delete test_interp} catch {rename p ""} @@ -494,10 +498,10 @@ test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of tra } {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}} test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { testcmdtrace tracetest {set stuff [info tclversion]} -} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff $::tcltest::version"] +} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff $tclvers"] test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { testcmdtrace deletetest {set stuff [info tclversion]} -} $::tcltest::version +} $tclvers } test basic-40.1 {Tcl_DeleteTrace} {emptyTest} { diff --git a/tests/tcltest2.test b/tests/tcltest2.test index 4cfb847..6c7c3d1 100755 --- a/tests/tcltest2.test +++ b/tests/tcltest2.test @@ -6,7 +6,7 @@ # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest2.test,v 1.2 2000/09/29 22:48:34 jenn Exp $ +# RCS: @(#) $Id: tcltest2.test,v 1.3 2000/10/19 18:01:00 jenn Exp $ set tcltestVersion [package require tcltest] namespace import -force ::tcltest::* @@ -29,6 +29,9 @@ makeFile { } {0} test c-1.0 {test c} {knownBug} { } {} + test d-1.0 {test d} { + error "foo" foo 9 + } {} ::tcltest::cleanupTests exit } test.tcl @@ -53,37 +56,44 @@ test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl} msg] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -verbose 'b'} msg] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -verbose 'p'} msg] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 0 1} test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -verbose 's'} msg] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 0 1 1} test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -verbose 'ps'} msg] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 1 1} test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -verbose 'psb'} msg] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] +} {0 1 1 1 1} + +test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -verbose "pass skip body"} msg] + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ + [regexp c-1.0 $msg] \ + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-2.6 {tcltest -verbose 't'} { @@ -96,6 +106,16 @@ test tcltest-2.6 {tcltest -verbose 't'} { -match regexp } +test tcltest-2.6a {tcltest -verbose 'start'} { + -constraints {unixOrPc} + -body { + set result [catch {exec $::tcltest::tcltest test.tcl -verbose start} msg] + list $result $msg + } + -result {^0 .*a-1.0 start.*b-1.0 start} + -match regexp +} + test tcltest-2.7 {tcltest::verbose} { -body { set oldVerbosity [tcltest::verbose] @@ -104,31 +124,40 @@ test tcltest-2.7 {tcltest::verbose} { tcltest::verbose foo set newVerbosity [tcltest::verbose] tcltest::verbose $oldVerbosity - list $currentVerbosity $newVerbosity + list $currentVerbosity $newVerbosity } - -result {bar foo} + -result {{body a r} {f o o}} } +test tcltest-2.8 {tcltest -verbose 'error'} { + -constraints {unixOrPc} + -body { + set result [catch {exec $::tcltest::tcltest test.tcl -verbose error} msg] + list $result $msg + } + -result {errorInfo: foo.*errorCode: 9} + -match regexp +} # -match, tcltest::match test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -match a* -verbose 'ps'} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -match b* -verbose 'ps'} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 1 0 1} test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -match c* -verbose 'ps'} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+0.+Skipped.+3.+Failed.+0" $msg] + [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg] } {0 0 0 1 1} test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -match {a* b*} -verbose 'ps'} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 1 0 1} test tcltest-3.5 {tcltest::match} { @@ -148,27 +177,27 @@ test tcltest-3.5 {tcltest::match} { test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -skip a* -verbose 'ps'} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] } {0 0 1 1 1} test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -skip b* -verbose 'ps'} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 0 1 1} test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -skip c* -verbose 'ps'} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 0 1} test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -skip {a* b*} -verbose 'ps'} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+0.+Skipped.+3.+Failed.+0" $msg] + [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 0 1 1} test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -match {a* b*} -skip b* -verbose 'ps'} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} test tcltest-4.6 {tcltest::skip} { @@ -190,12 +219,12 @@ test tcltest-4.6 {tcltest::skip} { test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -constraints knownBug -verbose 'ps'} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+2.+Skipped.+0.+Failed.+1" $msg] + [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1} msg] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ - [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg] + [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 0 0 1 1} test tcltest-5.3 {tcltest::testConstraint - constraint empty (tcltest::safeFetch)} { @@ -233,7 +262,7 @@ test tcltest-5.4 {tcltest::constraintsSpecified} { test tcltest-5.5 {tcltest::constraintList} { -constraints {!$tcltest::singleTestInterp} -body { - tcltest::constraintList + lsort [tcltest::constraintList] } -result {unixOrPc socket nonBlockFiles asyncPipeClose nt knownBug macOnly pc unixExecs nonPortable pcCrash unix notRoot macOrPc eformat macOrUnix 95 tempNotMac 98 mac macCrash tempNotPc stdio tempNotUnix root singleTestInterp unixCrash pcOnly interactive unixOnly hasIsoLocale userInteraction emptyTest} } @@ -258,7 +287,7 @@ test tcltest-5.6 {tcltest::limitConstraints} { # -outfile, -errfile, tcltest::outputChannel, tcltest::outputFile, # tcltest::errorChannel, tcltest::errorFile -makeFile { +set printerror [makeFile { package require tcltest namespace import -force ::tcltest::* puts $::tcltest::outputChannel "a test" @@ -271,12 +300,17 @@ makeFile { \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\"" exit -} printerror.tcl +} printerror.tcl] -test tcltest-6.1 {tcltest -outfile, -errfile defaults} {unixOrPc} { - catch {exec $::tcltest::tcltest printerror.tcl} msg - list [regexp "a test" $msg] [regexp "a really" $msg] -} {1 1} +test tcltest-6.1 {tcltest -outfile, -errfile defaults} { + -constraints unixOrPc + -body { + catch {exec [tcltest::interpreter] $printerror} msg + return $msg + } + -result {a test.*a really} + -match regexp +} test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc} { catch {exec $::tcltest::tcltest printerror.tcl -outfile a.tmp} msg set result1 [catch {exec grep "a test" a.tmp}] @@ -436,11 +470,17 @@ test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} { list [file exists [file join thisdirectorydoesnotexist a.tmp]] \ [file delete -force thisdirectorydoesnotexist] } {1 {}} -test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {unixOrPc} { - catch {exec $::tcltest::tcltest a.tcl -tmpdir thisdirectoryisafile} msg - # The join is necessary because the message can be split on multiple lines - list [regexp "not a directory" [join $msg]] -} {1} +test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { + -constraints unixOrPc + -body { + catch {exec $::tcltest::tcltest a.tcl -tmpdir thisdirectoryisafile} msg + # The join is necessary because the message can be split on multiple + # lines + join $msg + } + -result {not a directory} + -match regexp +} # Test non-writeable directories, non-readable directories with directory flags set notReadableDir [file join $::tcltest::temporaryDirectory notreadable] @@ -477,10 +517,10 @@ test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { file exists [file join $normaldirectory a.tmp] } {1} +set current [pwd] test tcltest-8.6 {tcltest::temporaryDirectory} { -setup { set old $tcltest::temporaryDirectory - set current [pwd] set tcltest::temporaryDirectory $normaldirectory } -body { @@ -495,6 +535,18 @@ test tcltest-8.6 {tcltest::temporaryDirectory} { } } +test tcltest-8.6a {tcltest::temporaryDirectory - test format 2} -setup { + set old $tcltest::temporaryDirectory + set tcltest::temporaryDirectory $normaldirectory +} -body { + set f1 [tcltest::temporaryDirectory] + set f2 [tcltest::temporaryDirectory $current] + set f3 [tcltest::temporaryDirectory] + list $f1 $f2 $f3 +} -cleanup { + set tcltest::temporaryDirectory $old +} -result "$normaldirectory $current $current" + # -testdir, tcltest::testsDirectory test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { file delete -force thisdirectorydoesnotexist @@ -705,9 +757,6 @@ test tcltest-12.4 {tcltest::loadFile} { set tcltest::load-body {} set oldf $tcltest::loadFile set tcltest::loadFile {} - set f [open load.tcl] - set content [read $f] - close $f } -body { set f1 [tcltest::loadScript] @@ -717,7 +766,13 @@ test tcltest-12.4 {tcltest::loadFile} { set f5 [tcltest::loadFile] list $f1 $f2 $f3 $f4 $f5 } - -result "{} {} $loadfile \{$content\} $loadfile" + -result "{} {} $loadfile { + package require tcltest + namespace import -force ::tcltest::* + puts \$::tcltest::loadScript + exit +} $loadfile +" -cleanup { set tcltest::loadScript $olds set tcltest::loadFile $oldf @@ -1054,6 +1109,17 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} { -output "foo is 2" } +test tcltest-21.7 {test command - bad flag} { + -body { + test foo-4 {foo-4} { + -foobar {} + } + } + -result {1} + -errorOutput {test foo-4: bad flag -foobar supplied to tcltest::test*} + -match glob +} + # alternate test command format (these are the same as 21.1-21.6, with the # exception of being in the all-inline format) @@ -1066,7 +1132,7 @@ test tcltest-21.8 {force a test command failure} -body { test foo { return 2 } {1} -} -errorOutput {test foo: {wrong # args: should be "test name desc ?constraints? script expectedResult"} +} -errorOutput {test foo: bad flag 1 supplied to tcltest::test } -result {1} test tcltest-21.9 {test command with setup} \ @@ -1147,6 +1213,92 @@ test tcltest-22.1 {runAllTests} { -result "Test files exiting with errors:.*error.test.*exit.test" } +# makeFile, removeFile, makeDirectory, removeDirectory, viewFile +test tcltest-23.1 {makeFile} { + -setup { + set mfdir [file join [tcltest::temporaryDirectory] mfdir] + file mkdir $mfdir + } + -body { + makeFile {} t1.tmp + makeFile {} et1.tmp $mfdir + list [file exists [file join [tcltest::temporaryDirectory] t1.tmp]] \ + [file exists [file join $mfdir et1.tmp]] + } + -cleanup { + file delete -force $mfdir \ + [file join [tcltest::temporaryDirectory] t1.tmp] + } + -result {1 1} +} +test tcltest-23.2 {removeFile} { + -setup { + set mfdir [file join [tcltest::temporaryDirectory] mfdir] + file mkdir $mfdir + makeFile {} t1.tmp + makeFile {} et1.tmp $mfdir + if {![file exists [file join [tcltest::temporaryDirectory] t1.tmp]] || \ + ![file exists [file join $mfdir et1.tmp]]} { + error "file creation didn't work" + } + } + -body { + removeFile t1.tmp + removeFile et1.tmp $mfdir + list [file exists [file join [tcltest::temporaryDirectory] t1.tmp]] \ + [file exists [file join $mfdir et1.tmp]] + } + -cleanup { + file delete -force $mfdir \ + [file join [tcltest::temporaryDirectory] t1.tmp] + } + -result {0 0} +} +test tcltest-23.3 {makeDirectory} { + -body { + set mfdir [file join [tcltest::temporaryDirectory] mfdir] + file mkdir $mfdir + makeDirectory d1 + makeDirectory d2 $mfdir + list [file exists [file join [tcltest::temporaryDirectory] d1]] \ + [file exists [file join $mfdir d2]] + } + -cleanup { + file delete -force [file join [tcltest::temporaryDirectory] d1] $mfdir + } + -result {1 1} +} +test tcltest-23.4 {removeDirectory} { + -body { + set mfdir [file join [tcltest::temporaryDirectory] mfdir] + file mkdir $mfdir + file mkdir [file join [tcltest::temporaryDirectory] t1] + file mkdir [file join [tcltest::temporaryDirectory] $mfdir t2] + if {![file exists $mfdir] || \ + ![file exists [file join [tcltest::temporaryDirectory] $mfdir t2]]} { + return "setup failed - directory not created" + } + removeDirectory t1 + removeDirectory t2 $mfdir + list [file exists [file join [tcltest::temporaryDirectory] t1]] \ + [file exists [file join $mfdir t2]] + } + -result {0 0} +} +test tcltest-23.5 {viewFile} { + -body { + set mfdir [file join [tcltest::temporaryDirectory] mfdir] + file mkdir $mfdir + makeFile {foobar} t1.tmp + makeFile {foobarbaz} t2.tmp $mfdir + list [viewFile t1.tmp] [viewFile t2.tmp $mfdir] + } + -result {foobar foobarbaz} + -cleanup { + file delete -force $mfdir + } +} + # cleanup if {[file exists a.tmp]} { file delete -force a.tmp |