diff options
| -rw-r--r-- | doc/tcltest.n | 191 | ||||
| -rw-r--r-- | library/tcltest/pkgIndex.tcl | 9 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 427 | ||||
| -rw-r--r-- | library/tcltest1.0/pkgIndex.tcl | 9 | ||||
| -rw-r--r-- | library/tcltest1.0/tcltest.tcl | 427 | ||||
| -rw-r--r-- | tests/all.tcl | 46 | ||||
| -rw-r--r-- | tests/winPipe.test | 18 |
7 files changed, 911 insertions, 216 deletions
diff --git a/doc/tcltest.n b/doc/tcltest.n index d5feea6..b065333 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -6,7 +6,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tcltest.n,v 1.1 1999/06/26 03:47:59 jenn Exp $ +'\" RCS: @(#) $Id: tcltest.n,v 1.2 1999/06/29 20:14:10 jenn Exp $ '\" .so man.macros .TH "Tcltest" n 8.1 Tcl "Tcl Built-In Commands" @@ -19,7 +19,9 @@ Tcltest \- Test harness support code and utilities .sp \fB::tcltest::test \fIname desc ?constraint? script expectedAnswer\fR .sp -\fB::tcltest::cleanupTests \fI?calledFromAll?\fR +\fB::tcltest::cleanupTests \fI?runningMultipleTests?\fR +.sp +\fB::tcltest::getMatchingTestFiles .sp \fB::tcltest::dotests \fIfile pattern\fR .sp @@ -91,6 +93,11 @@ of files created without the \fB::tcltest::makeFile\fR command are printed. This command also restores the original shell environment. The default value for \fIcalledFromAll\fR is false. .TP +\fB::tcltest::getMatchingTestFiles\fP +This command is used when you want to run multiple test files. It returns +the list of tests that should be sourced in an 'all.tcl' file. See the +section \fI"Running test files"\fR for more information. +.TP \fB::tcltest::dotests\fP \fIfile pattern\fR Source a test file and run tests of the specified pattern. .TP @@ -193,6 +200,40 @@ the fly using the ::tcltest::makeFile procedure. Files created by the The <expectedAnswer> argument will be compared against the result of evaluating the <script> argument. If they match, the test passes, otherwise the test fails. +.SH "TCLTEST NAMEPSACE VARIABLES" +The following variables are also defined in the \fBtcltest\fR namespace and +can be used by tests: +.TP +\fB::tcltest::outputChannel\fR +output file ID - defaults to stdout and can be specified using -outfile +.TP +\fB::tcltest::errorChannel\fR +error file ID - defaults to stderr and can be specified using -errfile +.TP +\fB::tcltest::mainThread\fR +main thread ID - defaults to 1 +.TP +\fB::tcltest::originalEnv\fR +values of environment variables at the beginning of the test run (::env) +.TP +\fB::tcltest::workingDirectory\fR +the current working directory ([pwd]) +.TP +\fB::tcltest::temporaryDirectory\fR +the output directory - defaults to the current working directory and can be +specified using -tmpdir +.TP +\fB::tcltest::testsDirectory\fR +where the tests reside - defaults to [pwd] and can be affected by use of +-relateddir and -asidefromdir +.TP +\fB::tcltest::isoLocale\fR +used for internationalization support - default language is French; default +value is fr_FR.ISO_8859-1 for FreeBSD, fr_FR.iso88591 for HP-UX, fr for +Linux and IRIX, iso_8859_1 for other UNIX systems, and French for Windows. +.TP +\fB::tcltest::tcltest\fR +the name of the tcltest executable ([info nameofexecutable]) .SH "TEST CONSTRAINTS" Constraints are used to determine whether a test should be skipped. Each constraint is stored as an index in the array @@ -221,6 +262,9 @@ test can only be run on any Windows NT platform \fI95\fR test can only be run on any Windows 95 platform .TP +\fI98\fR +test can only be run on any Windows 98 platform +.TP \fImac\fR test can only be run on any Mac platform .TP @@ -294,9 +338,6 @@ etc. available. \fIhasIsoLocale\fR test can only be run if can switch to an ISO locale .TP -\fIfonts\fR -test can only be run if the wish app's fonts can be controlled by Tk. -.TP \fIroot\fR test can only run if Unix user is root .TP @@ -319,6 +360,9 @@ Command line options include (variables that correspond to each flag are listed at the end of each flag description in parenthesis): .RS .TP +\fB-help\fR +display usage information. +.TP \fB-verbose <level>\fR set the level of verbosity to a substring of "bps". See the "Test output" section for an explanation of this option. @@ -331,20 +375,43 @@ only run tests that match one or more of the glob patterns in do not run tests that match one or more of the glob patterns in <skipList> .TP -\fB-file <globPattern>\fR -only source test files that match <globPattern> (relative to the -"tests" directory). This option only applies when you run the test -suite with the "all.tcl" file. +\fB-file <globPatternList>\fR +only source test files that match any of the items in +<globPatternList> (relative to ::tcltest::testsDirectory). +.TP +\fB-notfile <globPatternList>\fR +source files except for those that match any of the items in +<globPatternList> (relative to ::tcltest::testsDirectory). +.TP +\fB-relateddir <globPattern>\fR +only run tests in the directories that match <globPattern> (relative to the +current directory). +.TP +\fB-asidefromdir <globPattern>\fR +use all specified directories except those that match <globPattern> (relative +to the current directory). .TP \fB-constraints <list>\fR tests with any constraints in <list> will not be skipped. Note that elements of <list> must exactly match the existing constraints. .TP +\fB-limitconstraints <bool>\fR +If the argument to this flag is 1, the test harness limits test runs +to those tests that match the constraints listed by the -constraints +flag. Use of this flag requires use of the -constraints flag. The +default value for this flag is 0 (false). +.TP \fB-tmpdir <directoryName>\fR put any temporary files (created with ::tcltest::makeFile and ::tcltest::makeDirectory) into the named directory. The default location is your current working directory. .TP +\fB-preservecore <bool>\fR +If the argument to this flag is 1 (true), the test harness saves any +core files produced at the end of a test run in +::tcltest::temporaryDirectory. The default value for this flag is 0 +(false). +.TP \fB-debug <debugLevel>\fR print out debug information. This is used to debug code in the test harness. The default debug level is 1. Levels are defined as: @@ -362,7 +429,6 @@ in the current namespace as they are used. Display information regarding what individual procs in the test harness are doing. .RE -.TP \fB-outfile <filename>\fR send normal output to the named file. This defaults to stdout. Note that debug output always goes to stdout, regardless of this flag's @@ -390,27 +456,22 @@ package. These variables (and their corresponding flags) are: ::tcltest::outputChannel .IP -errfile ::tcltest::errorChannel +.IP -preservecore +::tcltest::preserveCore .IP -debug ::tcltest::debug, ::tcltest::debugLevel .IP -tmpdir ::tcltest::temporaryDirectory .IP -constraints ::tcltest::testConstraints(\fIconstraintName\fR) +.IP -limitconstraints +::tcltest::limitConstraints .RE .PP See the \fI"Test Constraints"\fR for all available constraint names that can be used in the \fB::tcltest::testConstraints\fR array. -Other variables defined in the \fBtcltest\fR package that can be used -by tests include: -.RS -::tcltest::workingDirectory -.br -::tcltest::testsDirectory -.br -::tcltest::originalEnv -.br -::tcltest::mainThread -.RE +See \fI"Tcltest namespace variables"\fR for details on other variables +defined in the \fBtcltest\fR namespace. .PP A final way to run tests would be to specify which test files to run within an \fIall.tcl\fR (or otherwise named) file. This is the @@ -426,7 +487,8 @@ errors, then additional messages will appear in the format described below. Note that some tests will be skipped if you run as superuser. .SH "TEST OUTPUT" After all specified test files are run, the number of tests -passed, skipped, and failed is printed to stdout. Aside from this +passed, skipped, and failed is printed to +\fB::tcltest::outputChannel\fR. Aside from this statistical information, output can be controlled on a per-test basis by the \fB::tcltest::verbose\fR variable. .PP @@ -451,10 +513,8 @@ tclsh socket.test -verbose bps .SH "CONTENTS OF A TEST FILE" Test files should begin by loading the \fBtcltest\fR package: .DS -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} +package require tcltest +namespace import ::tcltest::* .DE Test files should end by cleaning up after themselves and calling \fB::tcltest::cleanupTests\fR. The \fB::tcltest::cleanupTests\fR @@ -517,24 +577,87 @@ tclsh all.tcl -constraints "knownBug nonPortable" See the \fI"Constraints"\fR package for information about using built-in constraints and adding new ones. .SH "HOW TO CUSTOMIZE THE TEST HARNESS" -\fB::tcltest::initConstraintsHook -\fB::tcltest::processCmdLineArgsAddFlagHook -\fB::tcltest::processCmdLineArgsHook \fIflagArray\fR -\fB::tcltest::cleanupTestsHook +To create your own custom test harness, create a .tcl file that contains your +namespace. Within this file, require package \fBtcltest\fR. To add new +constraints, define your own version of \fB::tcltest::initConstraintsHook\fR. +Within your proc, you can add to the \fB::tcltest::testConstraints\fR array. +For example: +.DS +proc ::tcltest::initConstraintsHook {} { + set ::tcltest::testConstraints(win95Or98) \\ + [expr {$::tcltest::testConstraints(95) || \\ + $::tcltest::testConstraints(98)}] +} +.DE +.PP +To add new flags to your customized test harness, redefine +\fB::tcltest::processCmdLineArgsAddFlagHook\fR to define additional flags to be +parsed and \fB::tcltest::processCmdLineArgsHook\fR to actually process them. +For example: +.DS +proc ::tcltest::processCmdLineArgsAddFlagHook {} { + return [list -flag1 -flag2] +} + +proc ::tcltest::processCmdLineArgsHook {flagArray} { + array set flag $flagArray + + if {[info exists flag(-flag1)]} { + # Handle flag1 + } + + if {[info exists flag(-flag2)]} { + # Handle flag2 + } + + return +} +.DE +.PP +Finally, if you want to add additional cleanup code to your harness +you can define your own \fB::tcltest::cleanupTestsHook\fR. For example: +.DS +proc ::tcltest::cleanupTestsHook {} { + # Add your cleanup code here +} +.DE .SH EXAMPLES .IP [1] -Test file (foo.test) +A simple test file (foo.test) .DS package require tcltest +import namespace ::tcltest::* +test foo-1.1 {save 1 in variable name foo} {} { + set foo 1 +} {1} +cleanupTests +return .DE .IP [2] -all.tcl +A simple all.tcl +.DS +package require tcltest +import namespace ::tcltest::* +set ::tcltest::testSingleFile 0 +set ::tcltest::testsDirectory [file dir [info script]] +foreach file [::tcltest::getMatchingTestFiles] { + if {[catch {source $file} msg]} { + puts stdout $msg + } +} +::tclttest::cleanupTests 1 +return +.DE .IP [3] Running a single test +.DS +tclsh foo.test +.DE .IP [4] Running multiple tests -.IP [5] -Running tests using all.tcl +.DS +tclsh all.tcl -file 'foo*.test' -notfile 'foo2.test' +.DE .SH "SEE ALSO" tktest(n) .SH KEYWORDS diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index f9e2d30..96b38cc 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -8,4 +8,11 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg ::tcltest::removeDirectory ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory tcltest:grep}}}] +package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 \ + {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests \ + ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile \ + ::tcltest::normalizeMsg ::tcltest::removeDirectory \ + ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState \ + ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory \ + ::tcltest:grep ::tcltest::getMatchingTestFiles }}}] + diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 3375718..d3d8a8b 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1,6 +1,6 @@ # tcltest.tcl -- # -# This file contains support code for the Tcl test suite. It defines the +# This file contains support code for the Tcl test suite. It # defines the ::tcltest namespace and finds and defines the output # directory, constraints available, output and error channels, etc. used # by Tcl tests. See the README file for more details. @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.1 1999/06/26 03:53:45 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.2 1999/06/29 20:14:15 jenn Exp $ package provide tcltest 1.0 @@ -27,7 +27,7 @@ namespace eval tcltest { set procList [list test cleanupTests dotests saveState restoreState \ normalizeMsg makeFile removeFile makeDirectory removeDirectory \ viewFile grep bytestring set_iso8859_1_locale restore_locale \ - safeFetch threadReap] + safeFetch threadReap getMatchingTestFiles] foreach proc $procList { namespace export $proc } @@ -36,13 +36,20 @@ namespace eval tcltest { variable verbose "b" - # match defaults to the empty list + # Match and skip patterns default to the empty list, except for + # matchFiles, which defaults to all .test files in the testsDirectory variable match {} + variable skip {} - # skip defaults to the empty list + variable matchFiles {*.test} + variable skipFiles {} - variable skip {} + variable matchDirectories {} + variable skipDirectories {} + + # By default, don't save core files + variable preserveCore false # output goes to stdout by default @@ -104,11 +111,14 @@ namespace eval tcltest { array set ::tcltest::skippedBecause {} # initialize the ::tcltest::testConstraints array to keep track of valid - # predefined constraints (see the explanation for the ::tcltest::initConstraints - # proc for more details). + # predefined constraints (see the explanation for the + # ::tcltest::initConstraints proc for more details). array set ::tcltest::testConstraints {} + # Don't run only the constrained tests by default + variable limitConstraints false + # tests that use thread need to know which is the main thread variable mainThread 1 @@ -120,9 +130,6 @@ namespace eval tcltest { array set ::tcltest::originalEnv [array get ::env] - # TclPro has other variables that need to be set, including the locations - # of various directories. - # Set ::tcltest::workingDirectory to [pwd]. The default output directory # for Tcl tests is the working directory. @@ -135,6 +142,8 @@ namespace eval tcltest { variable testsDirectory [pwd] + # the variables and procs that existed when ::tcltest::saveState was + # called are stored in a variable of the same name variable saveState {} # Internationalization support @@ -174,17 +183,19 @@ namespace eval tcltest { # Set the location of the execuatble variable tcltest [info nameofexecutable] - - # If there is no "memory" command (because memory debugging isn't - # enabled), generate a dummy command that does nothing. - - if {[info commands memory] == {}} { - namespace eval :: { - proc memory args {} - } - } } +# ::tcltest::AddToSkippedBecause -- +# +# Increments the variable used to track how many tests were skipped +# because of a particular constraint. +# +# Arguments: +# constraint The name of the constraint to be modified +# +# Results: +# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't +# previously exist - otherwise, it just increments it. proc ::tcltest::AddToSkippedBecause { constraint } { # add the constraint to the list of constraints the kept tests @@ -250,10 +261,10 @@ proc ::tcltest::initConstraints {} { catch {unset ::tcltest::testConstraints} # 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. + # 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. trace variable ::tcltest::testConstraints r ::tcltest::safeFetch @@ -283,9 +294,14 @@ proc ::tcltest::initConstraints {} { set ::tcltest::testConstraints(macOrUnix) \ [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(unix)}] - set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) "Windows NT"] - set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) "Windows 95"] - set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) "Win32s"] + set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \ + "Windows NT"] + set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \ + "Windows 95"] + set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \ + "Windows 98"] + set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) \ + "Win32s"] # The following Constraints switches are used to mark tests that should work, # but have been temporarily disabled on certain platforms because they don't @@ -467,7 +483,8 @@ proc ::tcltest::initConstraints {} { catch {file delete -force tmp} # Deliberately call socket with the wrong number of arguments. The error - # message you get will indicate whether sockets are available on this system. + # message you get will indicate whether sockets are available on this + # system. catch {socket} msg set ::tcltest::testConstraints(socket) \ @@ -485,8 +502,87 @@ proc ::tcltest::initConstraints {} { } } +# ::tcltest::PrintUsageInfoHook +# +# Hook used for customization of display of usage information. +# + +proc ::tcltest::PrintUsageInfoHook {} {} + +# ::tcltest::PrintUsageInfo +# +# Prints out the usage information for package tcltest. This can be +# customized with the redefinition of ::tcltest::PrintUsageInfoHook. +# +# Arguments: +# none +# + +proc ::tcltest::PrintUsageInfo {} { + puts [format "Usage: [file tail [info nameofexecutable]] \ + script ?-help? ?flag value? ... \n\ + Available flags (and valid input values) are: \n\ + -help \t Display this usage information. \n\ + -verbose level \t Takes any combination of the values \n\ + \t 'p', 's' and 'b'. Test suite will \n\ + \t display all passed tests if 'p' is \n\ + \t specified, all skipped tests if 's' \n\ + \t is specified, and the bodies of \n\ + \t failed tests if 'b' is specified. \n\ + \t The default value is 'b'. \n\ + -constraints list\t Do not skip the listed constraints\n\ + -limitconstraints bool\t Only run tests with the constraints\n\ + \t listed in -constraints.\n\ + -match pattern \t Run all tests within the specified \n\ + \t files that match the glob pattern \n\ + \t given. \n\ + -skip pattern \t Skip all tests within the set of \n\ + \t specified tests (via -match) and \n\ + \t files that match the glob pattern \n\ + \t given. \n\ + -file pattern \t Run tests in all test files that \n\ + \t match the glob pattern given. \n\ + -notfile pattern\t Skip all test files that match the \n\ + \t glob pattern given. \n\ + -relateddir pattern\t Run tests in directories that match \n\ + \t the glob pattern given. \n\ + -asidefromdir pattern\t Skip tests in directories that match \n\ + \t the glob pattern given. \n\ + -preservecore bool \t If true, save any core files produced \n\ + \t during testing in the directory \n\ + \t specified by -tmpdir. The default \n\ + \t is $::tcltest::preserveCore. \n\ + -tmpdir directory\t Save temporary files in the specified\n\ + \t directory. The default value is \n\ + \t $::tcltest::temporaryDirectory. \n\ + -outfile file \t Send output from test runs to the \n\ + \t specified file. The default is \n\ + \t stdout. \n\ + -errfile file \t Send errors from test runs to the \n\ + \t specified file. The default is \n\ + \t stderr. \n\ + -debug level \t Internal debug flag."] + ::tcltest::PrintUsageInfoHook + return +} + +# ::tcltest::processCmdLineArgsFlagsHook -- +# +# This hook is used to add to the list of command line arguments that are +# processed by ::tcltest::processCmdLineArgs. +# + proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} +# ::tcltest::processCmdLineArgsHook -- +# +# This hook is used to actually process the flags added by +# ::tcltest::processCmdLineArgsAddFlagsHook. +# +# Arguments: +# flags The flags that have been pulled out of argv +# + proc ::tcltest::processCmdLineArgsHook {flag} {} # ::tcltest::processCmdLineArgs -- @@ -509,7 +605,7 @@ proc ::tcltest::processCmdLineArgs {} { # The "argv" var doesn't exist in some cases, so use {}. - if {(![info exists argv]) || ([llength $argv] < 2)} { + if {(![info exists argv]) || ([llength $argv] < 1)} { set flagArray {} } else { set flagArray $argv @@ -519,14 +615,24 @@ proc ::tcltest::processCmdLineArgs {} { # Note that -verbose cannot be abbreviated to -v in wish because it # conflicts with the wish option -visual. + # Process -help first + if {([lsearch -exact $flagArray {-help}] != -1) || \ + ([lsearch -exact $flagArray {-h}] != -1)} { + ::tcltest::PrintUsageInfo + exit + } + if {[catch {array set flag $flagArray}]} { ::tcltest::PrintError "odd number of arguments specified on command line: \ $argv" + ::tcltest::PrintUsageInfo exit } - + + # -help is not listed since it has already been processed lappend defaultFlags {-verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir} + -outfile -errfile -debug -tmpdir -file -notfile -relateddir \ + -asidefromdir -preservecore -limitconstraints} lappend defaultFlags [ ::tcltest::processCmdLineArgsAddFlagsHook ] foreach arg $defaultFlags { @@ -556,6 +662,22 @@ proc ::tcltest::processCmdLineArgs {} { set ::tcltest::skip $flag(-skip) } + # Handle the -file and -notfile flags + if {[info exists flag(-file)]} { + set ::tcltest::matchFiles $flag(-file) + } + if {[info exists flag(-notfile)]} { + set ::tcltest::skipFiles $flag(-notfile) + } + + # Handle -relateddir and -asidefromdir flags + if {[info exists flag(-relateddir)]} { + set ::tcltest::matchDirectories $flag(-relateddir) + } + if {[info exists flag(-asidefromdir)]} { + set ::tcltest::skipDirectories $flag(-asidefromdir) + } + # Use the -constraints flag, if given, to turn on constraints that are # turned off by default: userInteractive knownBug nonPortable. This # code fragment must be run after constraints are initialized. @@ -566,6 +688,23 @@ proc ::tcltest::processCmdLineArgs {} { } } + # Use the -limitconstraints flag, if given, to tell the harness to limit + # tests run to those that were specified using the -constraints flag. If + # the -constraints flag was not specified, print out an error and exit. + if {[info exists flag(-limitconstraints)]} { + if {![info exists flag(-constraints)]} { + puts "You can only use the -limitconstraints flag with \ + -constraints" + exit + } + set ::tcltest::limitConstraints $flag(-limitconstraints) + foreach elt [array names ::tcltest::testConstraints] { + if {[lsearch -exact $flag(-constraints) $elt] == -1} { + set ::tcltest::testConstraints($elt) 0 + } + } + } + # If an alternate error or output files are specified, change the # default channels. @@ -640,6 +779,35 @@ proc ::tcltest::processCmdLineArgs {} { lappend ::tcltest::filesExisted [file tail $file] } + # Handle -preservecore + if {[info exists flag(-preservecore)]} { + set ::tcltest::preserveCore $flag(-preserveCore) + } + + # Find the matching directories and then remove the ones that are + # specified in the skip pattern; if no match pattern is specified, use + # the default value specified for ::tcltest::testsDirectory - ignore the + # value of ::tcltest::skipDirectories if the default value is being used. + if {$::tcltest::matchDirectories != {}} { + set matchDir {} + set skipDir {} + if {$::tcltest::skipDirectories != {}} { + set skipDir [glob -nocomplain $::tcltest::skipDirectories] + } + foreach dir [glob -nocomplain $::tcltest::matchDirectories] { + if {[lsearch -exact $skipDir $dir] == -1} { + lappend matchDir $dir + } + } + + # Only reset ::tcltest::testsDirectory if anything actually matched + # after removing the skip patterns. + if {[llength $matchDir] > 0} { + set ::tcltest::testsDirectory $matchDir + } + } + + # Call the hook ::tcltest::processCmdLineArgsHook [array get flag] # Spit out everything you know if ::tcltest::debug is set. @@ -655,6 +823,8 @@ proc ::tcltest::processCmdLineArgs {} { puts "::tcltest::errorChannel = $::tcltest::errorChannel" puts "Original environment (::tcltest::originalEnv):" parray ::tcltest::originalEnv + puts "Constraints:" + parray ::tcltest::testConstraints } } @@ -764,63 +934,70 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { set ::tcltest::numTests($index) 0 } + # exit only if running Tk in non-interactive mode + + global tk_version tcl_interactive + if {[info exists tk_version] && !$tcl_interactive} { + exit + } + } else { + + # if we're deferring stat-reporting until all files are sourced, + # then add current file to failFile list if any tests in this file + # failed + + incr ::tcltest::numTestFiles + if {($::tcltest::currentFailure) && \ + ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} { + lappend ::tcltest::failFiles $testFileName + } + set ::tcltest::currentFailure false + # restore the environment to the state it was in before this package # was loaded set newEnv {} set changedEnv {} set removedEnv {} - foreach index [array names env] { + foreach index [array names ::env] { if {![info exists ::tcltest::originalEnv($index)]} { lappend newEnv $index - unset env($index) + unset ::env($index) } else { - if {$env($index) != $::tcltest::originalEnv($index)} { + if {$::env($index) != $::tcltest::originalEnv($index)} { lappend changedEnv $index - set env($index) $::tcltest::originalEnv($index) + set ::env($index) $::tcltest::originalEnv($index) } } } foreach index [array names ::tcltest::originalEnv] { if {![info exists ::env($index)]} { lappend removedEnv $index - set env($index) $::tcltest::originalEnv($index) + set ::env($index) $::tcltest::originalEnv($index) } } if {[llength $newEnv] > 0} { puts $::tcltest::outputChannel \ - "\t\tenv array elements created:\t$newEnv" + "env array elements created:\t$newEnv" } if {[llength $changedEnv] > 0} { puts $::tcltest::outputChannel \ - "\t\tenv array elements changed:\t$changedEnv" + "env array elements changed:\t$changedEnv" } if {[llength $removedEnv] > 0} { puts $::tcltest::outputChannel \ - "\t\tenv array elements removed:\t$removedEnv" - } - - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && !$tcl_interactive} { - exit + "env array elements removed:\t$removedEnv" } - } else { - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed - - incr ::tcltest::numTestFiles - if {($::tcltest::currentFailure) && \ - ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} { - lappend ::tcltest::failFiles $testFileName - } - set ::tcltest::currentFailure false } } +# ::tcltest::cleanupTestsHook -- +# +# This hook allows a harness that builds upon tcltest to specify +# additional things that should be done at cleanup. +# + proc ::tcltest::cleanupTestsHook {} {} # test -- @@ -882,6 +1059,13 @@ proc ::tcltest::test {name description script expectedAnswer args} { set i [llength $args] if {$i == 0} { set constraints {} + # If we're limited to the listed constraints and there aren't any + # listed, then we shouldn't run the test. + if {$::tcltest::limitConstraints} { + ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint + incr ::tcltest::numTests(Skipped) + return + } } elseif {$i == 1} { # "constraints" argument exists; shuffle arguments down, then @@ -892,49 +1076,50 @@ proc ::tcltest::test {name description script expectedAnswer args} { set expectedAnswer [lindex $args 0] set doTest 0 if {[string match {*[$\[]*} $constraints] != 0} { - # full expression, e.g. {$foo > [info tclversion]} - catch {set doTest [uplevel #0 expr $constraints]} } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { - # something like {a || b} should be turned into # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.a-zA-Z0-9]+} $constraints \ {$::tcltest::testConstraints(&)} c catch {set doTest [eval expr $c]} } else { - # just simple constraints such as {unixOnly fonts}. set doTest 1 foreach constraint $constraints { - if {![info exists ::tcltest::testConstraints($constraint)] - || !$::tcltest::testConstraints($constraint)} { + if {(![info exists ::tcltest::testConstraints($constraint)]) \ + || (!$::tcltest::testConstraints($constraint))} { set doTest 0 # store the constraint that kept the test from running - set constraints $constraint break } } } if {$doTest == 0} { - incr ::tcltest::numTests(Skipped) if {[string first s $::tcltest::verbose] != -1} { puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints" } + incr ::tcltest::numTests(Skipped) ::tcltest::AddToSkippedBecause $constraints return } } else { error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" } - memory tag $name + + # If there is no "memory" command (because memory debugging isn't + # enabled), then don't attempt to use the command. + + if {[info commands memory] != {}} { + memory tag $name + } + set code [catch {uplevel $script} actualAnswer] if {([string compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} { incr ::tcltest::numTests(Passed) @@ -973,6 +1158,65 @@ proc ::tcltest::test {name description script expectedAnswer args} { puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer" puts $::tcltest::outputChannel "==== $name FAILED\n" } + if {[file exists [file join $::tcltest::workingDirectory core]]} { + if {$::tcltest::preserveCore} { + file rename -force [file join $::tcltest::workingDirectory core] \ + [file join $::tcltest::temporaryDirectory core-$name] + + puts $::tcltest::outputChannel "==== $name produced core file! \ + Moved file to: \ + [file join $::tcltest::temporaryDirectory core-$name]" + } else { + puts $::tcltest::outputChannel "==== $name produced core file!" + } + } +} + +# ::tcltest::getMatchingTestFiles +# +# Looks at the patterns given to match and skip directories and files +# and uses them to put together a list of the tests that will be run. +# +# Arguments: +# none +# +# Results: +# The constructed list is returned to the user. This will primarily +# be used in 'all.tcl' files. + +proc ::tcltest::getMatchingFiles {} { + set matchingFiles {} + # Find the matching files in the list of directories and then remove the + # ones that match the skip pattern + foreach directory $::tcltest::testsDirectory { + set matchFileList {} + foreach match $::tcltest::matchFiles { + set matchFileList [concat $matchFileList \ + [glob -nocomplain [file join $directory $match]]] + } + if {$tcltest::skipFiles != {}} { + set skipFileList {} + foreach skip $::tcltest::skipFiles { + set skipFileList [concat $skipFileList \ + [glob -nocomplain [file join $directory $skip]]] + } + foreach file $matchFileList { + # Only include files that don't match the skip pattern and + # aren't SCCS lock files. + if {([lsearch -exact $skipFileList $file] == -1) && \ + (![string match l.*.test [file tail $file]])} { + lappend matchingFiles $file + } + } + } else { + set matchingFiles [concat $matchingFiles $matchFileList] + } + } + if {$matchingFiles == {}} { + ::tcltest::PrintError "No test files remain after applying \ + your match and skip patterns!" + } + return $matchingFiles } # ::tcltest::dotests -- @@ -997,6 +1241,9 @@ proc ::tcltest::dotests {file args} { set ::tcltest::match $savedTests } + +# The following two procs are used in the io tests. + proc ::tcltest::openfiles {} { if {[catch {testchannel open} result]} { return {} @@ -1017,6 +1264,16 @@ proc ::tcltest::leakfiles {old} { return $leak } +# ::tcltest::saveState -- +# +# Save information regarding what procs and variables exist. +# +# Arguments: +# none +# +# Results: +# Modifies the variable ::tcltest::saveState + proc ::tcltest::saveState {} { uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} { @@ -1024,6 +1281,18 @@ proc ::tcltest::saveState {} { } } +# ::tcltest::restoreState -- +# +# Remove procs and variables that didn't exist before the call to +# ::tcltest::saveState. +# +# Arguments: +# none +# +# Results: +# Removes procs and variables from your environment if they don't exist +# in the ::tcltest::saveState variable. + proc ::tcltest::restoreState {} { foreach p [info procs] { if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \ @@ -1044,6 +1313,14 @@ proc ::tcltest::restoreState {} { } } +# ::tcltest::normalizeMsg -- +# +# Removes "extra" newlines from a string. +# +# Arguments: +# msg String to be modified +# + proc ::tcltest::normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg regsub -all "\n\n" $msg "\n" msg @@ -1088,6 +1365,14 @@ proc ::tcltest::makeFile {contents name} { } } +# ::tcltest::removeFile -- +# +# Removes the named file from the filesystem +# +# Arguments: +# name file to be removed +# + proc ::tcltest::removeFile {name} { if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { puts "::tcltest::removeFile: removing $name" @@ -1112,6 +1397,14 @@ proc ::tcltest::makeDirectory {name} { } } +# ::tcltest::removeDirectory -- +# +# Removes a named directory from the file system. +# +# Arguments: +# name Name of the directory to remove +# + proc ::tcltest::removeDirectory {name} { file delete -force $name } diff --git a/library/tcltest1.0/pkgIndex.tcl b/library/tcltest1.0/pkgIndex.tcl index f9e2d30..96b38cc 100644 --- a/library/tcltest1.0/pkgIndex.tcl +++ b/library/tcltest1.0/pkgIndex.tcl @@ -8,4 +8,11 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg ::tcltest::removeDirectory ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory tcltest:grep}}}] +package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 \ + {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests \ + ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile \ + ::tcltest::normalizeMsg ::tcltest::removeDirectory \ + ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState \ + ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory \ + ::tcltest:grep ::tcltest::getMatchingTestFiles }}}] + diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl index 3375718..d3d8a8b 100644 --- a/library/tcltest1.0/tcltest.tcl +++ b/library/tcltest1.0/tcltest.tcl @@ -1,6 +1,6 @@ # tcltest.tcl -- # -# This file contains support code for the Tcl test suite. It defines the +# This file contains support code for the Tcl test suite. It # defines the ::tcltest namespace and finds and defines the output # directory, constraints available, output and error channels, etc. used # by Tcl tests. See the README file for more details. @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.1 1999/06/26 03:53:45 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.2 1999/06/29 20:14:15 jenn Exp $ package provide tcltest 1.0 @@ -27,7 +27,7 @@ namespace eval tcltest { set procList [list test cleanupTests dotests saveState restoreState \ normalizeMsg makeFile removeFile makeDirectory removeDirectory \ viewFile grep bytestring set_iso8859_1_locale restore_locale \ - safeFetch threadReap] + safeFetch threadReap getMatchingTestFiles] foreach proc $procList { namespace export $proc } @@ -36,13 +36,20 @@ namespace eval tcltest { variable verbose "b" - # match defaults to the empty list + # Match and skip patterns default to the empty list, except for + # matchFiles, which defaults to all .test files in the testsDirectory variable match {} + variable skip {} - # skip defaults to the empty list + variable matchFiles {*.test} + variable skipFiles {} - variable skip {} + variable matchDirectories {} + variable skipDirectories {} + + # By default, don't save core files + variable preserveCore false # output goes to stdout by default @@ -104,11 +111,14 @@ namespace eval tcltest { array set ::tcltest::skippedBecause {} # initialize the ::tcltest::testConstraints array to keep track of valid - # predefined constraints (see the explanation for the ::tcltest::initConstraints - # proc for more details). + # predefined constraints (see the explanation for the + # ::tcltest::initConstraints proc for more details). array set ::tcltest::testConstraints {} + # Don't run only the constrained tests by default + variable limitConstraints false + # tests that use thread need to know which is the main thread variable mainThread 1 @@ -120,9 +130,6 @@ namespace eval tcltest { array set ::tcltest::originalEnv [array get ::env] - # TclPro has other variables that need to be set, including the locations - # of various directories. - # Set ::tcltest::workingDirectory to [pwd]. The default output directory # for Tcl tests is the working directory. @@ -135,6 +142,8 @@ namespace eval tcltest { variable testsDirectory [pwd] + # the variables and procs that existed when ::tcltest::saveState was + # called are stored in a variable of the same name variable saveState {} # Internationalization support @@ -174,17 +183,19 @@ namespace eval tcltest { # Set the location of the execuatble variable tcltest [info nameofexecutable] - - # If there is no "memory" command (because memory debugging isn't - # enabled), generate a dummy command that does nothing. - - if {[info commands memory] == {}} { - namespace eval :: { - proc memory args {} - } - } } +# ::tcltest::AddToSkippedBecause -- +# +# Increments the variable used to track how many tests were skipped +# because of a particular constraint. +# +# Arguments: +# constraint The name of the constraint to be modified +# +# Results: +# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't +# previously exist - otherwise, it just increments it. proc ::tcltest::AddToSkippedBecause { constraint } { # add the constraint to the list of constraints the kept tests @@ -250,10 +261,10 @@ proc ::tcltest::initConstraints {} { catch {unset ::tcltest::testConstraints} # 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. + # 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. trace variable ::tcltest::testConstraints r ::tcltest::safeFetch @@ -283,9 +294,14 @@ proc ::tcltest::initConstraints {} { set ::tcltest::testConstraints(macOrUnix) \ [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(unix)}] - set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) "Windows NT"] - set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) "Windows 95"] - set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) "Win32s"] + set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \ + "Windows NT"] + set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \ + "Windows 95"] + set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \ + "Windows 98"] + set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) \ + "Win32s"] # The following Constraints switches are used to mark tests that should work, # but have been temporarily disabled on certain platforms because they don't @@ -467,7 +483,8 @@ proc ::tcltest::initConstraints {} { catch {file delete -force tmp} # Deliberately call socket with the wrong number of arguments. The error - # message you get will indicate whether sockets are available on this system. + # message you get will indicate whether sockets are available on this + # system. catch {socket} msg set ::tcltest::testConstraints(socket) \ @@ -485,8 +502,87 @@ proc ::tcltest::initConstraints {} { } } +# ::tcltest::PrintUsageInfoHook +# +# Hook used for customization of display of usage information. +# + +proc ::tcltest::PrintUsageInfoHook {} {} + +# ::tcltest::PrintUsageInfo +# +# Prints out the usage information for package tcltest. This can be +# customized with the redefinition of ::tcltest::PrintUsageInfoHook. +# +# Arguments: +# none +# + +proc ::tcltest::PrintUsageInfo {} { + puts [format "Usage: [file tail [info nameofexecutable]] \ + script ?-help? ?flag value? ... \n\ + Available flags (and valid input values) are: \n\ + -help \t Display this usage information. \n\ + -verbose level \t Takes any combination of the values \n\ + \t 'p', 's' and 'b'. Test suite will \n\ + \t display all passed tests if 'p' is \n\ + \t specified, all skipped tests if 's' \n\ + \t is specified, and the bodies of \n\ + \t failed tests if 'b' is specified. \n\ + \t The default value is 'b'. \n\ + -constraints list\t Do not skip the listed constraints\n\ + -limitconstraints bool\t Only run tests with the constraints\n\ + \t listed in -constraints.\n\ + -match pattern \t Run all tests within the specified \n\ + \t files that match the glob pattern \n\ + \t given. \n\ + -skip pattern \t Skip all tests within the set of \n\ + \t specified tests (via -match) and \n\ + \t files that match the glob pattern \n\ + \t given. \n\ + -file pattern \t Run tests in all test files that \n\ + \t match the glob pattern given. \n\ + -notfile pattern\t Skip all test files that match the \n\ + \t glob pattern given. \n\ + -relateddir pattern\t Run tests in directories that match \n\ + \t the glob pattern given. \n\ + -asidefromdir pattern\t Skip tests in directories that match \n\ + \t the glob pattern given. \n\ + -preservecore bool \t If true, save any core files produced \n\ + \t during testing in the directory \n\ + \t specified by -tmpdir. The default \n\ + \t is $::tcltest::preserveCore. \n\ + -tmpdir directory\t Save temporary files in the specified\n\ + \t directory. The default value is \n\ + \t $::tcltest::temporaryDirectory. \n\ + -outfile file \t Send output from test runs to the \n\ + \t specified file. The default is \n\ + \t stdout. \n\ + -errfile file \t Send errors from test runs to the \n\ + \t specified file. The default is \n\ + \t stderr. \n\ + -debug level \t Internal debug flag."] + ::tcltest::PrintUsageInfoHook + return +} + +# ::tcltest::processCmdLineArgsFlagsHook -- +# +# This hook is used to add to the list of command line arguments that are +# processed by ::tcltest::processCmdLineArgs. +# + proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} +# ::tcltest::processCmdLineArgsHook -- +# +# This hook is used to actually process the flags added by +# ::tcltest::processCmdLineArgsAddFlagsHook. +# +# Arguments: +# flags The flags that have been pulled out of argv +# + proc ::tcltest::processCmdLineArgsHook {flag} {} # ::tcltest::processCmdLineArgs -- @@ -509,7 +605,7 @@ proc ::tcltest::processCmdLineArgs {} { # The "argv" var doesn't exist in some cases, so use {}. - if {(![info exists argv]) || ([llength $argv] < 2)} { + if {(![info exists argv]) || ([llength $argv] < 1)} { set flagArray {} } else { set flagArray $argv @@ -519,14 +615,24 @@ proc ::tcltest::processCmdLineArgs {} { # Note that -verbose cannot be abbreviated to -v in wish because it # conflicts with the wish option -visual. + # Process -help first + if {([lsearch -exact $flagArray {-help}] != -1) || \ + ([lsearch -exact $flagArray {-h}] != -1)} { + ::tcltest::PrintUsageInfo + exit + } + if {[catch {array set flag $flagArray}]} { ::tcltest::PrintError "odd number of arguments specified on command line: \ $argv" + ::tcltest::PrintUsageInfo exit } - + + # -help is not listed since it has already been processed lappend defaultFlags {-verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir} + -outfile -errfile -debug -tmpdir -file -notfile -relateddir \ + -asidefromdir -preservecore -limitconstraints} lappend defaultFlags [ ::tcltest::processCmdLineArgsAddFlagsHook ] foreach arg $defaultFlags { @@ -556,6 +662,22 @@ proc ::tcltest::processCmdLineArgs {} { set ::tcltest::skip $flag(-skip) } + # Handle the -file and -notfile flags + if {[info exists flag(-file)]} { + set ::tcltest::matchFiles $flag(-file) + } + if {[info exists flag(-notfile)]} { + set ::tcltest::skipFiles $flag(-notfile) + } + + # Handle -relateddir and -asidefromdir flags + if {[info exists flag(-relateddir)]} { + set ::tcltest::matchDirectories $flag(-relateddir) + } + if {[info exists flag(-asidefromdir)]} { + set ::tcltest::skipDirectories $flag(-asidefromdir) + } + # Use the -constraints flag, if given, to turn on constraints that are # turned off by default: userInteractive knownBug nonPortable. This # code fragment must be run after constraints are initialized. @@ -566,6 +688,23 @@ proc ::tcltest::processCmdLineArgs {} { } } + # Use the -limitconstraints flag, if given, to tell the harness to limit + # tests run to those that were specified using the -constraints flag. If + # the -constraints flag was not specified, print out an error and exit. + if {[info exists flag(-limitconstraints)]} { + if {![info exists flag(-constraints)]} { + puts "You can only use the -limitconstraints flag with \ + -constraints" + exit + } + set ::tcltest::limitConstraints $flag(-limitconstraints) + foreach elt [array names ::tcltest::testConstraints] { + if {[lsearch -exact $flag(-constraints) $elt] == -1} { + set ::tcltest::testConstraints($elt) 0 + } + } + } + # If an alternate error or output files are specified, change the # default channels. @@ -640,6 +779,35 @@ proc ::tcltest::processCmdLineArgs {} { lappend ::tcltest::filesExisted [file tail $file] } + # Handle -preservecore + if {[info exists flag(-preservecore)]} { + set ::tcltest::preserveCore $flag(-preserveCore) + } + + # Find the matching directories and then remove the ones that are + # specified in the skip pattern; if no match pattern is specified, use + # the default value specified for ::tcltest::testsDirectory - ignore the + # value of ::tcltest::skipDirectories if the default value is being used. + if {$::tcltest::matchDirectories != {}} { + set matchDir {} + set skipDir {} + if {$::tcltest::skipDirectories != {}} { + set skipDir [glob -nocomplain $::tcltest::skipDirectories] + } + foreach dir [glob -nocomplain $::tcltest::matchDirectories] { + if {[lsearch -exact $skipDir $dir] == -1} { + lappend matchDir $dir + } + } + + # Only reset ::tcltest::testsDirectory if anything actually matched + # after removing the skip patterns. + if {[llength $matchDir] > 0} { + set ::tcltest::testsDirectory $matchDir + } + } + + # Call the hook ::tcltest::processCmdLineArgsHook [array get flag] # Spit out everything you know if ::tcltest::debug is set. @@ -655,6 +823,8 @@ proc ::tcltest::processCmdLineArgs {} { puts "::tcltest::errorChannel = $::tcltest::errorChannel" puts "Original environment (::tcltest::originalEnv):" parray ::tcltest::originalEnv + puts "Constraints:" + parray ::tcltest::testConstraints } } @@ -764,63 +934,70 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { set ::tcltest::numTests($index) 0 } + # exit only if running Tk in non-interactive mode + + global tk_version tcl_interactive + if {[info exists tk_version] && !$tcl_interactive} { + exit + } + } else { + + # if we're deferring stat-reporting until all files are sourced, + # then add current file to failFile list if any tests in this file + # failed + + incr ::tcltest::numTestFiles + if {($::tcltest::currentFailure) && \ + ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} { + lappend ::tcltest::failFiles $testFileName + } + set ::tcltest::currentFailure false + # restore the environment to the state it was in before this package # was loaded set newEnv {} set changedEnv {} set removedEnv {} - foreach index [array names env] { + foreach index [array names ::env] { if {![info exists ::tcltest::originalEnv($index)]} { lappend newEnv $index - unset env($index) + unset ::env($index) } else { - if {$env($index) != $::tcltest::originalEnv($index)} { + if {$::env($index) != $::tcltest::originalEnv($index)} { lappend changedEnv $index - set env($index) $::tcltest::originalEnv($index) + set ::env($index) $::tcltest::originalEnv($index) } } } foreach index [array names ::tcltest::originalEnv] { if {![info exists ::env($index)]} { lappend removedEnv $index - set env($index) $::tcltest::originalEnv($index) + set ::env($index) $::tcltest::originalEnv($index) } } if {[llength $newEnv] > 0} { puts $::tcltest::outputChannel \ - "\t\tenv array elements created:\t$newEnv" + "env array elements created:\t$newEnv" } if {[llength $changedEnv] > 0} { puts $::tcltest::outputChannel \ - "\t\tenv array elements changed:\t$changedEnv" + "env array elements changed:\t$changedEnv" } if {[llength $removedEnv] > 0} { puts $::tcltest::outputChannel \ - "\t\tenv array elements removed:\t$removedEnv" - } - - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && !$tcl_interactive} { - exit + "env array elements removed:\t$removedEnv" } - } else { - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed - - incr ::tcltest::numTestFiles - if {($::tcltest::currentFailure) && \ - ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} { - lappend ::tcltest::failFiles $testFileName - } - set ::tcltest::currentFailure false } } +# ::tcltest::cleanupTestsHook -- +# +# This hook allows a harness that builds upon tcltest to specify +# additional things that should be done at cleanup. +# + proc ::tcltest::cleanupTestsHook {} {} # test -- @@ -882,6 +1059,13 @@ proc ::tcltest::test {name description script expectedAnswer args} { set i [llength $args] if {$i == 0} { set constraints {} + # If we're limited to the listed constraints and there aren't any + # listed, then we shouldn't run the test. + if {$::tcltest::limitConstraints} { + ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint + incr ::tcltest::numTests(Skipped) + return + } } elseif {$i == 1} { # "constraints" argument exists; shuffle arguments down, then @@ -892,49 +1076,50 @@ proc ::tcltest::test {name description script expectedAnswer args} { set expectedAnswer [lindex $args 0] set doTest 0 if {[string match {*[$\[]*} $constraints] != 0} { - # full expression, e.g. {$foo > [info tclversion]} - catch {set doTest [uplevel #0 expr $constraints]} } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { - # something like {a || b} should be turned into # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.a-zA-Z0-9]+} $constraints \ {$::tcltest::testConstraints(&)} c catch {set doTest [eval expr $c]} } else { - # just simple constraints such as {unixOnly fonts}. set doTest 1 foreach constraint $constraints { - if {![info exists ::tcltest::testConstraints($constraint)] - || !$::tcltest::testConstraints($constraint)} { + if {(![info exists ::tcltest::testConstraints($constraint)]) \ + || (!$::tcltest::testConstraints($constraint))} { set doTest 0 # store the constraint that kept the test from running - set constraints $constraint break } } } if {$doTest == 0} { - incr ::tcltest::numTests(Skipped) if {[string first s $::tcltest::verbose] != -1} { puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints" } + incr ::tcltest::numTests(Skipped) ::tcltest::AddToSkippedBecause $constraints return } } else { error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" } - memory tag $name + + # If there is no "memory" command (because memory debugging isn't + # enabled), then don't attempt to use the command. + + if {[info commands memory] != {}} { + memory tag $name + } + set code [catch {uplevel $script} actualAnswer] if {([string compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} { incr ::tcltest::numTests(Passed) @@ -973,6 +1158,65 @@ proc ::tcltest::test {name description script expectedAnswer args} { puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer" puts $::tcltest::outputChannel "==== $name FAILED\n" } + if {[file exists [file join $::tcltest::workingDirectory core]]} { + if {$::tcltest::preserveCore} { + file rename -force [file join $::tcltest::workingDirectory core] \ + [file join $::tcltest::temporaryDirectory core-$name] + + puts $::tcltest::outputChannel "==== $name produced core file! \ + Moved file to: \ + [file join $::tcltest::temporaryDirectory core-$name]" + } else { + puts $::tcltest::outputChannel "==== $name produced core file!" + } + } +} + +# ::tcltest::getMatchingTestFiles +# +# Looks at the patterns given to match and skip directories and files +# and uses them to put together a list of the tests that will be run. +# +# Arguments: +# none +# +# Results: +# The constructed list is returned to the user. This will primarily +# be used in 'all.tcl' files. + +proc ::tcltest::getMatchingFiles {} { + set matchingFiles {} + # Find the matching files in the list of directories and then remove the + # ones that match the skip pattern + foreach directory $::tcltest::testsDirectory { + set matchFileList {} + foreach match $::tcltest::matchFiles { + set matchFileList [concat $matchFileList \ + [glob -nocomplain [file join $directory $match]]] + } + if {$tcltest::skipFiles != {}} { + set skipFileList {} + foreach skip $::tcltest::skipFiles { + set skipFileList [concat $skipFileList \ + [glob -nocomplain [file join $directory $skip]]] + } + foreach file $matchFileList { + # Only include files that don't match the skip pattern and + # aren't SCCS lock files. + if {([lsearch -exact $skipFileList $file] == -1) && \ + (![string match l.*.test [file tail $file]])} { + lappend matchingFiles $file + } + } + } else { + set matchingFiles [concat $matchingFiles $matchFileList] + } + } + if {$matchingFiles == {}} { + ::tcltest::PrintError "No test files remain after applying \ + your match and skip patterns!" + } + return $matchingFiles } # ::tcltest::dotests -- @@ -997,6 +1241,9 @@ proc ::tcltest::dotests {file args} { set ::tcltest::match $savedTests } + +# The following two procs are used in the io tests. + proc ::tcltest::openfiles {} { if {[catch {testchannel open} result]} { return {} @@ -1017,6 +1264,16 @@ proc ::tcltest::leakfiles {old} { return $leak } +# ::tcltest::saveState -- +# +# Save information regarding what procs and variables exist. +# +# Arguments: +# none +# +# Results: +# Modifies the variable ::tcltest::saveState + proc ::tcltest::saveState {} { uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} { @@ -1024,6 +1281,18 @@ proc ::tcltest::saveState {} { } } +# ::tcltest::restoreState -- +# +# Remove procs and variables that didn't exist before the call to +# ::tcltest::saveState. +# +# Arguments: +# none +# +# Results: +# Removes procs and variables from your environment if they don't exist +# in the ::tcltest::saveState variable. + proc ::tcltest::restoreState {} { foreach p [info procs] { if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \ @@ -1044,6 +1313,14 @@ proc ::tcltest::restoreState {} { } } +# ::tcltest::normalizeMsg -- +# +# Removes "extra" newlines from a string. +# +# Arguments: +# msg String to be modified +# + proc ::tcltest::normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg regsub -all "\n\n" $msg "\n" msg @@ -1088,6 +1365,14 @@ proc ::tcltest::makeFile {contents name} { } } +# ::tcltest::removeFile -- +# +# Removes the named file from the filesystem +# +# Arguments: +# name file to be removed +# + proc ::tcltest::removeFile {name} { if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { puts "::tcltest::removeFile: removing $name" @@ -1112,6 +1397,14 @@ proc ::tcltest::makeDirectory {name} { } } +# ::tcltest::removeDirectory -- +# +# Removes a named directory from the file system. +# +# Arguments: +# name Name of the directory to remove +# + proc ::tcltest::removeDirectory {name} { file delete -force $name } diff --git a/tests/all.tcl b/tests/all.tcl index f158c93..b4d132d 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -7,18 +7,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: all.tcl,v 1.6 1999/06/26 21:09:15 rjohnson Exp $ +# RCS: @(#) $Id: all.tcl,v 1.7 1999/06/29 20:14:17 jenn Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import ::tcltest::* } -info commands + set ::tcltest::testSingleFile false set ::tcltest::testsDirectory [file dir [info script]] puts stdout "Tcl $tcl_patchLevel tests running in interp: [info nameofexecutable]" -puts stdout "Tests running in working dir: $::tcltest::workingDirectory" +puts stdout "Tests running in working dir: $::tcltest::testsDirectory" if {[llength $::tcltest::skip] > 0} { puts stdout "Skipping tests that match: $::tcltest::skip" } @@ -26,37 +26,19 @@ if {[llength $::tcltest::match] > 0} { puts stdout "Only running tests that match: $::tcltest::match" } -# Use command line specified glob pattern (specified by -file or -f) -# if one exists. Otherwise use *.test. If given, the file pattern -# should be specified relative to the dir containing this file. If no -# files are found to match the pattern, print an error message and exit. - -set fileIndex [expr {[lsearch $argv "-file"] + 1}] -set fIndex [expr {[lsearch $argv "-f"] + 1}] -if {($fileIndex < 1) || ($fIndex > $fileIndex)} { - set fileIndex $fIndex +if {[llength $::tcltest::skipFiles] > 0} { + puts stdout "Skipping test files that match: $::tcltest::skipFiles" } -if {$fileIndex > 0} { - set globPattern [file join $::tcltest::testsDirectory [lindex $argv $fileIndex]] - puts stdout "Sourcing files that match: $globPattern" -} else { - set globPattern [file join $::tcltest::testsDirectory *.test] -} -set fileList [glob -nocomplain $globPattern] -if {[llength $fileList] < 1} { - puts "Error: no files found matching $globPattern" - exit +if {[llength $::tcltest::matchFiles] > 0} { + puts stdout "Only sourcing test files that match: $::tcltest::matchFiles" } + set timeCmd {clock format [clock seconds]} puts stdout "Tests began at [eval $timeCmd]" # source each of the specified tests -foreach file [lsort $fileList] { +foreach file [lsort [::tcltest::getMatchingFiles]] { set tail [file tail $file] - if {[string match l.*.test $tail]} { - # This is an SCCS lockfile; ignore it - continue - } puts stdout $tail if {[catch {source $file} msg]} { puts stdout $msg @@ -68,13 +50,3 @@ puts stdout "\nTests ended at [eval $timeCmd]" ::tcltest::cleanupTests 1 return - - - - - - - - - - diff --git a/tests/winPipe.test b/tests/winPipe.test index d9db002..b2c3c8a 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -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: winPipe.test,v 1.9 1999/06/26 20:55:20 rjohnson Exp $ +# RCS: @(#) $Id: winPipe.test,v 1.10 1999/06/29 20:14:17 jenn Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -306,7 +306,7 @@ catch {set env_temp $env(TEMP)} set env(TMP) c:/ set env(TEMP) c:/ -test winpipe-4.1 {TclpCreateTempFile: cleanup temp files} {pcOnly stdio} { +test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {pcOnly stdio} { set x {} set existing [glob -nocomplain c:/tcl*.tmp] exec $::tcltest::tcltest < nothing @@ -317,7 +317,7 @@ test winpipe-4.1 {TclpCreateTempFile: cleanup temp files} {pcOnly stdio} { } set x } {} -test winpipe-4.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly stdio} { +test winpipe-5.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly stdio} { set tmp $env(TMP) set temp $env(TEMP) unset env(TMP) @@ -327,7 +327,7 @@ test winpipe-4.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly stdio} { set env(TEMP) $temp set x {} } {} -test winpipe-4.3 {TclpCreateTempFile: TMP specifies non-existent directory} \ +test winpipe-5.3 {TclpCreateTempFile: TMP specifies non-existent directory} \ {pcOnly stdio} { set tmp $env(TMP) set env(TMP) snarky @@ -335,7 +335,7 @@ test winpipe-4.3 {TclpCreateTempFile: TMP specifies non-existent directory} \ set env(TMP) $tmp set x {} } {} -test winpipe-4.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \ +test winpipe-5.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \ {pcOnly stdio} { set tmp $env(TMP) set temp $env(TEMP) @@ -347,7 +347,7 @@ test winpipe-4.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \ set x {} } {} -test winpipe-5.1 {PipeSetupProc & PipeCheckProc: read threads} \ +test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \ {pcOnly stdio cat32} { set f [open "|$cat32" r+] fconfigure $f -blocking 0 @@ -367,7 +367,7 @@ test winpipe-5.1 {PipeSetupProc & PipeCheckProc: read threads} \ lappend x [catch {close $f} msg] $msg } {writable timeout readable {foobar } timeout 1 stderr32} -test winpipe-5.2 {PipeSetupProc & PipeCheckProc: write threads} \ +test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \ {pcOnly stdio cat32} { set f [open "|$cat32" r+] fconfigure $f -blocking 0 @@ -385,10 +385,10 @@ makeFile { puts "[list $argv0 $argv]" } echoArgs.tcl -test winpipe-4.1 {BuildCommandLine: null arguments} {pcOnly stdio} { +test winpipe-7.1 {BuildCommandLine: null arguments} {pcOnly stdio} { exec $::tcltest::tcltest echoArgs.tcl foo "" bar } {echoArgs.tcl {foo {} bar}} -test winpipe-4.1 {BuildCommandLine: null arguments} {pcOnly stdio} { +test winpipe-7.2 {BuildCommandLine: null arguments} {pcOnly stdio} { exec $::tcltest::tcltest echoArgs.tcl foo \" bar } {echoArgs.tcl {foo {"} bar}} |