diff options
| -rw-r--r-- | ChangeLog | 14 | ||||
| -rw-r--r-- | doc/tcltest.n | 1007 | ||||
| -rwxr-xr-x | doc/tcltest2.n | 1088 | ||||
| -rw-r--r-- | library/tcltest/pkgIndex.tcl | 3 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 3227 | ||||
| -rwxr-xr-x | library/tcltest/tcltest2.tcl | 3490 | ||||
| -rw-r--r-- | library/tcltest1.0/pkgIndex.tcl | 3 | ||||
| -rw-r--r-- | library/tcltest1.0/tcltest.tcl | 3227 | ||||
| -rwxr-xr-x | library/tcltest1.0/tcltest2.tcl | 3490 | ||||
| -rw-r--r-- | tests/all.tcl | 47 | ||||
| -rwxr-xr-x | tests/tcltest.test | 1148 | ||||
| -rwxr-xr-x | tests/tcltest2.test | 1308 |
12 files changed, 6523 insertions, 11529 deletions
@@ -1,3 +1,15 @@ +2000-10-24 Jennifer Hom <jenn@ajubasolutions.com> + + * tests/all.tcl: Removed support for tcltest 1.0. + + * tests/tcltest.test: + * library/tcltest1.0/tcltest.tcl: + * library/tcltest1.0/pkgIndex.tcl: + * docs/tcltest.n: Moved tcltest2 code so that it's the standard + version of tcltest. Removed all tcltest2 files + (tests/tcltest2.test, library/tcltest1.0/tcltest2.tcl, + docs/tcltest2.n). + 2000-10-20 Jeff Hobbs <hobbs@ajubasolutions.com> * win/tclWinFile.c (TclpMatchFilesTypes): made the stat call only @@ -7,7 +19,7 @@ 2000-10-19 Jennifer Hom <jenn@ajubasolutions.com> * library/tcltest1.0/tcltest2.tcl: - * tests/tcltest2.test + * 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 diff --git a/doc/tcltest.n b/doc/tcltest.n index f1d9616..b9dc2c7 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -2,48 +2,97 @@ '\" Copyright (c) 1990-1994 The Regents of the University of California '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation +'\" Copyright (c) 2000 Ajuba Solutions '\" '\" 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.9 1999/12/22 00:41:13 hobbs Exp $ +'\" RCS: @(#) $Id: tcltest.n,v 1.10 2000/10/24 22:30:25 jenn Exp $ '\" .so man.macros -.TH "Tcltest" n 8.2 Tcl "Tcl Built-In Commands" +.TH "tcltest" n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -Tcltest \- Test harness support code and utilities +tcltest \- Test harness support code and utilities .SH SYNOPSIS -\fBpackage require tcltest ?1.0?\fP +\fBpackage require tcltest ?2.0?\fP .sp -\fB::tcltest::test \fIname desc ?constraint? script expectedAnswer\fR +\fBtcltest::test \fIname desc ?option value? ?option value? ...\fR +.br +\fBtcltest::test \fIname desc {?option value? ?option value? ...}\fR .sp -\fB::tcltest::cleanupTests \fI?runningMultipleTests?\fR +\fBtcltest::cleanupTests \fI?runningMultipleTests?\fR .sp -\fB::tcltest::getMatchingTestFiles\fR +\fBtcltest::runAllTests\fR .sp -\fB::tcltest::loadTestedCommands\fR +\fBtcltest::interpreter \fI?interp?\fR .sp -\fB::tcltest::makeFile \fIcontents name\fR +\fBtcltest::singleProcess \fI?boolean?\fR .sp -\fB::tcltest::removeFile \fIname\fR +\fBtcltest::debug \fI?level?\fR .sp -\fB::tcltest::makeDirectory \fIname\fR +\fBtcltest::verbose \fI?levelList?\fR .sp -\fB::tcltest::removeDirectory \fIname\fR +\fBtcltest::preserveCore \fI?level?\fR .sp -\fB::tcltest::viewFile \fIname\fR +\fBtcltest::testConstraint \fIconstraint ?value?\fR .sp -\fB::tcltest::normalizeMsg \fImsg\fR +\fBtcltest::limitConstraints \fI?constraintList?\fR .sp -\fB::tcltest::bytestring \fIstring\fR +\fBtcltest::workingDirectory \fI?dir?\fR .sp -\fB::tcltest::saveState\fR +\fBtcltest::temporaryDirectory \fI?dir?\fR .sp -\fB::tcltest::restoreState\fR +\fBtcltest::testsDirectory \fI?dir?\fR .sp -\fB::tcltest::threadReap\fR +\fBtcltest::match \fI?patternList?\fR +.sp +\fBtcltest::matchFiles \fI?patternList?\fR +.sp +\fBtcltest::matchDirectories \fI?patternList?\fR +.sp +\fBtcltest::skip \fI?patternList?\fR +.sp +\fBtcltest::skipFiles \fI?patternList?\fR +.sp +\fBtcltest::skipDirectories \fI?patternList?\fR +.sp +\fBtcltest::loadTestedCommands\fR +.sp +\fBtcltest::loadScript \fI?script?\fR +.sp +\fBtcltest::loadFile \fI?filename?\fR +.sp +\fBtcltest::outputChannel \fI?channelID?\fR +.sp +\fBtcltest::outputFile \fI?filename?\fR +.sp +\fBtcltest::errorChannel \fI?channelID?\fR +.sp +\fBtcltest::errorFile \fI?filename?\fR +.sp +\fBtcltest::makeFile \fIcontents name ?directory?\fR +.sp +\fBtcltest::removeFile \fIname ?directory?\fR +.sp +\fBtcltest::makeDirectory \fIname ?directory?\fR +.sp +\fBtcltest::removeDirectory \fIname ?directory?\fR +.sp +\fBtcltest::viewFile \fIname ?directory?\fR +.sp +\fBtcltest::normalizeMsg \fImsg\fR +.sp +\fBtcltest::normalizePath \fIpathVar\fR +.sp +\fBtcltest::bytestring \fIstring\fR +.sp +\fBtcltest::saveState\fR +.sp +\fBtcltest::restoreState\fR +.sp +\fBtcltest::threadReap\fR .BE .SH DESCRIPTION .PP @@ -55,81 +104,262 @@ The Tcl test suite consists of multiple .test files, each of which contains multiple test cases. Each test case consists of a call to the test command, which specifies the name of test, a short description, any constraints that apply to the test case, the script -to be run, and expected results. See the sections \fI"Tests,"\fR -\fI"Test Constraints,"\fR and \fI"Test Files and How to Run Them"\fR -for more details. +to be run, and expected results. See the \fI"Tests"\fR section for more +details. .PP It is also possible to add to this test harness to create your own customized test harness implementation. For more defails, see the section \fI"How to Customize the Test Harness"\fR. -.PP -This approach to testing was designed and initially implemented by -Mary Ann May-Pumphrey of Sun Microsystems in the early 1990's. Many -thanks to her for donating her work back to the public Tcl release. .SH COMMANDS .TP -\fB::tcltest::test\fP \fIname desc ?constraints? script expectedAnswer\fR -The \fB::tcltest::test\fR command runs\fIscript\fR and compares -its result to \fIexpectedAnswer\fR. It prints an error message if the two do -not match. If \fB::tcltest::verbose\fR contains "p" or "s", it also prints -out a message if the test passed or was skipped. The test will be -skipped if it doesn't match the \fB::tcltest::match\fR variable, if it -matches an element in \fB::tcltest::skip\fR, or if one of the elements -of \fIconstraint\fR turns out not to be true. The -\fB::tcltest::test\fR command has no defined return values. See the -\fI"Writing a new test"\fR section for more details on this command. -.TP -\fB::tcltest::cleanupTests\fP \fI?runningMultipleTests?\fR +\fBtcltest::test\fP \fIname desc ?option value? ?option value? ...\fR +.TP +\fBtcltest::test\fP \fIname desc {?option value? ?option value? ...}\fR +The \fBtcltest::test\fR command runs the value supplied for attribute +\fIscript\fR and compares its result to possible results. +It prints an error message if actual results and expected results do +not match. The \fBtcltest::test\fR command returns 0 if it completes +successfully. Any other return value indicates that an error has +occurred in the tcltest package. See the \fI"Tests"\fR section for +more details on this command. +.TP +\fBtcltest::cleanupTests\fP \fI?runningMultipleTests?\fR This command should be called at the end of a test file. It prints statistics about the tests run and removes files that were created by -\fB::tcltest::makeDirectory\fR and \fB::tcltest::makeFile\fR. Names +\fBtcltest::makeDirectory\fR and \fBtcltest::makeFile\fR. Names of files and directories created outside of -\fB::tcltest::makeFile\fR and \fB::tcltest::makeDirectory\fR and -never deleted are printed to \fB::tcltest::outputChannel\fR. This command +\fBtcltest::makeFile\fR and \fBtcltest::makeDirectory\fR and +never deleted are printed to \fBtcltest::outputChannel\fR. This command also restores the original shell environment, as described by the ::env -array. \fIcalledFromAll\fR should be specified when -\fB::tcltest::cleanupTests\fR is called from an "all.tcl" file. Tcl files -files are generally used to run multiple tests. For more details on how to -run multiple tests, please see the section \fI"Running test files"\fR. -This proc has no defined return value. -.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::loadTestedCommands\fP +array. \fIcalledFromAll\fR should be specified if +\fBtcltest::cleanupTests\fR is called explicitly from an "all.tcl" +file. Tcl files files are generally used to run multiple tests. For +more details on how to run multiple tests, please see the section +\fI"Running test files"\fR. This proc has no defined return value. +.TP +\fBtcltest::runAllTests\fP +This command should be used in your 'all.tcl' file. It is used to +loop over test files and directories, determining which test files to +run and then running them. Note that this test calls +tcltest::cleanupTests; if using this proc in your 'all.tcl' file, you +should not call tcltest::cleanupTests explicitly in that file. See the +sample 'all.tcl' file in the \fI"Examples"\fR section. +.TP +\fBtcltest::interpreter\fR \fI?executableName?\fR +Sets or returns the name of the executable used to invoke the test +suite. This is the interpreter used in runAllTests to run test files +if singleProcess is set to false. The default value for interpreter +is the name of the interpreter in which the tests were started. +.TP +\fBtcltest::singleProcess\fR \fI?boolean?\fR +Sets or returns a boolean indicating whether test files should be sourced +into the current interpreter by runAllTests or run in their own +processes. If \fIboolean\fR is true (1), tests are sourced into the +current interpreter. If \fIboolean\fR is false (0), tests are run in +the interpreter specified in tcltest::interpreter. The default value +for tcltest::singleProcess is false. +.TP +\fBtcltest::debug\fR \fI?level?\fR +Sets or returns the current debug level. The debug level determines +how much tcltest package debugging information is printed to stdout. +The default debug level is 0. Levels are defined as: +.RS +.IP 0 +Do not display any debug information. +.IP 1 +Display information regarding whether a test is skipped because it +doesn't match any of the tests that were specified using -match or +tcltest::match (userSpecifiedNonMatch) or matches any of the tests +specified by -skip or tcltest::skip (userSpecifiedSkip). +.IP 2 +Display the flag array parsed by the command line processor, the +contents of the ::env array, and all user-defined variables that exist +in the current namespace as they are used. +.IP 3 +Display information regarding what individual procs in the test +harness are doing. +.RE +.TP +\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 body +Display the body of failed tests +.IP pass +Print output when a test passes +.IP skip +Print output when a test is skipped +.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 +Sets or returns the current core preservation level. This level +determines how stringent checks for core files are. The default core +preservation level is 0. Levels are defined as: +.RS +.IP 0 +No checking - do not check for core files at the end of each test +command, but do check for them whenever tcltest::cleanupTests is +called from tcltest::runAllTests. +.IP 1 +Check for core files at the end of each test command and whenever +tcltest::cleanupTests is called from tcltest::runAllTests. +.IP 2 +Check for core files at the end of all test commands and whenever +tcltest::cleanupTests is called from all.tcl. Save any core files +produced in tcltest::temporaryDirectory. +.RE +.TP +\fBtcltest::testConstraint \fIconstraint ?value?\fR +Sets or returns the value associated with the named \fIconstraint\fR. +See the section \fI"Test constraints"\fR for more information. +.TP +\fBtcltest::limitConstraints \fI?constraintList?\fR +Sets or returns a boolean indicating whether testing is being limited +to constraints listed in \fIconstraintList\fR. +If limitConstraints is not false, only those tests with constraints matching +values in \fIconstraintList\fR will be run. +.TP +\fBtcltest::workingDirectory\fR \fI?directoryName?\fR +Sets or returns the directory in which the test suite is being run. +The default value for workingDirectory is the directory in which the +test suite was launched. +.TP +\fBtcltest::temporaryDirectory\fR \fI?directoryName?\fR +Sets or returns the output directory for temporary files created by +tcltest::makeFile and tcltest::makeDirectory. This defaults to the +directory returned by \fItcltest::workingDirectory\fR. +.TP +\fBtcltest::testsDirectory\fR \fI?directoryName?\fR +Sets or returns the directory where the tests reside. This defaults +to the directory returned by \fItcltest::workingDirectory\fR +if the script cannot determine where the \fItests\fR directory is +located. This variable should be explicitly set if tests are being run +from an all.tcl file. +.TP +\fBtcltest::match\fR \fI?globPatternList?\fR +Sets or returns the glob pattern list that determines which tests +should be run. Only tests which match one of the glob patterns in +\fIglobPatternList\fR are run by the test harness. The default value +for \fIglobPatternList\fR is '*'. +.TP +\fBtcltest::matchFiles\fR \fI?globPatternList?\fR +Sets or returns the glob pattern list that determines which test files +should be run. Only test files which match one of the glob patterns in +\fIglobPatternList\fR are run by the test harness. The default value +for \fIglobPatternList\fR is '*.test'. +.TP +\fBtcltest::matchDirectories\fR \fI?globPatternList?\fR +Sets or returns the glob pattern list that determines which test +subdirectories of the current test directory should be run. Only test +subdirectories which match one of the glob patterns in +\fIglobPatternList\fR are run by the test harness. The default value +for \fIglobPatternList\fR is '*'. +.TP +\fBtcltest::skip\fR \fI?globPatternList?\fR +Sets or returns the glob pattern list that determines which tests (of +those matched by tcltest::match) should be skipped. The default value +for \fIglobPatternList\fR is {}. +.TP +\fBtcltest::skipFiles\fR \fI?globPatternList?\fR +Sets or returns the glob pattern list that determines which test files +(of those matched by tcltest::matchFiles) should be skipped. The +default value for \fIglobPatternList\fR is {}. +.TP +\fBtcltest::skipDirectories\fR \fI?globPatternList?\fR +Sets or returns the glob pattern list that determines which test +subdirectories (of those matched by tcltest::matchDirectories) should +be skipped. The default value for \fIglobPatternList\fR is {}. +.TP +\fBtcltest::loadTestedCommands\fP This command uses the script specified via the \fI-load\fR or -\fI-loadfile\fR to load the commands checked by the test suite. -Allowed to be empty, as the tested commands could have been compiled -into the interpreter running the test suite. +\fI-loadfile\fR options or the tcltest::loadScript or +tcltest::loadFile procs to load the commands checked by the test suite. +It is allowed to be empty, as the tested commands could have been +compiled into the interpreter running the test suite. +.TP +\fBtcltest::loadScript\fR \fI?script?\fR +Sets or returns the script executed by \fBloadTestedCommands\fR. +.TP +\fBtcltest::loadFile\fR \fI?filename?\fR +Sets ore returns the file name associated with the script executed +\fBloadTestedCommands\fR. If setting \fIfilename\fR, this proc will +open the file and call \fItcltest::loadScript\fR with the content. +.TP +\fBtcltest::outputChannel\fR \fI?channelID?\fR +Sets or returns the output file ID. This defaults to stdout. +Any test that prints test related output should send +that output to \fItcltest::outputChannel\fR rather than letting +that output default to stdout. +.TP +\fBtcltest::outputFile\fR \fI?filename?\fR +Sets or returns the file name corresponding to the output file. This +defaults to stdout. This proc calls +outputChannel to set the output file channel. +Any test that prints test related output should send +that output to \fItcltest::outputChannel\fR rather than letting +that output default to stdout. +.TP +\fBtcltest::errorChannel\fR \fI?channelID?\fR +Sets or returns the error file ID. This defaults to stderr. +Any test that prints error messages should send +that output to \fItcltest::errorChannel\fR rather than printing +directly to stderr. +.TP +\fBtcltest::errorFile\fR \fI?filename?\fR +Sets or returns the file name corresponding to the error file. This +defaults to stderr. This proc calls +errorChannel to set the error file channel. +Any test that prints test related error output should send +that output to \fItcltest::errorChannel\fR or +\fItcltest::outputChannel\fR rather than letting +that output default to stdout. .TP -\fB::tcltest::makeFile\fP \fIcontents name\fR +\fBtcltest::makeFile\fP \fIcontents name ?directory?\fR Create a file that will be automatically be removed by -\fB::tcltest::cleanupTests\fR at the end of a test file. -This proc has no defined return value. +\fBtcltest::cleanupTests\fR at the end of a test file. This file is +created relative to \fIdirectory\fR. If left unspecified, +\fIdirectory\fR defaults to tcltest::temporaryDirectory. +Returns the full path of the file created. .TP -\fB::tcltest::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 \fI::tcltest::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 -\fB::tcltest::makeDirectory\fP \fIname\fR +\fBtcltest::makeDirectory\fP \fIname ?directory?\fR Create a directory named \fIname\fR that will automatically be removed -by \fB::tcltest::cleanupTests\fR at the end of a test file. This proc -has no defined return value. -.TP -\fB::tcltest::removeDirectory\fP \fIname\fR -Force the directory referenced by \fIname\fR to be removed. This proc +by \fBtcltest::cleanupTests\fR at the end of a test file. This +directory is created relative to tcltest::temporaryDirectory. +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 \fIdirectory\fR. If left unspecified, +\fIdirectory\fR defaults to tcltest::temporaryDirectory. This proc has no defined return value. .TP -\fB::tcltest::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 -\fB::tcltest::normalizeMsg\fP \fImsg\fR +\fBtcltest::normalizeMsg\fP \fImsg\fR Remove extra newlines from \fImsg\fR. .TP -\fB::tcltest::bytestring\fP \fIstring\fR +\fBtcltest::normalizePath\fP \fIpathVar\fR +Resolves symlinks in a path, thus creating a path without internal +redirection. It is assumed that \fIpathVar\fR is absolute. +\fIpathVar\fR is modified in place. +.TP +\fBtcltest::bytestring\fP \fIstring\fR Construct a string that consists of the requested sequence of bytes, as opposed to a string of properly formed UTF-8 characters using the value supplied in \fIstring\fR. This allows the tester to create @@ -137,158 +367,178 @@ denormalized or improperly formed strings to pass to C procedures that are supposed to accept strings with embedded NULL types and confirm that a string result has a certain pattern of bytes. .TP -\fB::tcltest::saveState\fP -\fB::tcltest::restoreState\fP -Save and restore the procedure and global variable names. -A test file might contain calls to \fB::tcltest::saveState\fR and +\fBtcltest::saveState\fP +Save procedure and global variable names. +A test file might contain calls to \fBtcltest::saveState\fR and +\fB::tcltest:restoreState\fR if it creates or deletes global variables +or procs. +.TP +\fBtcltest::restoreState\fP +Restore procedure and global variable names. +A test file might contain calls to \fBtcltest::saveState\fR and \fB::tcltest:restoreState\fR if it creates or deletes global variables or procs. .TP -\fB::tcltest::threadReap\fP -\fB::tcltest::threadReap\fR only works if \fItestthread\fR is +\fBtcltest::threadReap\fP +\fBtcltest::threadReap\fR only works if \fItestthread\fR is defined, generally by compiling tcltest. If \fItestthread\fR is -defined, \fB::tcltest::threadReap\fR kills all threads except for the +defined, \fBtcltest::threadReap\fR kills all threads except for the main thread. It gets the ID of the main thread by calling \fItestthread names\fR during initialization. This value is stored in -\fI::tcltest::mainThread\fR. \fB::tcltest::threadReap\fR returns the +\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. -The following is the spec for the \fBtest\fR command: +Two syntaxes are provided for specifying the attributes of the tests. +The first uses a separate argument for each of the attributes and +values. The second form places all of the attributes and values +together into a single argument; the argument must have proper list +structure, with teh elements of the list being the attributes and +values. The second form makes it easy to construct multi-line +scripts, since the braces around the whole list make it unnecessary to +include a backslash at the end of each line. In the second form, no +command or variable substitutions are performed on the attribute +names. This makes the behavior of the second form different from the +first form in some cases. +.PP +The first form for the \fBtest\fR command: +.DS +test \fIname\fR \fIdescription\fR + ?-constraints \fIkeywordList|expression\fR + ?-setup \fIsetupScript\fR? + ?-body \fItestScript\fR? + ?-cleanup \fIcleanupScript\fR? + ?-result \fIexpectedAnswer\fR? + ?-output \fIexpectedOutput\fR? + ?-errorOutput \fIexpectedError\fR? + ?-returnCodes \fIcodeList\fR? + ?-match \fIexact|glob|regexp\fR? +.DE +.PP +The second form for the \fBtest\fR command: .DS -test <name> <description> ?<constraint>? <script> <expectedAnswer> +test \fIname\fR \fIdescription\fR { + ?-constraints \fIkeywordList|expression\fR + ?-setup \fIsetupScript\fR? + ?-body \fItestScript\fR? + ?-cleanup \fIcleanupScript\fR? + ?-result \fIexpectedAnswer\fR? + ?-output\fIexpectedOutput\fR? + ?-errorOutput \fIexpectedError\fR? + ?-returnCodes \fIcodeList\fR? + ?-match \fIexact|glob|regexp? +} .DE -The <name> argument should follow the pattern: +The \fIname\fR argument should follow the pattern: .DS <target>-<majorNum>.<minorNum> .DE For white-box (regression) tests, the target should be the name of the C function or Tcl procedure being tested. For black-box tests, the target should be the name of the feature being tested. Related tests -should share a major number. -.PP -The <description> argument is a short textual description of the test, -to help humans understand what it tests. The name of a Tcl or C -function being tested should be included for regression tests. If the -test case exists to reproduce a bug, include the bug ID in the -description. -.PP -The optional <constraints> argument can be list of one or more -keywords or an expression. If the <constraints> argument consists of -keywords, each of these keywords must be the name of an element in the array -\fI::tcltest::testConstraints\fR. If any of these elements is false or does -not exist, the test is skipped. If the <constraints> argument -consists of an expression, that expression is evaluated. If the -expression evaluates to true, then the test is run. -.PP -Add appropriate constraints (e.g., -unixOnly) to any tests that should not always be run. For example, a -test that should only be run on Unix should look like the following: -.PP -.DS -test getAttribute-1.1 {testing file permissions} {unixOnly} { - lindex [file attributes foo.tcl] 5 -} {00644} -.DE +should share a major number. .PP -An example of a test that contains an expression: +The \fIdescription\fR should be a short textual description of the +test. It is generally used to help humans +understand the purpose of the test. The name of a Tcl or C function +being tested should be included in the description for regression +tests. If the test case exists to reproduce a bug, include the bug ID +in the description. .PP -.DS -test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly && !testthread} { - catch {vwait x} - set f [open foo w] - fileevent $f writable {set x 1} - vwait x - close $f - list [catch {vwait x} msg] $msg -} {1 {can't wait for variable "x": would wait forever}} -.DE -.PP -See the "Test Constraints" section for a list of built-in +Valid attributes and associated values are: +.TP +\fB-constraints \fIkeywordList|expression\fR\fP +The optional \fIconstraints\fR attribute can be list of one or more +keywords or an expression. If the \fIconstraints\fR value consists of +keywords, each of these keywords being the name of a constraint +defined by a call to \fItcltest::testConstraint\fR. If any of these +elements is false or does +not exist, the test is skipped. If the \fIconstraints\fR argument +consists of an expression, that expression is evaluated. If the +expression evaluates to true, then the test is run. Appropriate +constraints should be added to any tests that should +not always be run. See the "Test Constraints" section for a list of built-in constraints and information on how to add your own constraints. -.PP -The <script> argument contains the script to run to carry out the -test. It must return a result that can be checked for correctness. -If your script requires that a file be created on the fly, please use -the ::tcltest::makeFile procedure. If your test requires that a small -file (<50 lines) be checked in, please consider creating the file on -the fly using the ::tcltest::makeFile procedure. Files created by the -::tcltest::makeFile procedure will automatically be removed by the -::tcltest::cleanupTests call at the end of each test file. -.PP -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 on the command line. -Any test that prints test related output should send -that output to \fI::tcltest::outputChannel\fR rather than letting -that output default to stdout. -.TP -\fB::tcltest::errorChannel\fR -error file ID - defaults to stderr and can be specified using -errfile -on the command line. -Any test that prints error messages should send -that output to \fI::tcltest::errorChannel\fR rather than printing -directly to stderr. -.TP -\fB::tcltest::mainThread\fR -main thread ID - 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 -\fB::tcltest::originalEnv\fR -copy of the global "env" array at the beginning of the test run. This -array is used to restore the "env" array to its original state when -\fI::tcltest::cleanupTests\fR is called. -.TP -\fB::tcltest::workingDirectory\fR -the directory in which the test suite was launched. -.TP -\fB::tcltest::temporaryDirectory\fR -the output directory - defaults to \fI::tcltest::workingDirectory\fR and can be -specified using -tmpdir on the command line. -.TP -\fB::tcltest::testsDirectory\fR -where the tests reside - defaults to \fI::tcltest::workingDirectory\fR -if the script cannot determine where the \fItests\fR directory is -located. It is possible to change the default by specifying -\fI-testdir\fR on the commandline. This variable should be -explicitly set if tests are being run from an all.tcl file. .TP -\fB::tcltest::tcltest\fR -the name of the executable used to invoke the test suite. +\fB-setup \fIscript\fR\fP +The optional \fIsetup\fR attribute indicates a script that will be run +before the script indicated by the \fIscript\fR attribute. If setup +fails, the test will fail. .TP -\fB::tcltest::loadScript\fR -The script executed \fBloadTestedCommands\fR. Specified either by -\fI-load\fR or \fI-loadfile\fR. +\fB-body \fIscript\fR\fP +The \fIbody\fR attribute indicates the script to run to carry out the +test. It must return a result that can be checked for correctness. +If left unspecified, the script value will be {}. +.TP +\fB-cleanup \fIscript\fR\fP +The optional \fIcleanup\fR attribute indicates a script that will be +run after the script indicated by the \fIscript\fR attribute. If +cleanup fails, the test will fail. +.TP +\fB-match \fIregexp|glob|exact\fP +The \fImatch\fR attribute determines how expected answers supplied in +\fIresult\fR, \fIoutput\fR, and \fRerrorOutput\fR are compared. Valid +options for the value supplied are "regexp", "glob", and +"exact". If \fImatch\fR is not specified, the comparisons will be +done in "exact" mode by default. +.TP +\fB-result \fIexpectedValue\fR\fP +The \fIresult\fR attribute supplies the comparison value with which +the return value from script will be compared. +If left unspecified, the default +\fIexpectedValue\fR will be the empty list. +.TP +\fB-output \fIexpectedValue\fR\fP +The \fIoutput\fR attribute supplies the comparison value with which +any output sent to stdout or tcltest::outputChannel during the script +run will be compared. Note that only output printed using +puts is used for comparison. If \fIoutput\fR is not specified, output +sent to stdout and tcltest::outputChannel is not processed for comparison. +.TP +\fB-errorOutut \fIexpectedValue\fR\fP +The \fIerrorOutput\fR attribute supplies the comparison value with which +any output sent to stderr or tcltest::errorChannel during the script +run will be compared. Note that only output printed using +puts is used for comparison. If \fIerrorOutut\fR is not specified, output +sent to stderr and tcltest::errorChannel is not processed for comparison. +.TP +\fB-returnCodes \fIexpectedCodeList\fR\fP +The optional \fIreturnCodes\fR attribute indicates which return codes +from the script supplied with the \fIscript\fR attribute are correct. +Default values for \fIexpectedCodeList\fR are 0 (normal return) and 2 +(return exception). Symbolic values \fInormal\fR (0), \fIerror\fR +(1), \fIreturn\fR (2), \fIbreak\fR (3), and \fIcontinue\fR (4) can be +used in the \fIexpectedCodeList\fR list. +.PP +To pass, a test must successfully execute its setup, script, and +cleanup code. The return code of the test and its return values must +match expected values, and if specified, output and error data from +the test must match expected output and error values. If all of these +conditions are not met, then the test fails. .SH "TEST CONSTRAINTS" -Constraints are used to determine whether a test should be skipped. -Each constraint is stored as an index in the array -\fI::tcltest::testConstraints\fR. For example, the unixOnly constraint is -defined as the following: -.DS -set ::tcltest::testConstraints(unixOnly) \\ - [string equal $tcl_platform(platform) "unix"] -.DE +Constraints are used to determine whether or not a test should be skipped. If a test is constrained by "unixOnly", then it will only be run if -the value of ::tcltest::testConstraints(unixOnly) is true. Several -constraints are defined in the \fBtcltest\fR package. To add file- or -test-specific constraints, you can set the desired index of the -::tcltest::testsConstraints array in your own test file. +the value of the constraint is true. Several +constraints are defined in the \fBtcltest\fR package. To add +constraints, you can call \fBtcltest::testConstraint\fR +with the appropriate arguments in your own test file. .PP The following is a list of constraints defined in the \fBtcltest\fR package: .TP +\fIsingleTestInterp\fR +test can only be run if all test files are sourced into a single interpreter +.TP \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 @@ -303,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 @@ -324,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 @@ -355,8 +605,8 @@ test requires interaction from the user. This constraint always causes tests to be skipped unless the user specifies otherwise. .TP \fIinteractive\fR -test can only be run in if the interpreter is in interactive mode, -that is the global tcl_interactive variable is set to 1. +test can only be run in if the interpreter is in interactive mode +(when the global tcl_interactive variable is set to 1). .TP \fInonBlockFiles\fR test can only be run if platform supports setting files into @@ -367,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 @@ -391,7 +641,7 @@ tcltest: .DS <shell> <testFile> ?<option> ?<value>?? ... .DE -Command line options include (tcltest namespace variables that +Command line options include (tcltest accessor procs that correspond to each flag are listed at the end of each flag description in parenthesis): .RS @@ -399,33 +649,54 @@ in parenthesis): \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. (::tcltest::verbose) +\fB-singleproc <bool>\fR +if <bool> is 0, run test files in separate interpreters. if 1, source test +files into the current intpreter. (tcltest::singleProcess) +.TP +\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 -<matchList>. (::tcltest::match) +<matchList>. (tcltest::match) .TP \fB-skip <skipList>\fR do not run tests that match one or more of the glob patterns in -<skipList>. (::tcltest::skip) +<skipList>. (tcltest::skip) .TP \fB-file <globPatternList>\fR only source test files that match any of the items in -<globPatternList> relative to ::tcltest::testsDirectory. +<globPatternList> relative to tcltest::testsDirectory. This option only makes sense if you are running tests using "all.tcl" as the <testFile> instead of running single test files directly. -(::tcltest::matchFiles) +(tcltest::matchFiles) .TP \fB-notfile <globPatternList>\fR source files except for those that match any of the items in -<globPatternList> relative to ::tcltest::testsDirectory. +<globPatternList> relative to tcltest::testsDirectory. +This option +only makes sense if you are running tests using "all.tcl" as the +<testFile> instead of running single test files directly. +(tcltest::skipFiles) +.TP +\fB-relateddir <globPatternList>\fR +only run tests in directories that match any of the items in +<globPatternList> relative to tcltest::testsDirectory. This option only makes sense if you are running tests using "all.tcl" as the <testFile> instead of running single test files directly. -(::tcltest::skipFiles) +(tcltest::matchDirectories) +.TP +\fB-asidefromdir <globPatternList>\fR +run tests in directories except for those that match any of the items in +<globPatternList> relative to tcltest::testsDirectory. +This option +only makes sense if you are running tests using "all.tcl" as the +<testFile> instead of running single test files directly. +(tcltest::skipDirectories) .TP \fB-constraints <list>\fR tests with any constraints in <list> will not be skipped. Note that @@ -433,7 +704,7 @@ elements of <list> must exactly match the existing constraints. This is useful if you want to make sure that tests with a particular constraint are run (for example, if the tester wants to run all tests with the knownBug constraint). -(::tcltest::testConstraints(\fIconstraintName\fR)) +(tcltest::testConstraint) .TP \fB-limitconstraints <bool>\fR If the argument to this flag is 1, the test harness limits test runs @@ -441,173 +712,145 @@ 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). This is useful if you want to run \fBonly\fR those tests that match the constraints listed using -the -constraints option. A tester might want to do this if he were +the -constraints option. A tester might want to do this if (for +example) he were interested in running only those tests that are constrained to be unixOnly and no other tests. -(::tcltest::limitConstraints) +(tcltest::limitConstraints) .TP \fB-load <script>\fR will use the specified script to load the commands under test -(::tcltest::loadTestedCommands). The default is the empty -script. See -loadfile below too. (::tcltest::loadScript) +(tcltest::loadTestedCommands). The default is the empty +script. See -loadfile below too. (tcltest::loadScript) .TP \fB-loadfile <scriptfile>\fR will use the contents of the named file to load the commands under -test (::tcltest::loadTestedCommands). See -load above too. The default -is the empty script. (::tcltest::loadScript) +test (tcltest::loadTestedCommands). See -load above too. The default +is the empty script. (tcltest::loadFile) .TP \fB-tmpdir <directoryName>\fR -put any temporary files (created with ::tcltest::makeFile and -::tcltest::makeDirectory) into the named directory. The default -location is ::tcltest::workingDirectory. (::tcltest::temporaryDirectory) +put any temporary files (created with tcltest::makeFile and +tcltest::makeDirectory) into the named directory. The default +location is tcltest::workingDirectory. (tcltest::temporaryDirectory) .TP \fB-testdir <directoryName>\fR search the test suite to execute in the named directory. The default -location is ::tcltest::workingDirectory. (::tcltest::testsDirectory) +location is tcltest::workingDirectory. (tcltest::testsDirectory) .TP \fB-preservecore <level>\fR check for core files. This flag is used to determine how much -checking should be done for core files. The default value for -\fIlevel\fR is 0. Levels are defined as: -.RS -.IP 0 -No checking - do not check for core files at the end of each test -command, but do check for them whenever ::tcltest::cleanupTests is -called from an all.tcl file. -.IP 1 -Check for core files at the end of each test command and whenever -::tcltest::cleanupTests is called from all.tcl. -.IP 2 -Check for core files at the end of all test commands and whenever -::tcltest::cleanupTests is called from all.tcl. Save any core files -produced in ::tcltest::temporaryDirectory. -.RE -.sp -(::tcltest::preserveCore) +checking should be done for core files. (tcltest::preserveCore) .TP \fB-debug <debugLevel>\fR print debug information to stdout. This is used to debug code in the -test harness. The default debug level is 0. Levels are defined as: -.RS -.IP 0 -Do not display any debug information. -.IP 1 -Display information regarding whether a test is skipped because it -doesn't match any of the tests that were specified using -match or -::tcltest::match (userSpecifiedNonMatch) or matches any of the tests -specified by -skip or ::tcltest::skip (userSpecifiedSkip). -.IP 2 -Display the flag array parsed by the command line processor, the -contents of the ::env array, and all user-defined variables that exist -in the current namespace as they are used. -.IP 3 -Display information regarding what individual procs in the test -harness are doing. -.RE -.sp -(::tcltest::debug) +tcltest package. (tcltest::debug) .TP \fB-outfile <filename>\fR print output generated by the tcltest package to the named file. This defaults to stdout. Note that debug output always goes to stdout, -regardless of this flag's setting. (::tcltest::outputChannel) +regardless of this flag's setting. (tcltest::outputFile) .TP \fB-errfile <filename>\fR print errors generated by the tcltest package to the named file. This -defaults to stderr. (::tcltest::errorChannel) +defaults to stderr. (tcltest::errorFile) .RE .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 '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 \fBtcltest\fR package, and then source an appropriate test file or use the test command. To use the options in interactive mode, set their corresponding tcltest namespace variables after loading the package. .PP -See \fI"Test Constraints"\fR for all built-in constraint names -that can be used in the \fB::tcltest::testConstraints\fR array. -See \fI"Tcltest namespace variables"\fR for details on other variables -defined in the \fBtcltest\fR namespace. +See \fI"Test Constraints"\fR for a list of all built-in constraint names. .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 approach used by the Tcl test suite. This file loads the tcltest package, sets the location of -the test directory (::tcltest::testsDirectory), determines which test -files to run, sources each of these files, calls -::tcltest::cleanupTests and then exits. +the test directory (tcltest::testsDirectory), and then calls the +\fItcltest::runAllTests\fR proc, which determines which test +files to run, how to run them, and calls tcltest::cleanupTests to +determine the summary status of the test suite. .PP A more elaborate \fIall.tcl\fR file might do some pre- and post-processing before sourcing each .test file, use separate interpreters for each file, or handle -complex directory structures. +complex directory structures. For an example of an all.tcl file, please see the "Examples" section of this document. .SH "TEST OUTPUT" After all specified test files are run, the number of tests passed, skipped, and failed is printed to -\fB::tcltest::outputChannel\fR. Aside from this +\fBtcltest::outputChannel\fR. Aside from this statistical information, output can be controlled on a per-test basis -by the \fB::tcltest::verbose\fR variable. -.PP -\fB::tcltest::verbose\fR can be set to any substring or permutation -of "bps". In the string "bps", the 'b' stands for a test's "body", -the 'p' stands for "passed" tests, and the 's' stands for "skipped" -tests. The default value of \fB::tcltest::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, +by the \fBtcltest::verbose\fR variable. +.PP +\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. +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 \fB::tcltest::verbose\fR either interactively (after the +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: .DS -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} +package require tcltest +namespace import -force tcltest::* .DE Test files should end by cleaning up after themselves and calling -\fB::tcltest::cleanupTests\fR. The \fB::tcltest::cleanupTests\fR +\fBtcltest::cleanupTests\fR. The \fBtcltest::cleanupTests\fR procedure prints statistics about the number of tests that passed, skipped, and failed, and removes all files that were created using the -\fB::tcltest::makeFile\fR and \fB::tcltest::makeDirectory\fR procedures. +\fBtcltest::makeFile\fR and \fBtcltest::makeDirectory\fR procedures. .DS # Remove files created by these tests # Change to original working directory # Unset global arrays -::tcltest::cleanupTests +tcltest::cleanupTests return .DE When naming test files, file names should end with a .test extension. The names of test files that contain regression (or glass-box) tests should correspond to the Tcl or C code file that they are testing. For example, the test file for the C file "tclCmdAH.c" is "cmdAH.test". -Test files that contain black-box tests should match the pattern "*_bb.test". -.SH "SELECTING TESTS FOR EXECUTION WITHIN A FILE" +.SH "SELECTING TESTS FOR EXECUTION" .PP Normally, all the tests in a file are run whenever the file is sourced. An individual test will be skipped if one of the following conditions is met: .IP [1] the \fIname\fR of the tests does not match (using glob style matching) -one or more elements in the \fB::tcltest::match\fR variable +one or more elements in the \fBtcltest::match\fR variable .IP [2] the \fIname\fR of the tests matches (using glob style matching) one or -more elements in the \fB::tcltest::skip\fR variable +more elements in the \fBtcltest::skip\fR variable .IP [3] -the \fIconstraints\fR argument to the \fB::tcltest::test\fR call, if +the \fIconstraints\fR argument to the \fBtcltest::test\fR call, if given, contains one or more false elements. .PP -You can set \fB::tcltest::match\fR and/or \fB::tcltest::skip\fR +You can set \fBtcltest::match\fR and/or \fBtcltest::skip\fR either interactively (after the \fBtcltest\fR package has been sourced), or by using the command line arguments \fB-match\fR and \fB-skip\fR, for example: @@ -622,8 +865,7 @@ specify. .PP Predefined constraints (e.g. \fIknownBug\fR and \fInonPortable\fR) can be overridden either interactively (after the \fBtcltest\fR package has been -sourced) by setting the proper -\fB::tcltest::testConstraints(\fIconstraint\fB)\fR variable +sourced) by setting the proper constraint or by using the \fB-constraints\fR command line option with the name of the constraint in the argument. The following example shows how to run tests that are constrained by the \fIknownBug\fR and \fInonPortable\fR @@ -633,41 +875,81 @@ restrictions: tclsh all.tcl -constraints "knownBug nonPortable" .CE .PP -See the \fI"Constraints"\fR package for information about using +See the \fI"Constraints"\fR section for information about using built-in constraints and adding new ones. +.PP +When tests are run from within an 'all.tcl' file, all files with a +'.test' extension are normally run. An individual test file will be +skipped if one of the following conditions is met: +.IP [1] +the \fIname\fR of the test files does not match (using glob style matching) +one or more elements in the \fBtcltest::matchFiles\fR variable +.IP [2] +the \fIname\fR of the test file matches (using glob style matching) one or +more elements in the \fBtcltest::skipFiles\fR variable +.PP +You can set \fBtcltest::matchFiles\fR and/or \fBtcltest::skipFiles\fR +either interactively (after the \fBtcltest\fR package has been +sourced), or by using the command line arguments \fB-file\fR and +\fB-notfile\fR, for example: +.PP +.CS +tclsh info.test -file 'unix*.test' -notfile 'unixNotfy.test' +.CE +.PP +Additionally, if tests are run from within an 'all.tcl' containing a +call to \fBtcltest::runAllTests\fR, any subdirectory of +\fItcltest::testsDirectory\fR containing an 'all.tcl' file will also +be run. Individual test subdirectories will be skipped if one of the +following conditions is met: +.IP [1] +the \fIname\fR of the directory does not match (using glob style matching) +one or more elements in the \fBtcltest::matchDirectories\fR variable +.IP [2] +the \fIname\fR of the directory matches (using glob style matching) one or +more elements in the \fBtcltest::skipDirectories\fR variable +.PP +You can set \fBtcltest::matchDirectories\fR and/or \fBtcltest::skipDirectories\fR +either interactively (after the \fBtcltest\fR package has been +sourced), or by using the command line arguments \fB-relateddir\fR and +\fB-asidefromdir\fR, for example: +.PP +.CS +tclsh info.test -relateddir 'subdir*' -asidefromdir 'subdir2' +.CE .SH "HOW TO CUSTOMIZE THE TEST HARNESS" To create your own custom test harness, create a .tcl file that contains your namespace. Within this file, require package \fBtcltest\fR. Commands that can be redefined to customize the test harness include: .TP -\fB::tcltest::PrintUsageInfoHook\fP +\fBtcltest::PrintUsageInfoHook\fP print additional usage information specific to your situation. .TP -\fB::tcltest::processCmdLineArgsFlagHook\fP +\fBtcltest::processCmdLineArgsFlagHook\fP tell the test harness about additional flags that you want it to understand. .TP -\fB::tcltest::processCmdLineArgsHook\fR \fIflags\fP +\fBtcltest::processCmdLineArgsHook\fR \fIflags\fP process the additional flags that you told the harness about in -::tcltest::processCmdLineArgsFlagHook. +tcltest::processCmdLineArgsFlagHook. .TP -\fB::tcltest::initConstraintsHook\fP +\fBtcltest::initConstraintsHook\fP used to add additional built-in constraints to those already defined by \fBtcltest\fR. .TP -\fB::tcltest::cleanupTestsHook\fP +\fBtcltest::cleanupTestsHook\fP do additional cleanup .PP .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. +\fBtcltest::processCmdLineArgsAddFlagHook\fR to define additional flags to be +parsed and \fBtcltest::processCmdLineArgsHook\fR to actually process them. For example: .DS -proc ::tcltest::processCmdLineArgsAddFlagHook {} { +proc tcltest::processCmdLineArgsAddFlagHook {} { return [list -flag1 -flag2] } -proc ::tcltest::processCmdLineArgsHook {flagArray} { +proc tcltest::processCmdLineArgsHook {flagArray} { array set flag $flagArray if {[info exists flag(-flag1)]} { @@ -684,27 +966,27 @@ proc ::tcltest::processCmdLineArgsHook {flagArray} { You may also want to add usage information for these flags. This information would be displayed whenever the user specifies -help. To define additional usage information, define your own -::tcltest::PrintUsageInfoHook proc. Within this proc, you should +tcltest::PrintUsageInfoHook proc. Within this proc, you should print out additional usage information for any flags that you've implemented. .PP To add new built-in constraints to the test harness, define your own version of -\fB::tcltest::initConstraintsHook\fR. -Within your proc, you can add to the \fB::tcltest::testConstraints\fR array. +\fBtcltest::initConstraintsHook\fR. +Within your proc, you can add to the \fBtcltest::testConstraints\fR array. For example: .DS -proc ::tcltest::initConstraintsHook {} { - set ::tcltest::testConstraints(win95Or98) \\ - [expr {$::tcltest::testConstraints(95) || \\ - $::tcltest::testConstraints(98)}] +proc tcltest::initConstraintsHook {} { + set tcltest::testConstraints(win95Or98) \\ + [expr {$tcltest::testConstraints(95) || \\ + $tcltest::testConstraints(98)}] } .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: +you can define your own \fBtcltest::cleanupTestsHook\fR. For example: .DS -proc ::tcltest::cleanupTestsHook {} { +proc tcltest::cleanupTestsHook {} { # Add your cleanup code here } .DE @@ -712,36 +994,23 @@ proc ::tcltest::cleanupTestsHook {} { .IP [1] A simple test file (foo.test) .DS -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} +package require tcltest +namespace import -force ::tcltest::* -test foo-1.1 {save 1 in variable name foo} {} { - set foo 1 -} {1} +test foo-1.1 {save 1 in variable name foo} -body {set foo 1} -result 1 -::tcltest::cleanupTests +tcltest::cleanupTests return .DE .IP [2] A simple all.tcl .DS -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import ::tcltest::* -} +package require tcltest +namespace import -force ::tcltest::* -set ::tcltest::testSingleFile false -set ::tcltest::testsDirectory [file dir [info script]] +tcltest::testsDirectory [file dir [info script]] +tcltest::runAllTests -foreach file [::tcltest::getMatchingTestFiles] { - if {[catch {source $file} msg]} { - puts stdout $msg - } -} - -::tclttest::cleanupTests 1 return .DE .IP [3] @@ -754,6 +1023,66 @@ Running multiple tests .DS tclsh all.tcl -file 'foo*.test' -notfile 'foo2.test' .DE +.IP [5] +A test that uses the unixOnly constraint and should only be +run on Unix +.DS +test getAttribute-1.1 {testing file permissions} { + -constraints {unixOnly} + -body { + lindex [file attributes foo.tcl] 5 + } + -result {00644} +} +.DE +.IP [6] +A test containing an constraint expression that evaluates to true (a case where the test would be run) if it is being run on unix and if threads are not being tested +.DS +test testOnUnixWithoutThreads-1.1 { + this test runs only on unix and only if we're not testing + threads +} { + -constraints {unixOnly && !testthread} + -body { + # some script goes here + } +} +.DE +.SH "KNOWN ISSUES" +There are two known issues related to nested test commands. +The first issue relates to the stack level in which test scripts are +executed. Tests nested within other tests may be executed at the same +stack level as the outermost test. For example, in the following test +code: +.DS +test level-1.1 {level 1} { + -body { + test level-2.1 {level 2} { + } + } +} +.DE +any script executed in level-2.1 may be executed at the same stack +level as the script defined for level-1.1. +.PP +In addition, while two +test commands have been run, results will only be reported for tests +at the same level as test level-1.1. However, test results for all +tests run prior to level-1.1 will be available when test level-2.1 +runs. What this means is that if you try to access the test results +for test level-2.1, it will may say that 'm' tests have run, 'n' tests +have been skipped, 'o' tests have passed and 'p' tests have failed, +where 'm', 'n', 'o', and 'p' refer to tests that were run at the same +test level as test level-1.1. +.PP +Implementation of output and error comparison in the test command +depends on usage of puts in your application code. Output is +intercepted by redefining the puts command while the defined test +script is being run. Errors thrown by C procedures or printed +directly from C applications will not be caught by the test command. +Therefore, usage of expect_out and expect_err in the test command is +useful only for pure Tcl applications that use the puts command for +output. .SH KEYWORDS test, test harness, test suite diff --git a/doc/tcltest2.n b/doc/tcltest2.n deleted file mode 100755 index 90c621f..0000000 --- a/doc/tcltest2.n +++ /dev/null @@ -1,1088 +0,0 @@ -'\" -'\" Copyright (c) 1990-1994 The Regents of the University of California -'\" Copyright (c) 1994-1997 Sun Microsystems, Inc. -'\" Copyright (c) 1998-1999 Scriptics Corporation -'\" Copyright (c) 2000 Ajuba Solutions -'\" -'\" 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.3 2000/10/19 18:00:55 jenn Exp $ -'\" -.so man.macros -.TH "tcltest" n 8.4 Tcl "Tcl Built-In Commands" -.BS -'\" Note: do not modify the .SH NAME line immediately below! -.SH NAME -tcltest \- Test harness support code and utilities -.SH SYNOPSIS -\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 -.sp -\fBtcltest::runAllTests\fR -.sp -\fBtcltest::interpreter \fI?interp?\fR -.sp -\fBtcltest::singleProcess \fI?boolean?\fR -.sp -\fBtcltest::debug \fI?level?\fR -.sp -\fBtcltest::verbose \fI?levelList?\fR -.sp -\fBtcltest::preserveCore \fI?level?\fR -.sp -\fBtcltest::testConstraint \fIconstraint ?value?\fR -.sp -\fBtcltest::limitConstraints \fI?constraintList?\fR -.sp -\fBtcltest::workingDirectory \fI?dir?\fR -.sp -\fBtcltest::temporaryDirectory \fI?dir?\fR -.sp -\fBtcltest::testsDirectory \fI?dir?\fR -.sp -\fBtcltest::match \fI?patternList?\fR -.sp -\fBtcltest::matchFiles \fI?patternList?\fR -.sp -\fBtcltest::matchDirectories \fI?patternList?\fR -.sp -\fBtcltest::skip \fI?patternList?\fR -.sp -\fBtcltest::skipFiles \fI?patternList?\fR -.sp -\fBtcltest::skipDirectories \fI?patternList?\fR -.sp -\fBtcltest::loadTestedCommands\fR -.sp -\fBtcltest::loadScript \fI?script?\fR -.sp -\fBtcltest::loadFile \fI?filename?\fR -.sp -\fBtcltest::outputChannel \fI?channelID?\fR -.sp -\fBtcltest::outputFile \fI?filename?\fR -.sp -\fBtcltest::errorChannel \fI?channelID?\fR -.sp -\fBtcltest::errorFile \fI?filename?\fR -.sp -\fBtcltest::makeFile \fIcontents name ?directory?\fR -.sp -\fBtcltest::removeFile \fIname ?directory?\fR -.sp -\fBtcltest::makeDirectory \fIname ?directory?\fR -.sp -\fBtcltest::removeDirectory \fIname ?directory?\fR -.sp -\fBtcltest::viewFile \fIname ?directory?\fR -.sp -\fBtcltest::normalizeMsg \fImsg\fR -.sp -\fBtcltest::normalizePath \fIpathVar\fR -.sp -\fBtcltest::bytestring \fIstring\fR -.sp -\fBtcltest::saveState\fR -.sp -\fBtcltest::restoreState\fR -.sp -\fBtcltest::threadReap\fR -.BE -.SH DESCRIPTION -.PP -The \fBtcltest\fR package provides the user with utility tools for -writing and running tests in the Tcl test suite. It can also be used -to create a customized test harness for an extension. -.PP -The Tcl test suite consists of multiple .test files, each of which -contains multiple test cases. Each test case consists of a call to -the test command, which specifies the name of test, a short -description, any constraints that apply to the test case, the script -to be run, and expected results. See the \fI"Tests"\fR section for more -details. -.PP -It is also possible to add to this test harness to create your own -customized test harness implementation. For more defails, see the -section \fI"How to Customize the Test Harness"\fR. -.SH COMMANDS -.TP -\fBtcltest::test\fP \fIname desc ?option value? ?option value? ...\fR -.TP -\fBtcltest::test\fP \fIname desc {?option value? ?option value? ...}\fR -The \fBtcltest::test\fR command runs the value supplied for attribute -\fIscript\fR and compares its result to possible results. -It prints an error message if actual results and expected results do -not match. The \fBtcltest::test\fR command returns 0 if it completes -successfully. Any other return value indicates that an error has -occurred in the tcltest package. See the \fI"Tests"\fR section for -more details on this command. -.TP -\fBtcltest::cleanupTests\fP \fI?runningMultipleTests?\fR -This command should be called at the end of a test file. It prints -statistics about the tests run and removes files that were created by -\fBtcltest::makeDirectory\fR and \fBtcltest::makeFile\fR. Names -of files and directories created outside of -\fBtcltest::makeFile\fR and \fBtcltest::makeDirectory\fR and -never deleted are printed to \fBtcltest::outputChannel\fR. This command -also restores the original shell environment, as described by the ::env -array. \fIcalledFromAll\fR should be specified if -\fBtcltest::cleanupTests\fR is called explicitly from an "all.tcl" -file. Tcl files files are generally used to run multiple tests. For -more details on how to run multiple tests, please see the section -\fI"Running test files"\fR. This proc has no defined return value. -.TP -\fBtcltest::runAllTests\fP -This command should be used in your 'all.tcl' file. It is used to -loop over test files and directories, determining which test files to -run and then running them. Note that this test calls -tcltest::cleanupTests; if using this proc in your 'all.tcl' file, you -should not call tcltest::cleanupTests explicitly in that file. See the -sample 'all.tcl' file in the \fI"Examples"\fR section. -.TP -\fBtcltest::interpreter\fR \fI?executableName?\fR -Sets or returns the name of the executable used to invoke the test -suite. This is the interpreter used in runAllTests to run test files -if singleProcess is set to false. The default value for interpreter -is the name of the interpreter in which the tests were started. -.TP -\fBtcltest::singleProcess\fR \fI?boolean?\fR -Sets or returns a boolean indicating whether test files should be sourced -into the current interpreter by runAllTests or run in their own -processes. If \fIboolean\fR is true (1), tests are sourced into the -current interpreter. If \fIboolean\fR is false (0), tests are run in -the interpreter specified in tcltest::interpreter. The default value -for tcltest::singleProcess is false. -.TP -\fBtcltest::debug\fR \fI?level?\fR -Sets or returns the current debug level. The debug level determines -how much tcltest package debugging information is printed to stdout. -The default debug level is 0. Levels are defined as: -.RS -.IP 0 -Do not display any debug information. -.IP 1 -Display information regarding whether a test is skipped because it -doesn't match any of the tests that were specified using -match or -tcltest::match (userSpecifiedNonMatch) or matches any of the tests -specified by -skip or tcltest::skip (userSpecifiedSkip). -.IP 2 -Display the flag array parsed by the command line processor, the -contents of the ::env array, and all user-defined variables that exist -in the current namespace as they are used. -.IP 3 -Display information regarding what individual procs in the test -harness are doing. -.RE -.TP -\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 body -Display the body of failed tests -.IP pass -Print output when a test passes -.IP skip -Print output when a test is skipped -.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 -Sets or returns the current core preservation level. This level -determines how stringent checks for core files are. The default core -preservation level is 0. Levels are defined as: -.RS -.IP 0 -No checking - do not check for core files at the end of each test -command, but do check for them whenever tcltest::cleanupTests is -called from tcltest::runAllTests. -.IP 1 -Check for core files at the end of each test command and whenever -tcltest::cleanupTests is called from tcltest::runAllTests. -.IP 2 -Check for core files at the end of all test commands and whenever -tcltest::cleanupTests is called from all.tcl. Save any core files -produced in tcltest::temporaryDirectory. -.RE -.TP -\fBtcltest::testConstraint \fIconstraint ?value?\fR -Sets or returns the value associated with the named \fIconstraint\fR. -See the section \fI"Test constraints"\fR for more information. -.TP -\fBtcltest::limitConstraints \fI?constraintList?\fR -Sets or returns a boolean indicating whether testing is being limited -to constraints listed in \fIconstraintList\fR. -If limitConstraints is not false, only those tests with constraints matching -values in \fIconstraintList\fR will be run. -.TP -\fBtcltest::workingDirectory\fR \fI?directoryName?\fR -Sets or returns the directory in which the test suite is being run. -The default value for workingDirectory is the directory in which the -test suite was launched. -.TP -\fBtcltest::temporaryDirectory\fR \fI?directoryName?\fR -Sets or returns the output directory for temporary files created by -tcltest::makeFile and tcltest::makeDirectory. This defaults to the -directory returned by \fItcltest::workingDirectory\fR. -.TP -\fBtcltest::testsDirectory\fR \fI?directoryName?\fR -Sets or returns the directory where the tests reside. This defaults -to the directory returned by \fItcltest::workingDirectory\fR -if the script cannot determine where the \fItests\fR directory is -located. This variable should be explicitly set if tests are being run -from an all.tcl file. -.TP -\fBtcltest::match\fR \fI?globPatternList?\fR -Sets or returns the glob pattern list that determines which tests -should be run. Only tests which match one of the glob patterns in -\fIglobPatternList\fR are run by the test harness. The default value -for \fIglobPatternList\fR is '*'. -.TP -\fBtcltest::matchFiles\fR \fI?globPatternList?\fR -Sets or returns the glob pattern list that determines which test files -should be run. Only test files which match one of the glob patterns in -\fIglobPatternList\fR are run by the test harness. The default value -for \fIglobPatternList\fR is '*.test'. -.TP -\fBtcltest::matchDirectories\fR \fI?globPatternList?\fR -Sets or returns the glob pattern list that determines which test -subdirectories of the current test directory should be run. Only test -subdirectories which match one of the glob patterns in -\fIglobPatternList\fR are run by the test harness. The default value -for \fIglobPatternList\fR is '*'. -.TP -\fBtcltest::skip\fR \fI?globPatternList?\fR -Sets or returns the glob pattern list that determines which tests (of -those matched by tcltest::match) should be skipped. The default value -for \fIglobPatternList\fR is {}. -.TP -\fBtcltest::skipFiles\fR \fI?globPatternList?\fR -Sets or returns the glob pattern list that determines which test files -(of those matched by tcltest::matchFiles) should be skipped. The -default value for \fIglobPatternList\fR is {}. -.TP -\fBtcltest::skipDirectories\fR \fI?globPatternList?\fR -Sets or returns the glob pattern list that determines which test -subdirectories (of those matched by tcltest::matchDirectories) should -be skipped. The default value for \fIglobPatternList\fR is {}. -.TP -\fBtcltest::loadTestedCommands\fP -This command uses the script specified via the \fI-load\fR or -\fI-loadfile\fR options or the tcltest::loadScript or -tcltest::loadFile procs to load the commands checked by the test suite. -It is allowed to be empty, as the tested commands could have been -compiled into the interpreter running the test suite. -.TP -\fBtcltest::loadScript\fR \fI?script?\fR -Sets or returns the script executed by \fBloadTestedCommands\fR. -.TP -\fBtcltest::loadFile\fR \fI?filename?\fR -Sets ore returns the file name associated with the script executed -\fBloadTestedCommands\fR. If setting \fIfilename\fR, this proc will -open the file and call \fItcltest::loadScript\fR with the content. -.TP -\fBtcltest::outputChannel\fR \fI?channelID?\fR -Sets or returns the output file ID. This defaults to stdout. -Any test that prints test related output should send -that output to \fItcltest::outputChannel\fR rather than letting -that output default to stdout. -.TP -\fBtcltest::outputFile\fR \fI?filename?\fR -Sets or returns the file name corresponding to the output file. This -defaults to stdout. This proc calls -outputChannel to set the output file channel. -Any test that prints test related output should send -that output to \fItcltest::outputChannel\fR rather than letting -that output default to stdout. -.TP -\fBtcltest::errorChannel\fR \fI?channelID?\fR -Sets or returns the error file ID. This defaults to stderr. -Any test that prints error messages should send -that output to \fItcltest::errorChannel\fR rather than printing -directly to stderr. -.TP -\fBtcltest::errorFile\fR \fI?filename?\fR -Sets or returns the file name corresponding to the error file. This -defaults to stderr. This proc calls -errorChannel to set the error file channel. -Any test that prints test related error output should send -that output to \fItcltest::errorChannel\fR or -\fItcltest::outputChannel\fR rather than letting -that output default to stdout. -.TP -\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 \fIdirectory\fR. If left unspecified, -\fIdirectory\fR defaults to tcltest::temporaryDirectory. -Returns the full path of the file created. -.TP -\fBtcltest::removeFile\fP \fIname ?directory?\fR -Force the file referenced by \fIname\fR to be removed. This file name -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 ?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. -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 \fIdirectory\fR. If left unspecified, -\fIdirectory\fR defaults to tcltest::temporaryDirectory. This proc -has no defined return value. -.TP -\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. -.TP -\fBtcltest::normalizePath\fP \fIpathVar\fR -Resolves symlinks in a path, thus creating a path without internal -redirection. It is assumed that \fIpathVar\fR is absolute. -\fIpathVar\fR is modified in place. -.TP -\fBtcltest::bytestring\fP \fIstring\fR -Construct a string that consists of the requested sequence of bytes, -as opposed to a string of properly formed UTF-8 characters using the -value supplied in \fIstring\fR. This allows the tester to create -denormalized or improperly formed strings to pass to C procedures that -are supposed to accept strings with embedded NULL types and confirm -that a string result has a certain pattern of bytes. -.TP -\fBtcltest::saveState\fP -Save procedure and global variable names. -A test file might contain calls to \fBtcltest::saveState\fR and -\fB::tcltest:restoreState\fR if it creates or deletes global variables -or procs. -.TP -\fBtcltest::restoreState\fP -Restore procedure and global variable names. -A test file might contain calls to \fBtcltest::saveState\fR and -\fB::tcltest:restoreState\fR if it creates or deletes global variables -or procs. -.TP -\fBtcltest::threadReap\fP -\fBtcltest::threadReap\fR only works if \fItestthread\fR is -defined, generally by compiling tcltest. If \fItestthread\fR is -defined, \fBtcltest::threadReap\fR kills all threads except for the -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. -Two syntaxes are provided for specifying the attributes of the tests. -The first uses a separate argument for each of the attributes and -values. The second form places all of the attributes and values -together into a single argument; the argument must have proper list -structure, with teh elements of the list being the attributes and -values. The second form makes it easy to construct multi-line -scripts, since the braces around the whole list make it unnecessary to -include a backslash at the end of each line. In the second form, no -command or variable substitutions are performed on the attribute -names. This makes the behavior of the second form different from the -first form in some cases. -.PP -The first form for the \fBtest\fR command: -.DS -test \fIname\fR \fIdescription\fR - ?-constraints \fIkeywordList|expression\fR - ?-setup \fIsetupScript\fR? - ?-body \fItestScript\fR? - ?-cleanup \fIcleanupScript\fR? - ?-result \fIexpectedAnswer\fR? - ?-output \fIexpectedOutput\fR? - ?-errorOutput \fIexpectedError\fR? - ?-returnCodes \fIcodeList\fR? - ?-match \fIexact|glob|regexp\fR? -.DE -.PP -The second form for the \fBtest\fR command: -.DS -test \fIname\fR \fIdescription\fR { - ?-constraints \fIkeywordList|expression\fR - ?-setup \fIsetupScript\fR? - ?-body \fItestScript\fR? - ?-cleanup \fIcleanupScript\fR? - ?-result \fIexpectedAnswer\fR? - ?-output\fIexpectedOutput\fR? - ?-errorOutput \fIexpectedError\fR? - ?-returnCodes \fIcodeList\fR? - ?-match \fIexact|glob|regexp? -} -.DE -The \fIname\fR argument should follow the pattern: -.DS -<target>-<majorNum>.<minorNum> -.DE -For white-box (regression) tests, the target should be the name of the -C function or Tcl procedure being tested. For black-box tests, the -target should be the name of the feature being tested. Related tests -should share a major number. -.PP -The \fIdescription\fR should be a short textual description of the -test. It is generally used to help humans -understand the purpose of the test. The name of a Tcl or C function -being tested should be included in the description for regression -tests. If the test case exists to reproduce a bug, include the bug ID -in the description. -.PP -Valid attributes and associated values are: -.TP -\fB-constraints \fIkeywordList|expression\fR\fP -The optional \fIconstraints\fR attribute can be list of one or more -keywords or an expression. If the \fIconstraints\fR value consists of -keywords, each of these keywords being the name of a constraint -defined by a call to \fItcltest::testConstraint\fR. If any of these -elements is false or does -not exist, the test is skipped. If the \fIconstraints\fR argument -consists of an expression, that expression is evaluated. If the -expression evaluates to true, then the test is run. Appropriate -constraints should be added to any tests that should -not always be run. See the "Test Constraints" section for a list of built-in -constraints and information on how to add your own constraints. -.TP -\fB-setup \fIscript\fR\fP -The optional \fIsetup\fR attribute indicates a script that will be run -before the script indicated by the \fIscript\fR attribute. If setup -fails, the test will fail. -.TP -\fB-body \fIscript\fR\fP -The \fIbody\fR attribute indicates the script to run to carry out the -test. It must return a result that can be checked for correctness. -If left unspecified, the script value will be {}. -.TP -\fB-cleanup \fIscript\fR\fP -The optional \fIcleanup\fR attribute indicates a script that will be -run after the script indicated by the \fIscript\fR attribute. If -cleanup fails, the test will fail. -.TP -\fB-match \fIregexp|glob|exact\fP -The \fImatch\fR attribute determines how expected answers supplied in -\fIresult\fR, \fIoutput\fR, and \fRerrorOutput\fR are compared. Valid -options for the value supplied are "regexp", "glob", and -"exact". If \fImatch\fR is not specified, the comparisons will be -done in "exact" mode by default. -.TP -\fB-result \fIexpectedValue\fR\fP -The \fIresult\fR attribute supplies the comparison value with which -the return value from script will be compared. -If left unspecified, the default -\fIexpectedValue\fR will be the empty list. -.TP -\fB-output \fIexpectedValue\fR\fP -The \fIoutput\fR attribute supplies the comparison value with which -any output sent to stdout or tcltest::outputChannel during the script -run will be compared. Note that only output printed using -puts is used for comparison. If \fIoutput\fR is not specified, output -sent to stdout and tcltest::outputChannel is not processed for comparison. -.TP -\fB-errorOutut \fIexpectedValue\fR\fP -The \fIerrorOutput\fR attribute supplies the comparison value with which -any output sent to stderr or tcltest::errorChannel during the script -run will be compared. Note that only output printed using -puts is used for comparison. If \fIerrorOutut\fR is not specified, output -sent to stderr and tcltest::errorChannel is not processed for comparison. -.TP -\fB-returnCodes \fIexpectedCodeList\fR\fP -The optional \fIreturnCodes\fR attribute indicates which return codes -from the script supplied with the \fIscript\fR attribute are correct. -Default values for \fIexpectedCodeList\fR are 0 (normal return) and 2 -(return exception). Symbolic values \fInormal\fR (0), \fIerror\fR -(1), \fIreturn\fR (2), \fIbreak\fR (3), and \fIcontinue\fR (4) can be -used in the \fIexpectedCodeList\fR list. -.PP -To pass, a test must successfully execute its setup, script, and -cleanup code. The return code of the test and its return values must -match expected values, and if specified, output and error data from -the test must match expected output and error values. If all of these -conditions are not met, then the test fails. -.SH "TEST CONSTRAINTS" -Constraints are used to determine whether or not a test should be skipped. -If a test is constrained by "unixOnly", then it will only be run if -the value of the constraint is true. Several -constraints are defined in the \fBtcltest\fR package. To add -constraints, you can call \fBtcltest::testConstraint\fR -with the appropriate arguments in your own test file. -.PP -The following is a list of constraints defined in the \fBtcltest\fR package: -.TP -\fIsingleTestInterp\fR -test can only be run if all test files are sourced into a single interpreter -.TP -\fIunix\fR -test can only be run on any UNIX platform -.TP -\fIwin\fR -test can only be run on any Windows platform -.TP -\fInt\fR -test can only be run on any Windows NT platform -.TP -\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 -\fIunixOrWin\fR -test can only be run on a UNIX or Windows platform -.TP -\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 -\fItempNotWin\fR -test can not be run on Windows. This flag is used to temporarily -disable a test. -.TP -\fItempNotMac\fR -test can not be run on a Mac. This flag is used -to temporarily disable a test. -.TP -\fIunixCrash\fR -test crashes if it's run on UNIX. This flag is used to temporarily -disable a test. -.TP -\fIwinCrash\fR -test crashes if it's run on Windows. This flag is used to temporarily -disable a test. -.TP -\fImacCrash\fR -test crashes if it's run on a Mac. This flag is used to temporarily -disable a test. -.TP -\fIemptyTest\fR -test is empty, and so not worth running, but it remains as a -place-holder for a test to be written in the future. This constraint -always causes tests to be skipped. -.TP -\fIknownBug\fR -test is known to fail and the bug is not yet fixed. This constraint -always causes tests to be skipped unless the user specifies otherwise. -See the "Introduction" section for more details. -.TP -\fInonPortable\fR -test can only be run in the master Tcl/Tk development environment. -Some tests are inherently non-portable because they depend on things -like word length, file system configuration, window manager, etc. -These tests are only run in the main Tcl development directory where -the configuration is well known. This constraint always causes tests -to be skipped unless the user specifies otherwise. -.TP -\fIuserInteraction\fR -test requires interaction from the user. This constraint always -causes tests to be skipped unless the user specifies otherwise. -.TP -\fIinteractive\fR -test can only be run in if the interpreter is in interactive mode -(when the global tcl_interactive variable is set to 1). -.TP -\fInonBlockFiles\fR -test can only be run if platform supports setting files into -nonblocking mode -.TP -\fIasyncPipeClose\fR -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 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 -.TP -\fIroot\fR -test can only run if Unix user is root -.TP -\fInotRoot\fR -test can only run if Unix user is not root -.TP -\fIeformat\fR -test can only run if app has a working version of sprintf with respect -to the "e" format of floating-point numbers. -.TP -\fIstdio\fR -test can only be run if the current app can be spawned via a pipe -.SH "RUNNING TEST FILES" -Use the following command to run a test file that uses package -tcltest: -.DS -<shell> <testFile> ?<option> ?<value>?? ... -.DE -Command line options include (tcltest accessor procs 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-singleproc <bool>\fR -if <bool> is 0, run test files in separate interpreters. if 1, source test -files into the current intpreter. (tcltest::singleProcess) -.TP -\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 -<matchList>. (tcltest::match) -.TP -\fB-skip <skipList>\fR -do not run tests that match one or more of the glob patterns in -<skipList>. (tcltest::skip) -.TP -\fB-file <globPatternList>\fR -only source test files that match any of the items in -<globPatternList> relative to tcltest::testsDirectory. -This option -only makes sense if you are running tests using "all.tcl" as the -<testFile> instead of running single test files directly. -(tcltest::matchFiles) -.TP -\fB-notfile <globPatternList>\fR -source files except for those that match any of the items in -<globPatternList> relative to tcltest::testsDirectory. -This option -only makes sense if you are running tests using "all.tcl" as the -<testFile> instead of running single test files directly. -(tcltest::skipFiles) -.TP -\fB-relateddir <globPatternList>\fR -only run tests in directories that match any of the items in -<globPatternList> relative to tcltest::testsDirectory. -This option -only makes sense if you are running tests using "all.tcl" as the -<testFile> instead of running single test files directly. -(tcltest::matchDirectories) -.TP -\fB-asidefromdir <globPatternList>\fR -run tests in directories except for those that match any of the items in -<globPatternList> relative to tcltest::testsDirectory. -This option -only makes sense if you are running tests using "all.tcl" as the -<testFile> instead of running single test files directly. -(tcltest::skipDirectories) -.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. This -is useful if you want to make sure that tests with a particular -constraint are run (for example, if the tester wants to run all tests -with the knownBug constraint). -(tcltest::testConstraint) -.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). This is useful if you want -to run \fBonly\fR those tests that match the constraints listed using -the -constraints option. A tester might want to do this if (for -example) he were -interested in running only those tests that are constrained to be -unixOnly and no other tests. -(tcltest::limitConstraints) -.TP -\fB-load <script>\fR -will use the specified script to load the commands under test -(tcltest::loadTestedCommands). The default is the empty -script. See -loadfile below too. (tcltest::loadScript) -.TP -\fB-loadfile <scriptfile>\fR -will use the contents of the named file to load the commands under -test (tcltest::loadTestedCommands). See -load above too. The default -is the empty script. (tcltest::loadFile) -.TP -\fB-tmpdir <directoryName>\fR -put any temporary files (created with tcltest::makeFile and -tcltest::makeDirectory) into the named directory. The default -location is tcltest::workingDirectory. (tcltest::temporaryDirectory) -.TP -\fB-testdir <directoryName>\fR -search the test suite to execute in the named directory. The default -location is tcltest::workingDirectory. (tcltest::testsDirectory) -.TP -\fB-preservecore <level>\fR -check for core files. This flag is used to determine how much -checking should be done for core files. (tcltest::preserveCore) -.TP -\fB-debug <debugLevel>\fR -print debug information to stdout. This is used to debug code in the -tcltest package. (tcltest::debug) -.TP -\fB-outfile <filename>\fR -print output generated by the tcltest package to the named file. This -defaults to stdout. Note that debug output always goes to stdout, -regardless of this flag's setting. (tcltest::outputFile) -.TP -\fB-errfile <filename>\fR -print errors generated by the tcltest package to the named file. This -defaults to stderr. (tcltest::errorFile) -.RE -.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 '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 -\fBtcltest\fR package, and then source an appropriate test file or use -the test command. To use the options in interactive mode, set -their corresponding tcltest namespace variables after loading the -package. -.PP -See \fI"Test Constraints"\fR for a list of all built-in constraint names. -.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 -approach used by the Tcl test suite. This file loads the tcltest -package, sets the location of -the test directory (tcltest::testsDirectory), and then calls the -\fItcltest::runAllTests\fR proc, which determines which test -files to run, how to run them, and calls tcltest::cleanupTests to -determine the summary status of the test suite. -.PP -A more elaborate \fIall.tcl\fR file might do some pre- and -post-processing before sourcing -each .test file, use separate interpreters for each file, or handle -complex directory structures. -For an example of an all.tcl file, -please see the "Examples" section of this document. -.SH "TEST OUTPUT" -After all specified test files are run, the number of tests -passed, skipped, and failed is printed to -\fBtcltest::outputChannel\fR. Aside from this -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 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 "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 "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 'body pass skip' -.DE -.SH "CONTENTS OF A TEST FILE" -Test files should begin by loading the \fBtcltest\fR package: -.DS -package require tcltest -namespace import -force tcltest::* -.DE -Test files should end by cleaning up after themselves and calling -\fBtcltest::cleanupTests\fR. The \fBtcltest::cleanupTests\fR -procedure prints statistics about the number of tests that passed, -skipped, and failed, and removes all files that were created using the -\fBtcltest::makeFile\fR and \fBtcltest::makeDirectory\fR procedures. -.DS -# Remove files created by these tests -# Change to original working directory -# Unset global arrays -tcltest::cleanupTests -return -.DE -When naming test files, file names should end with a .test extension. -The names of test files that contain regression (or glass-box) tests -should correspond to the Tcl or C code file that they are testing. -For example, the test file for the C file "tclCmdAH.c" is "cmdAH.test". -.SH "SELECTING TESTS FOR EXECUTION" -.PP -Normally, all the tests in a file are run whenever the file is -sourced. An individual test will be skipped if one of the following -conditions is met: -.IP [1] -the \fIname\fR of the tests does not match (using glob style matching) -one or more elements in the \fBtcltest::match\fR variable -.IP [2] -the \fIname\fR of the tests matches (using glob style matching) one or -more elements in the \fBtcltest::skip\fR variable -.IP [3] -the \fIconstraints\fR argument to the \fBtcltest::test\fR call, if -given, contains one or more false elements. -.PP -You can set \fBtcltest::match\fR and/or \fBtcltest::skip\fR -either interactively (after the \fBtcltest\fR package has been -sourced), or by using the command line arguments \fB-match\fR and -\fB-skip\fR, for example: -.PP -.CS -tclsh info.test -match '*-5.* *-7.*' -skip '*-7.1*' -.CE -.PP -Be sure to use the proper quoting convention so that your shell does -not perform the glob substitution on the match or skip patterns you -specify. -.PP -Predefined constraints (e.g. \fIknownBug\fR and \fInonPortable\fR) can be -overridden either interactively (after the \fBtcltest\fR package has been -sourced) by setting the proper constraint -or by using the \fB-constraints\fR command line option with the name of the -constraint in the argument. The following example shows how to run -tests that are constrained by the \fIknownBug\fR and \fInonPortable\fR -restrictions: -.PP -.CS -tclsh all.tcl -constraints "knownBug nonPortable" -.CE -.PP -See the \fI"Constraints"\fR section for information about using -built-in constraints and adding new ones. -.PP -When tests are run from within an 'all.tcl' file, all files with a -'.test' extension are normally run. An individual test file will be -skipped if one of the following conditions is met: -.IP [1] -the \fIname\fR of the test files does not match (using glob style matching) -one or more elements in the \fBtcltest::matchFiles\fR variable -.IP [2] -the \fIname\fR of the test file matches (using glob style matching) one or -more elements in the \fBtcltest::skipFiles\fR variable -.PP -You can set \fBtcltest::matchFiles\fR and/or \fBtcltest::skipFiles\fR -either interactively (after the \fBtcltest\fR package has been -sourced), or by using the command line arguments \fB-file\fR and -\fB-notfile\fR, for example: -.PP -.CS -tclsh info.test -file 'unix*.test' -notfile 'unixNotfy.test' -.CE -.PP -Additionally, if tests are run from within an 'all.tcl' containing a -call to \fBtcltest::runAllTests\fR, any subdirectory of -\fItcltest::testsDirectory\fR containing an 'all.tcl' file will also -be run. Individual test subdirectories will be skipped if one of the -following conditions is met: -.IP [1] -the \fIname\fR of the directory does not match (using glob style matching) -one or more elements in the \fBtcltest::matchDirectories\fR variable -.IP [2] -the \fIname\fR of the directory matches (using glob style matching) one or -more elements in the \fBtcltest::skipDirectories\fR variable -.PP -You can set \fBtcltest::matchDirectories\fR and/or \fBtcltest::skipDirectories\fR -either interactively (after the \fBtcltest\fR package has been -sourced), or by using the command line arguments \fB-relateddir\fR and -\fB-asidefromdir\fR, for example: -.PP -.CS -tclsh info.test -relateddir 'subdir*' -asidefromdir 'subdir2' -.CE -.SH "HOW TO CUSTOMIZE THE TEST HARNESS" -To create your own custom test harness, create a .tcl file that contains your -namespace. Within this file, require package \fBtcltest\fR. Commands -that can be redefined to customize the test harness include: -.TP -\fBtcltest::PrintUsageInfoHook\fP -print additional usage information specific to your situation. -.TP -\fBtcltest::processCmdLineArgsFlagHook\fP -tell the test harness about additional flags that you want it to understand. -.TP -\fBtcltest::processCmdLineArgsHook\fR \fIflags\fP -process the additional flags that you told the harness about in -tcltest::processCmdLineArgsFlagHook. -.TP -\fBtcltest::initConstraintsHook\fP -used to add additional built-in constraints to those already defined -by \fBtcltest\fR. -.TP -\fBtcltest::cleanupTestsHook\fP -do additional cleanup -.PP -.PP -To add new flags to your customized test harness, redefine -\fBtcltest::processCmdLineArgsAddFlagHook\fR to define additional flags to be -parsed and \fBtcltest::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 -You may also want to add usage information for these flags. This -information would be displayed whenever the user specifies -help. To -define additional usage information, define your own -tcltest::PrintUsageInfoHook proc. Within this proc, you should -print out additional usage information for any flags that you've -implemented. -.PP -To add new built-in -constraints to the test harness, define your own version of -\fBtcltest::initConstraintsHook\fR. -Within your proc, you can add to the \fBtcltest::testConstraints\fR array. -For example: -.DS -proc tcltest::initConstraintsHook {} { - set tcltest::testConstraints(win95Or98) \\ - [expr {$tcltest::testConstraints(95) || \\ - $tcltest::testConstraints(98)}] -} -.DE -.PP -Finally, if you want to add additional cleanup code to your harness -you can define your own \fBtcltest::cleanupTestsHook\fR. For example: -.DS -proc tcltest::cleanupTestsHook {} { - # Add your cleanup code here -} -.DE -.SH EXAMPLES -.IP [1] -A simple test file (foo.test) -.DS -package require tcltest -namespace import -force ::tcltest::* - -test foo-1.1 {save 1 in variable name foo} -body {set foo 1} -result 1 - -tcltest::cleanupTests -return -.DE -.IP [2] -A simple all.tcl -.DS -package require tcltest -namespace import -force ::tcltest::* - -tcltest::testsDirectory [file dir [info script]] -tcltest::runAllTests - -return -.DE -.IP [3] -Running a single test -.DS -tclsh foo.test -.DE -.IP [4] -Running multiple tests -.DS -tclsh all.tcl -file 'foo*.test' -notfile 'foo2.test' -.DE -.IP [5] -A test that uses the unixOnly constraint and should only be -run on Unix -.DS -test getAttribute-1.1 {testing file permissions} { - -constraints {unixOnly} - -body { - lindex [file attributes foo.tcl] 5 - } - -result {00644} -} -.DE -.IP [6] -A test containing an constraint expression that evaluates to true (a case where the test would be run) if it is being run on unix and if threads are not being tested -.DS -test testOnUnixWithoutThreads-1.1 { - this test runs only on unix and only if we're not testing - threads -} { - -constraints {unixOnly && !testthread} - -body { - # some script goes here - } -} -.DE -.SH "KNOWN ISSUES" -There are two known issues related to nested test commands. -The first issue relates to the stack level in which test scripts are -executed. Tests nested within other tests may be executed at the same -stack level as the outermost test. For example, in the following test -code: -.DS -test level-1.1 {level 1} { - -body { - test level-2.1 {level 2} { - } - } -} -.DE -any script executed in level-2.1 may be executed at the same stack -level as the script defined for level-1.1. -.PP -In addition, while two -test commands have been run, results will only be reported for tests -at the same level as test level-1.1. However, test results for all -tests run prior to level-1.1 will be available when test level-2.1 -runs. What this means is that if you try to access the test results -for test level-2.1, it will may say that 'm' tests have run, 'n' tests -have been skipped, 'o' tests have passed and 'p' tests have failed, -where 'm', 'n', 'o', and 'p' refer to tests that were run at the same -test level as test level-1.1. -.PP -Implementation of output and error comparison in the test command -depends on usage of puts in your application code. Output is -intercepted by redefining the puts command while the defined test -script is being run. Errors thrown by C procedures or printed -directly from C applications will not be caught by the test command. -Therefore, usage of expect_out and expect_err in the test command is -useful only for pure Tcl applications that use the puts command for -output. -.SH KEYWORDS -test, test harness, test suite - diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index e3746e2..da93644 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -8,5 +8,4 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded tcltest 1.0 [list source [file join $dir tcltest.tcl]] -package ifneeded tcltest 2.0 [list source [file join $dir tcltest2.tcl]] +package ifneeded tcltest 2.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 63639e3..80f80c7 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1,7 +1,7 @@ # tcltest.tcl -- # # This file contains support code for the Tcl test suite. It -# defines the ::tcltest namespace and finds and defines the output +# defines the tcltest namespace and finds and defines the output # directory, constraints available, output and error channels, etc. used # by Tcl tests. See the tcltest man page for more details. # @@ -10,11 +10,10 @@ # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.27 2000/09/06 18:50:15 hobbs Exp $ - -package provide tcltest 1.0 +# RCS: @(#) $Id: tcltest.tcl,v 1.28 2000/10/24 22:30:32 jenn Exp $ # create the "tcltest" namespace for all testing variables and procedures @@ -23,19 +22,25 @@ namespace eval tcltest { # Export the public tcltest procs set procList [list test cleanupTests saveState restoreState \ normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring safeFetch threadReap getMatchingFiles \ - loadTestedCommands normalizePath] + viewFile bytestring threadReap debug testConstraint \ + limitConstraints loadTestedCommands normalizePath verbose match \ + skip matchFiles skipFiles preserveCore loadScript loadFile \ + mainThread workingDirectory singleProcess interpreter runAllTests \ + outputChannel outputFile errorChannel \ + errorFile temporaryDirectory testsDirectory matchDirectories \ + skipDirectories ] foreach proc $procList { namespace export $proc } - # ::tcltest::verbose defaults to "b" + # tcltest::verbose defaults to {body} if {![info exists verbose]} { - variable verbose "b" + variable verbose {body} } # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory + # matchFiles, which defaults to all .test files in the testsDirectory and + # matchDirectories, which defaults to all directories. if {![info exists match]} { variable match {} @@ -49,6 +54,12 @@ namespace eval tcltest { if {![info exists skipFiles]} { variable skipFiles {} } + if {![info exists matchDirectories]} { + variable matchDirectories {*} + } + if {![info exists skipDirectories]} { + variable skipDirectories {} + } # By default, don't save core files if {![info exists preserveCore]} { @@ -59,11 +70,17 @@ namespace eval tcltest { if {![info exists outputChannel]} { variable outputChannel stdout } + if {![info exists outputFile]} { + variable outputFile stdout + } # errors go to stderr by default if {![info exists errorChannel]} { variable errorChannel stderr } + if {![info exists errorFile]} { + variable errorFile stderr + } # debug output doesn't get printed by default; debug level 1 spits # up only the tests that were skipped because they didn't match or were @@ -81,9 +98,9 @@ namespace eval tcltest { variable parameters {} } - # Count the number of files tested (0 if all.tcl wasn't called). - # The all.tcl file will set testSingleFile to false, so stats will - # not be printed until all.tcl calls the cleanupTests proc. + # Count the number of files tested (0 if runAllTests wasn't called). + # runAllTests will set testSingleFile to false, so stats will + # not be printed until runAllTests calls the cleanupTests proc. # The currentFailure var stores the boolean value of whether the # current test file has had any failures. The failFiles list # stores the names of test files that had failures. @@ -103,9 +120,9 @@ namespace eval tcltest { # Tests should remove all files they create. The test suite will # check the current working dir for files created by the tests. - # ::tcltest::filesMade keeps track of such files created using the - # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. - # ::tcltest::filesExisted stores the names of pre-existing files. + # tcltest::filesMade keeps track of such files created using the + # tcltest::makeFile and tcltest::makeDirectory procedures. + # tcltest::filesExisted stores the names of pre-existing files. if {![info exists filesMade]} { variable filesMade {} @@ -114,43 +131,47 @@ namespace eval tcltest { variable filesExisted {} } - # ::tcltest::numTests will store test files as indices and the list + # tcltest::numTests will store test files as indices and the list # of files (that should not have been) left behind by the test files. if {![info exists createdNewFiles]} { variable createdNewFiles - array set ::tcltest::createdNewFiles {} + array set tcltest::createdNewFiles {} } - # initialize ::tcltest::numTests array to keep track fo the number of + # initialize tcltest::numTests array to keep track fo the number of # tests that pass, fail, and are skipped. if {![info exists numTests]} { variable numTests - array set ::tcltest::numTests \ + array set tcltest::numTests \ [list Total 0 Passed 0 Skipped 0 Failed 0] } - # initialize ::tcltest::skippedBecause array to keep track of + # initialize tcltest::skippedBecause array to keep track of # constraints that kept tests from running; a constraint name of # "userSpecifiedSkip" means that the test appeared on the list of tests # that matched the -skip value given to the flag; "userSpecifiedNonMatch" # means that the test didn't match the argument given to the -match flag; - # both of these constraints are counted only if ::tcltest::debug is set to + # both of these constraints are counted only if tcltest::debug is set to # true. if {![info exists skippedBecause]} { variable skippedBecause - array set ::tcltest::skippedBecause {} + array set tcltest::skippedBecause {} } - # initialize the ::tcltest::testConstraints array to keep track of valid + # initialize the tcltest::testConstraints array to keep track of valid # predefined constraints (see the explanation for the - # ::tcltest::initConstraints proc for more details). + # tcltest::initConstraints proc for more details). if {![info exists testConstraints]} { variable testConstraints - array set ::tcltest::testConstraints {} + array set tcltest::testConstraints {} + } + + if {![info exists constraintsSpecified]} { + variable constraintsSpecified {} } # Don't run only the constrained tests by default @@ -166,6 +187,11 @@ namespace eval tcltest { variable loadScript {} } + # and the filename of the script file, if it exists + if {![info exists loadFile]} { + variable loadFile {} + } + # tests that use threads need to know which is the main thread if {![info exists mainThread]} { @@ -181,10 +207,10 @@ namespace eval tcltest { if {![info exists originalEnv]} { variable originalEnv - array set ::tcltest::originalEnv [array get ::env] + array set tcltest::originalEnv [array get ::env] } - # Set ::tcltest::workingDirectory to [pwd]. The default output directory + # Set tcltest::workingDirectory to [pwd]. The default output directory # for Tcl tests is the working directory. if {![info exists workingDirectory]} { @@ -196,7 +222,7 @@ namespace eval tcltest { # Tests should not rely on the current working directory. # Files that are part of the test suite should be accessed relative to - # ::tcltest::testsDirectory. + # tcltest::testsDirectory. if {![info exists testsDirectory]} { set oldpwd [pwd] @@ -206,30 +232,40 @@ namespace eval tcltest { unset oldpwd } - # the variables and procs that existed when ::tcltest::saveState was + # Default is to run each test file in a separate process + if {![info exists singleProcess]} { + variable singleProcess 0 + } + + # the variables and procs that existed when tcltest::saveState was # called are stored in a variable of the same name if {![info exists saveState]} { variable saveState {} } - # Internationalization support + # Internationalization support -- used in tcltest::set_iso8859_1_locale + # and tcltest::restore_locale. Those commands are used in cmdIL.test. + if {![info exists previousLocale]} { + variable previousLocale + } + if {![info exists isoLocale]} { variable isoLocale fr - switch $tcl_platform(platform) { + switch -- $tcl_platform(platform) { "unix" { # Try some 'known' values for some platforms: switch -exact -- $tcl_platform(os) { "FreeBSD" { - set ::tcltest::isoLocale fr_FR.ISO_8859-1 + set tcltest::isoLocale fr_FR.ISO_8859-1 } HP-UX { - set ::tcltest::isoLocale fr_FR.iso88591 + set tcltest::isoLocale fr_FR.iso88591 } Linux - IRIX { - set ::tcltest::isoLocale fr + set tcltest::isoLocale fr } default { @@ -237,12 +273,12 @@ namespace eval tcltest { # define it to something else on your system #if you want to test those. - set ::tcltest::isoLocale iso_8859_1 + set tcltest::isoLocale iso_8859_1 } } } "windows" { - set ::tcltest::isoLocale French + set tcltest::isoLocale French } } } @@ -250,7 +286,7 @@ namespace eval tcltest { # Set the location of the execuatble if {![info exists tcltest]} { variable tcltest [info nameofexecutable] - } + } # save the platform information so it can be restored later if {![info exists originalTclPlatform]} { @@ -259,29 +295,34 @@ namespace eval tcltest { # If a core file exists, save its modification time. if {![info exists coreModificationTime]} { - if {[file exists [file join $::tcltest::workingDirectory core]]} { + if {[file exists [file join $tcltest::workingDirectory core]]} { variable coreModificationTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + $tcltest::workingDirectory core]] } } - # Tcl version numbers - if {![info exists version]} { - variable version 8.4 + # stdout and stderr buffers for use when we want to store them + if {![info exists outData]} { + variable outData {} } - if {![info exists patchLevel]} { - variable patchLevel 8.4a2 + if {![info exists errData]} { + variable errData {} } + + # keep track of test level for nested test commands + variable testLevel 0 } -# ::tcltest::Debug* -- +##################################################################### + +# tcltest::Debug* -- # # Internal helper procedures to write out debug information # dependent on the chosen level. A test shell may overide # them, f.e. to redirect the output into a different # channel, or even into a GUI. -# ::tcltest::DebugPuts -- +# tcltest::DebugPuts -- # # Prints the specified string if the current debug level is # higher than the provided level argument. @@ -293,15 +334,19 @@ namespace eval tcltest { # Results: # Prints the string. Nothing else is allowed. # +# Side Effects: +# None. +# -proc ::tcltest::DebugPuts {level string} { +proc tcltest::DebugPuts {level string} { variable debug if {$debug >= $level} { puts $string } + return } -# ::tcltest::DebugPArray -- +# tcltest::DebugPArray -- # # Prints the contents of the specified array if the current # debug level is higher than the provided level argument @@ -313,17 +358,21 @@ proc ::tcltest::DebugPuts {level string} { # Results: # Prints the contents of the array. Nothing else is allowed. # +# Side Effects: +# None. +# -proc ::tcltest::DebugPArray {level arrayvar} { +proc tcltest::DebugPArray {level arrayvar} { variable debug if {$debug >= $level} { catch {upvar $arrayvar $arrayvar} parray $arrayvar } + return } -# ::tcltest::DebugDo -- +# tcltest::DebugDo -- # # Executes the script if the current debug level is greater than # the provided level argument @@ -335,16 +384,779 @@ proc ::tcltest::DebugPArray {level arrayvar} { # Results: # Arbitrary side effects, dependent on the executed script. # +# Side Effects: +# None. +# -proc ::tcltest::DebugDo {level script} { +proc tcltest::DebugDo {level script} { variable debug if {$debug >= $level} { uplevel $script } + return +} + +##################################################################### + +# tcltest::CheckDirectory -- +# +# This procedure checks whether the specified path is a readable +# and/or writable directory. If one of the conditions is not +# satisfied an error is printed and the application aborted. The +# procedure assumes that the caller already checked the existence +# of the path. +# +# Arguments +# rw Information what attributes to check. Allowed values: +# r, w, rw, wr. If 'r' is part of the value the directory +# must be readable. 'w' associates to 'writable'. +# dir The directory to check. +# errMsg The string to prepend to the actual error message before +# printing it. +# +# Results +# none +# +# Side Effects: +# None. +# + +proc tcltest::CheckDirectory {rw dir errMsg} { + # Allowed values for 'rw': r, w, rw, wr + + if {![file isdir $dir]} { + set msg "$errMsg \"$dir\" is not a directory" + error $msg + } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { + set msg "$errMsg \"$dir\" is not writeable" + error $msg + } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { + set msg "$errMsg \"$dir\" is not readable" + error $msg + } + return +} + +# tcltest::normalizePath -- +# +# This procedure resolves any symlinks in the path thus creating a +# path without internal redirection. It assumes that the incoming +# path is absolute. +# +# Arguments +# pathVar contains the name of the variable containing the path to modify. +# +# Results +# The path is modified in place. +# +# Side Effects: +# None. +# + +proc tcltest::normalizePath {pathVar} { + upvar $pathVar path + + set oldpwd [pwd] + catch {cd $path} + set path [pwd] + cd $oldpwd + return $path +} + + +# tcltest::MakeAbsolutePath -- +# +# This procedure checks whether the incoming path is absolute or not. +# Makes it absolute if it was not. +# +# Arguments +# pathVar contains the name of the variable containing the path to modify. +# prefix is optional, contains the path to use to make the other an +# absolute one. The current working directory is used if it was +# not specified. +# +# Results +# The path is modified in place. +# +# Side Effects: +# None. +# + +proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { + upvar $pathVar path + + if {![string equal [file pathtype $path] "absolute"]} { + if {$prefix == {}} { + set prefix [pwd] + } + + set path [file join $prefix $path] + } + return $path +} + +##################################################################### + +# tcltest::<variableName> +# +# Accessor functions for tcltest variables that can be modified externally. +# These are vars that could otherwise be modified using command line +# arguments to tcltest. + +# tcltest::verbose -- +# +# Set or return the verbosity level (tcltest::verbose) for tests. This +# determines what gets printed to the screen and when, with regard to the +# running of the tests. The proc does not check for invalid values. It +# assumes that a string that doesn't match its predefined keywords +# is a string containing letter-specified verbosity levels. +# +# Arguments: +# A string containing any combination of 'pbste' or a list of keywords +# (listed in parens) +# p = print output whenever a test passes (pass) +# b = print the body of the test when it fails (body) +# s = print when a test is skipped (skip) +# t = print when a test starts (start) +# e = print errorInfo and errorCode when a test encounters an error +# (error) +# +# Results: +# content of tcltest::verbose - this is always the character combination +# (pbste) instead of the list form. +# +# Side effects: +# None. + +proc tcltest::verbose { {level ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::verbose + } + if {[llength $level] > 1} { + set tcltest::verbose $level + } else { + if {[regexp {pass|body|skip|start|error} $level]} { + set tcltest::verbose $level + } else { + set levelList [split $level {}] + set tcltest::verbose [string map {p pass b body s skip t start e + error} $levelList] + } + } + return $tcltest::verbose +} + +# tcltest::isVerbose -- +# +# Returns true if argument is one of the verbosity levels currently being +# used; returns false otherwise. +# +# Arguments: +# level +# +# Results: +# boolean 1 (true) or 0 (false), depending on whether or not the level +# provided is one of the ones stored in tcltest::verbose. +# +# Side effects: +# None. + +proc tcltest::isVerbose {level} { + if {[lsearch -exact [tcltest::verbose] $level] == -1} { + return 0 + } + return 1 +} + + + +# tcltest::match -- +# +# Set or return the match patterns (tcltest::match) that determine which +# tests are run. +# +# Arguments: +# List containing match patterns (glob format) +# +# Results: +# content of tcltest::match +# +# Side effects: +# none + +proc tcltest::match { {matchList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::match + } + set tcltest::match $matchList +} + +# tcltest::skip -- +# +# Set or return the skip patterns (tcltest::skip) that determine which +# tests are skipped. +# +# Arguments: +# List containing skip patterns (glob format) +# +# Results: +# content of tcltest::skip +# +# Side effects: +# None. + +proc tcltest::skip { {skipList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skip + } + set tcltest::skip $skipList +} + +# tcltest::matchFiles -- +# +# set or return the match patterns for file sourcing +# +# Arguments: +# list containing match file list (glob format) +# +# Results: +# content of tcltest::matchFiles +# +# Side effects: +# None. + +proc tcltest::matchFiles { {matchFileList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::matchFiles + } + set tcltest::matchFiles $matchFileList +} + +# tcltest::skipFiles -- +# +# set or return the skip patterns for file sourcing +# +# Arguments: +# list containing the skip file list (glob format) +# +# Results: +# content of tcltest::skipFiles +# +# Side effects: +# None. + +proc tcltest::skipFiles { {skipFileList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skipFiles + } + set tcltest::skipFiles $skipFileList +} + + +# tcltest::matchDirectories -- +# +# set or return the list of directories for matching (glob pattern list) +# +# Arguments: +# list of glob patterns matching subdirectories of +# tcltest::testsDirectory +# +# Results: +# content of tcltest::matchDirectories +# +# Side effects: +# None. + +proc tcltest::matchDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::matchDirectories + } + set tcltest::matchDirectories $dirlist +} + +# tcltest::skipDirectories -- +# +# set or return the list of directories to skip (glob pattern list) +# +# Arguments: +# list of glob patterns matching directories to skip; these directories +# are subdirectories of tcltest::testsDirectory +# +# Results: +# content of tcltest::skipDirectories +# +# Side effects: +# None. + +proc tcltest::skipDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skipDirectories + } + set tcltest::skipDirectories $dirlist +} + +# tcltest::preserveCore -- +# +# set or return the core preservation level. This proc does not do any +# error checking for invalid values. +# +# Arguments: +# core level: +# '0' = don't do anything with core files (default) +# '1' = notify the user if core files are created +# '2' = save any core files produced during testing to +# tcltest::temporaryDirectory +# +# Results: +# content of tcltest::preserveCore +# +# Side effects: +# None. + +proc tcltest::preserveCore { {coreLevel ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::preserveCore + } + set tcltest::preserveCore $coreLevel +} + +# tcltest::outputChannel -- +# +# set or return the output file descriptor based on the supplied file +# name (where tcltest puts all of its output) +# +# Arguments: +# output file descriptor +# +# Results: +# file descriptor corresponding to supplied file name (or currently set +# file descriptor, if no new filename was supplied) - this is the content +# of tcltest::outputChannel +# +# Side effects: +# None. + +proc tcltest::outputChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::outputChannel + } + if {($filename == "stderr") || ($filename == "stdout")} { + set tcltest::outputChannel $filename + } else { + set tcltest::outputChannel [open $filename w] + } + return $tcltest::outputChannel +} + +# tcltest::outputFile -- +# +# set or return the output file name (where tcltest puts all of its +# output); calls tcltest::outputChannel to set the corresponding file +# descriptor +# +# Arguments: +# output file name +# +# Results: +# file name corresponding to supplied file name (or currently set +# file name, if no new filename was supplied) - this is the content +# of tcltest::outputFile +# +# Side effects: +# if the file name supplied is relative, it will be made absolute with +# respect to the predefined temporaryDirectory + +proc tcltest::outputFile { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::outputFile + } + if {($filename != "stderr") && ($filename != "stdout")} { + MakeAbsolutePath filename $tcltest::temporaryDirectory + } + tcltest::outputChannel $filename + set tcltest::outputFile $filename +} + +# tcltest::errorChannel -- +# +# set or return the error file descriptor based on the supplied file name +# (where tcltest sends all its errors) +# +# Arguments: +# error file name +# +# Results: +# file descriptor corresponding to the supplied file name (or currently +# set file descriptor, if no new filename was supplied) - this is the +# content of tcltest::errorChannel +# +# Side effects: +# opens the descriptor in w mode unless the filename is set to stderr or +# stdout + +proc tcltest::errorChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::errorChannel + } + if {($filename == "stderr") || ($filename == "stdout")} { + set tcltest::errorChannel $filename + } else { + set tcltest::errorChannel [open $filename w] + } + return $tcltest::errorChannel +} + +# tcltest::errorFile -- +# +# set or return the error file name; calls tcltest::errorChannel to set +# the corresponding file descriptor +# +# Arguments: +# error file name +# +# Results: +# content of tcltest::errorFile +# +# Side effects: +# if the file name supplied is relative, it will be made absolute with +# respect to the predefined temporaryDirectory + +proc tcltest::errorFile { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::errorFile + } + if {($filename != "stderr") && ($filename != "stdout")} { + MakeAbsolutePath filename $tcltest::temporaryDirectory + } + set tcltest::errorFile $filename + errorChannel $tcltest::errorFile + return $tcltest::errorFile +} + +# tcltest::debug -- +# +# set or return the debug level for tcltest; this proc does not check for +# invalid values +# +# Arguments: +# debug level: +# '0' = no debug output (default) +# '1' = skipped tests +# '2' = tcltest variables and supplied flags +# '3' = harness operations +# +# Results: +# content of tcltest::debug +# +# Side effects: +# None. + +proc tcltest::debug { {debugLevel ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::debug + } + set tcltest::debug $debugLevel +} + +# tcltest::testConstraint -- +# +# sets a test constraint to a value; to do multiple constraints, call +# this proc multiple times. also returns the value of the named +# constraint if no value was supplied. +# +# Arguments: +# constraint - name of the constraint +# value - new value for constraint (should be boolean) - if not supplied, +# this is a query +# +# Results: +# content of tcltest::testConstraints($constraint) +# +# Side effects: +# appends the constraint name to tcltest::constraintsSpecified + +proc tcltest::testConstraint {constraint {value ""}} { + DebugPuts 3 "entering testConstraint $constraint $value" + if {[llength [info level 0]] == 2} { + return $tcltest::testConstraints($constraint) + } + lappend tcltest::constraintsSpecified $constraint + set tcltest::testConstraints($constraint) $value +} + +# tcltest::constraintsSpecified -- +# +# returns a list of all the constraint names specified using +# testConstraint +# +# Arguments: +# None. +# +# Results: +# list of the constraint names in tcltest::constraintsSpecified +# +# Side effects: +# None. + +proc tcltest::constraintsSpecified {} { + return $tcltest::constraintsSpecified +} + +# tcltest::constraintList -- +# +# returns a list of all the constraint names +# +# Arguments: +# None. +# +# Results: +# list of the constraint names in tcltest::testConstraints +# +# Side effects: +# None. + +proc tcltest::constraintList {} { + return [array names tcltest::testConstraints] +} + +# tcltest::limitConstraints -- +# +# sets the limited constraints to tcltest::limitConstraints +# +# Arguments: +# list of constraint names +# +# Results: +# content of tcltest::limitConstraints +# +# Side effects: +# None. + +proc tcltest::limitConstraints { {constraintList ""} } { + DebugPuts 3 "entering limitConstraints $constraintList" + if {[llength [info level 0]] == 1} { + return $tcltest::limitConstraints + } + set tcltest::limitConstraints $constraintList + foreach elt [tcltest::constraintList] { + if {[lsearch -exact [tcltest::constraintsSpecified] $elt] == -1} { + tcltest::testConstraint $elt 0 + } + } + return $tcltest::limitConstraints +} + +# tcltest::loadScript -- +# +# sets the load script +# +# Arguments: +# script to be set +# +# Results: +# contents of tcltest::loadScript +# +# Side effects: +# None. + +proc tcltest::loadScript { {script ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::loadScript + } + set tcltest::loadScript $script +} + +# tcltest::loadFile -- +# +# set the load file (containing the load script); +# put the content of the load file into loadScript +# +# Arguments: +# script's file name +# +# Results: +# content of tcltest::loadFile +# +# Side effects: +# None. + +proc tcltest::loadFile { {scriptFile ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::loadFile + } + MakeAbsolutePath scriptFile $tcltest::temporaryDirectory + set tmp [open $scriptFile r] + tcltest::loadScript [read $tmp] + close $tmp + set tcltest::loadFile $scriptFile +} + +# tcltest::workingDirectory -- +# +# set workingDirectory to the given path. +# If the path is relative, make it absolute. +# change directory to the stated working directory, if resetting the +# value +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::workingDirectory +# +# Side effects: +# None. + +proc tcltest::workingDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::workingDirectory + } + set tcltest::workingDirectory $dir + MakeAbsolutePath tcltest::workingDirectory + cd $tcltest::workingDirectory + return $tcltest::workingDirectory +} + +# tcltest::temporaryDirectory -- +# +# Set tcltest::temporaryDirectory to the given path. +# If the path is relative, make it absolute. If the file exists but +# is not a dir, then return an error. +# +# If tcltest::temporaryDirectory does not already exist, create it. +# If you cannot create it, then return an error (the file mkdir isn't +# caught and will propagate). +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::temporaryDirectory +# +# Side effects: +# None. + +proc tcltest::temporaryDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::temporaryDirectory + } + set tcltest::temporaryDirectory $dir + + MakeAbsolutePath tcltest::temporaryDirectory + set tmpDirError "bad argument for temporary directory: " + + if {[file exists $tcltest::temporaryDirectory]} { + tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError + } else { + file mkdir $tcltest::temporaryDirectory + } + + normalizePath tcltest::temporaryDirectory +} + +# tcltest::testsDirectory -- +# +# Set tcltest::testsDirectory to the given path. +# If the path is relative, make it absolute. If the file exists but +# is not a dir, then return an error. +# +# If tcltest::testsDirectory does not already exist, return an error. +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::testsDirectory +# +# Side effects: +# None. + +proc tcltest::testsDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::testsDirectory + } + + set tcltest::testsDirectory $dir + + MakeAbsolutePath tcltest::testsDirectory + set testDirError "bad argument for tests directory: " + + if {[file exists $tcltest::testsDirectory]} { + tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError + } else { + set msg "$testDirError \"$tcltest::testsDirectory\" does not exist" + error $msg + } + + normalizePath tcltest::testsDirectory +} + +# tcltest::singleProcess -- +# +# sets tcltest::singleProcess to the value provided. +# +# Arguments: +# value for singleProcess: +# 1 = source each test file into the current process +# 0 = run each test file in its own process +# +# Results: +# content of tcltest::singleProcess +# +# Side effects: +# None. + +proc tcltest::singleProcess { {value ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::singleProcess + } + set tcltest::singleProcess $value +} + +# tcltest::interpreter -- +# +# the interpreter name stored in tcltest::tcltest +# +# Arguments: +# executable name +# +# Results: +# content of tcltest::tcltest +# +# Side effects: +# None. + +proc tcltest::interpreter { {interp ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::tcltest + } + set tcltest::tcltest $interp +} + +# tcltest::mainThread -- +# +# sets or returns the thread id stored in tcltest::mainThread +# +# Arguments: +# thread id +# +# Results: +# content of tcltest::mainThread +# +# Side effects: +# None. + +proc tcltest::mainThread { {threadid ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::mainThread + } + set tcltest::mainThread $threadid } -# ::tcltest::AddToSkippedBecause -- +##################################################################### + +# tcltest::AddToSkippedBecause -- # # Increments the variable used to track how many tests were skipped # because of a particular constraint. @@ -353,52 +1165,61 @@ proc ::tcltest::DebugDo {level script} { # constraint The name of the constraint to be modified # # Results: -# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't +# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't # previously exist - otherwise, it just increments it. +# +# Side effects: +# None. -proc ::tcltest::AddToSkippedBecause { constraint } { +proc tcltest::AddToSkippedBecause { constraint {value 1}} { # add the constraint to the list of constraints that kept tests # from running - if {[info exists ::tcltest::skippedBecause($constraint)]} { - incr ::tcltest::skippedBecause($constraint) + if {[info exists tcltest::skippedBecause($constraint)]} { + incr tcltest::skippedBecause($constraint) $value } else { - set ::tcltest::skippedBecause($constraint) 1 + set tcltest::skippedBecause($constraint) $value } return } -# ::tcltest::PrintError -- +# tcltest::PrintError -- # -# Prints errors to ::tcltest::errorChannel and then flushes that +# Prints errors to tcltest::errorChannel and then flushes that # channel, making sure that all messages are < 80 characters per line. # # Arguments: # errorMsg String containing the error to be printed # +# +# Results: +# None. +# +# Side effects: +# None. -proc ::tcltest::PrintError {errorMsg} { +proc tcltest::PrintError {errorMsg} { set InitialMessage "Error: " set InitialMsgLen [string length $InitialMessage] - puts -nonewline $::tcltest::errorChannel $InitialMessage + puts -nonewline [errorChannel] $InitialMessage # Keep track of where the end of the string is. set endingIndex [string length $errorMsg] if {$endingIndex < 80} { - puts $::tcltest::errorChannel $errorMsg + puts [errorChannel] $errorMsg } else { # Print up to 80 characters on the first line, including the # InitialMessage. set beginningIndex [string last " " [string range $errorMsg 0 \ [expr {80 - $InitialMsgLen}]]] - puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] + puts [errorChannel] [string range $errorMsg 0 $beginningIndex] while {$beginningIndex != "end"} { - puts -nonewline $::tcltest::errorChannel \ + puts -nonewline [errorChannel] \ [string repeat " " $InitialMsgLen] if {[expr {$endingIndex - $beginningIndex}] < 72} { - puts $::tcltest::errorChannel [string trim \ + puts [errorChannel] [string trim \ [string range $errorMsg $beginningIndex end]] set beginningIndex end } else { @@ -409,25 +1230,52 @@ proc ::tcltest::PrintError {errorMsg} { || ($newEndingIndex <= $beginningIndex)} { set newEndingIndex end } - puts $::tcltest::errorChannel [string trim \ + puts [errorChannel] [string trim \ [string range $errorMsg \ - $beginningIndex $newEndingIndex]] + $beginningIndex $newEndingIndex]] set beginningIndex $newEndingIndex } } } - flush $::tcltest::errorChannel + flush [errorChannel] return } -if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { - proc ::tcltest::initConstraintsHook {} {} +if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { + proc tcltest::initConstraintsHook {} {} +} + +# tcltest::safeFetch -- +# +# The following trace procedure makes it so that we can safely refer to +# non-existent members of the tcltest::testConstraints array without +# causing an error. Instead, reading a non-existent member will return +# 0. This is necessary because tests are allowed to use constraint "X" +# without ensuring that tcltest::testConstraints("X") is defined. +# +# Arguments: +# n1 - name of the array (tcltest::testConstraints) +# n2 - array key value (constraint name) +# op - operation performed on tcltest::testConstraints (generally r) +# +# Results: +# none +# +# Side effects: +# sets tcltest::testConstraints($n2) to 0 if it's referenced but never +# before used + +proc tcltest::safeFetch {n1 n2 op} { + DebugPuts 3 "entering safeFetch $n1 $n2 $op" + if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { + tcltest::testConstraint $n2 0 + } } -# ::tcltest::initConstraints -- +# tcltest::initConstraints -- # -# Check Constraintsuration information that will determine which tests -# to run. To do this, create an array ::tcltest::testConstraints. Each +# Check constraint information that will determine which tests +# to run. To do this, create an array tcltest::testConstraints. Each # element has a 0 or 1 value. If the element is "true" then tests # with that constraint will be run, otherwise tests with that constraint # will be skipped. See the tcltest man page for the list of built-in @@ -437,101 +1285,110 @@ if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { # none # # Results: -# The ::tcltest::testConstraints array is reset to have an index for +# The tcltest::testConstraints array is reset to have an index for # each built-in test constraint. +# +# Side Effects: +# None. +# -proc ::tcltest::initConstraints {} { +proc tcltest::initConstraints {} { global tcl_platform tcl_interactive tk_version - # The following trace procedure makes it so that we can safely refer to - # non-existent members of the ::tcltest::testConstraints array without - # causing an error. Instead, reading a non-existent member will return 0. - # This is necessary because tests are allowed to use constraint "X" without - # ensuring that ::tcltest::testConstraints("X") is defined. + # Safely refer to non-existent members of the tcltest::testConstraints + # array without causing an error. + trace variable tcltest::testConstraints r tcltest::safeFetch - trace variable ::tcltest::testConstraints r ::tcltest::safeFetch + tcltest::initConstraintsHook - proc ::tcltest::safeFetch {n1 n2 op} { - if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} { - set ::tcltest::testConstraints($n2) 0 - } - } + tcltest::testConstraint singleTestInterp [singleProcess] - ::tcltest::initConstraintsHook + # All the 'pc' constraints are here for backward compatibility and are not + # documented. They have been replaced with equivalent 'win' constraints. - set ::tcltest::testConstraints(unixOnly) \ + tcltest::testConstraint unixOnly \ [string equal $tcl_platform(platform) "unix"] - set ::tcltest::testConstraints(macOnly) \ + tcltest::testConstraint macOnly \ [string equal $tcl_platform(platform) "macintosh"] - set ::tcltest::testConstraints(pcOnly) \ + tcltest::testConstraint pcOnly \ + [string equal $tcl_platform(platform) "windows"] + tcltest::testConstraint winOnly \ [string equal $tcl_platform(platform) "windows"] - set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly) - set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly) - set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly) - - set ::tcltest::testConstraints(unixOrPc) \ - [expr {$::tcltest::testConstraints(unix) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrPc) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrUnix) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(unix)}] - - set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \ - "Windows NT"] - set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \ - "Windows 95"] - set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \ - "Windows 98"] + tcltest::testConstraint unix [tcltest::testConstraint unixOnly] + tcltest::testConstraint mac [tcltest::testConstraint macOnly] + tcltest::testConstraint pc [tcltest::testConstraint pcOnly] + tcltest::testConstraint win [tcltest::testConstraint winOnly] + + tcltest::testConstraint unixOrPc \ + [expr {[tcltest::testConstraint unix] \ + || [tcltest::testConstraint pc]}] + tcltest::testConstraint macOrPc \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint pc]}] + tcltest::testConstraint unixOrWin \ + [expr {[tcltest::testConstraint unix] \ + || [tcltest::testConstraint win]}] + tcltest::testConstraint macOrWin \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint win]}] + tcltest::testConstraint macOrUnix \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint unix]}] + + tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"] + tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"] + tcltest::testConstraint 98 [string equal $tcl_platform(os) "Windows 98"] # The following Constraints switches are used to mark tests that should # work, but have been temporarily disabled on certain platforms because # they don't and we haven't gotten around to fixing the underlying # problem. - set ::tcltest::testConstraints(tempNotPc) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(tempNotMac) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(tempNotUnix) \ - [expr {!$::tcltest::testConstraints(unix)}] + tcltest::testConstraint tempNotPc \ + [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint tempNotWin \ + [expr {![tcltest::testConstraint win]}] + tcltest::testConstraint tempNotMac \ + [expr {![tcltest::testConstraint mac]}] + tcltest::testConstraint tempNotUnix \ + [expr {![tcltest::testConstraint unix]}] # The following Constraints switches are used to mark tests that crash on # certain platforms, so that they can be reactivated again when the # underlying problem is fixed. - set ::tcltest::testConstraints(pcCrash) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macCrash) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(unixCrash) \ - [expr {!$::tcltest::testConstraints(unix)}] + tcltest::testConstraint pcCrash \ + [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint winCrash \ + [expr {![tcltest::testConstraint win]}] + tcltest::testConstraint macCrash \ + [expr {![tcltest::testConstraint mac]}] + tcltest::testConstraint unixCrash \ + [expr {![tcltest::testConstraint unix]}] # Skip empty tests - set ::tcltest::testConstraints(emptyTest) 0 + tcltest::testConstraint emptyTest 0 # By default, tests that expose known bugs are skipped. - set ::tcltest::testConstraints(knownBug) 0 + tcltest::testConstraint knownBug 0 # By default, non-portable tests are skipped. - set ::tcltest::testConstraints(nonPortable) 0 + tcltest::testConstraint nonPortable 0 # Some tests require user interaction. - set ::tcltest::testConstraints(userInteraction) 0 + tcltest::testConstraint userInteraction 0 # Some tests must be skipped if the interpreter is not in interactive mode if {[info exists tcl_interactive]} { - set ::tcltest::testConstraints(interactive) $::tcl_interactive + tcltest::testConstraint interactive $::tcl_interactive } else { - set ::tcltest::testConstraints(interactive) 0 + tcltest::testConstraint interactive 0 } # Some tests can only be run if the installation came from a CD image @@ -539,8 +1396,8 @@ proc ::tcltest::initConstraints {} { # Some tests must be skipped if you are running as root on Unix. # Other tests can only be run if you are running as root on Unix. - set ::tcltest::testConstraints(root) 0 - set ::tcltest::testConstraints(notRoot) 1 + tcltest::testConstraint root 0 + tcltest::testConstraint notRoot 1 set user {} if {[string equal $tcl_platform(platform) "unix"]} { catch {set user [exec whoami]} @@ -548,21 +1405,21 @@ proc ::tcltest::initConstraints {} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} } if {([string equal $user "root"]) || ([string equal $user ""])} { - set ::tcltest::testConstraints(root) 1 - set ::tcltest::testConstraints(notRoot) 0 + tcltest::testConstraint root 1 + tcltest::testConstraint notRoot 0 } } # Set nonBlockFiles constraint: 1 means this platform supports - # setting files into nonblocking mode. + # ting files into nonblocking mode. if {[catch {set f [open defs r]}]} { - set ::tcltest::testConstraints(nonBlockFiles) 1 + tcltest::testConstraint nonBlockFiles 1 } else { if {[catch {fconfigure $f -blocking off}] == 0} { - set ::tcltest::testConstraints(nonBlockFiles) 1 + tcltest::testConstraint nonBlockFiles 1 } else { - set ::tcltest::testConstraints(nonBlockFiles) 0 + tcltest::testConstraint nonBlockFiles 0 } close $f } @@ -576,75 +1433,75 @@ proc ::tcltest::initConstraints {} { if {[string equal $tcl_platform(platform) "unix"]} { if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - set ::tcltest::testConstraints(asyncPipeClose) 0 + tcltest::testConstraint asyncPipeClose 0 } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 + tcltest::testConstraint asyncPipeClose 1 } } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 + tcltest::testConstraint asyncPipeClose 1 } # Test to see if we have a broken version of sprintf with respect # to the "e" format of floating-point numbers. - set ::tcltest::testConstraints(eformat) 1 + tcltest::testConstraint eformat 1 if {![string equal "[format %g 5e-5]" "5e-05"]} { - set ::tcltest::testConstraints(eformat) 0 + tcltest::testConstraint eformat 0 } # Test to see if execed commands such as cat, echo, rm and so forth are # present on this machine. - set ::tcltest::testConstraints(unixExecs) 1 + tcltest::testConstraint unixExecs 1 if {[string equal $tcl_platform(platform) "macintosh"]} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([string equal $tcl_platform(platform) "windows"])} { if {[catch {exec cat defs}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec sh -c echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec wc defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {$::tcltest::testConstraints(unixExecs) == 1} { + if {[tcltest::testConstraint unixExecs] == 1} { exec echo hello > removeMe if {[catch {exec rm removeMe}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec sleep 1}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec fgrep unixExecs defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec ps}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec echo abc > removeMe}] == 0) && \ ([catch {exec chmod 644 removeMe}] == 1) && \ ([catch {exec rm removeMe}] == 0)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } else { catch {exec rm -f removeMe} } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec mkdir removeMe}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } else { catch {exec rm -r removeMe} } @@ -653,14 +1510,14 @@ proc ::tcltest::initConstraints {} { # Locate tcltest executable if {![info exists tk_version]} { - set tcltest [info nameofexecutable] + set tcltest::tcltest [info nameofexecutable] - if {$tcltest == "{}"} { - set tcltest {} + if {$tcltest::tcltest == "{}"} { + set tcltest::tcltest {} } } - set ::tcltest::testConstraints(stdio) 0 + tcltest::testConstraint stdio 0 catch { catch {file delete -force tmp} set f [open tmp w] @@ -672,7 +1529,7 @@ proc ::tcltest::initConstraints {} { set f [open "|[list $tcltest tmp]" r] close $f - set ::tcltest::testConstraints(stdio) 1 + tcltest::testConstraint stdio 1 } catch {file delete -force tmp} @@ -681,50 +1538,62 @@ proc ::tcltest::initConstraints {} { # system. catch {socket} msg - set ::tcltest::testConstraints(socket) \ + tcltest::testConstraint socket \ [expr {$msg != "sockets are not available on this system"}] # Check for internationalization if {[info commands testlocale] == ""} { # No testlocale command, no tests... - set ::tcltest::testConstraints(hasIsoLocale) 0 + tcltest::testConstraint hasIsoLocale 0 } else { - set ::tcltest::testConstraints(hasIsoLocale) \ - [string length [::tcltest::set_iso8859_1_locale]] - ::tcltest::restore_locale + tcltest::testConstraint hasIsoLocale \ + [string length [tcltest::set_iso8859_1_locale]] + tcltest::restore_locale } } -# ::tcltest::PrintUsageInfoHook +##################################################################### + +# Handle command line arguments (from argv) and default arg settings +# (in TCLTEST_OPTIONS). + +# tcltest::PrintUsageInfoHook # # Hook used for customization of display of usage information. # -if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} { - proc ::tcltest::PrintUsageInfoHook {} {} +if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} { + proc tcltest::PrintUsageInfoHook {} {} } -# ::tcltest::PrintUsageInfo +# tcltest::PrintUsageInfo # # Prints out the usage information for package tcltest. This can be -# customized with the redefinition of ::tcltest::PrintUsageInfoHook. +# customized with the redefinition of tcltest::PrintUsageInfoHook. # # Arguments: # none # +# Results: +# none +# +# Side Effects: +# none -proc ::tcltest::PrintUsageInfo {} { +proc tcltest::PrintUsageInfo {} { puts [format "Usage: [file tail [info nameofexecutable]] \ script ?-help? ?flag value? ... \n\ Available flags (and valid input values) are: \n\ -help \t Display this usage information. \n\ -verbose level \t Takes any combination of the values \n\ - \t 'p', 's' and 'b'. Test suite will \n\ + \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\ \t display all passed tests if 'p' is \n\ \t specified, all skipped tests if 's' \n\ - \t is specified, and the bodies of \n\ - \t failed tests if 'b' is specified. \n\ + \t is specified, the bodies of \n\ + \t failed tests if 'b' is specified, \n\ + \t and when tests start if 't' is specified. \n\ + \t ErrorInfo is displayed if 'e' is specified. \n\ \t The default value is 'b'. \n\ -constraints list\t Do not skip the listed constraints\n\ -limitconstraints bool\t Only run tests with the constraints\n\ @@ -740,17 +1609,21 @@ proc ::tcltest::PrintUsageInfo {} { \t match the glob pattern given. \n\ -notfile pattern\t Skip all test files that match the \n\ \t glob pattern given. \n\ + -relateddir pattern\t Run tests in directories that match \n\ + \t the glob pattern given. \n\ + -asidefromdir pattern\t Skip tests in directories that match \n\ + \t the glob pattern given.\n\ -preservecore level \t If 2, save any core files produced \n\ \t during testing in the directory \n\ \t specified by -tmpdir. If 1, notify the\n\ \t user if core files are created. The default \n\ - \t is $::tcltest::preserveCore. \n\ + \t is $tcltest::preserveCore. \n\ -tmpdir directory\t Save temporary files in the specified\n\ \t directory. The default value is \n\ - \t $::tcltest::temporaryDirectory. \n\ + \t $tcltest::temporaryDirectory. \n\ -testdir directories\t Search tests in the specified\n\ \t directories. The default value is \n\ - \t $::tcltest::testsDirectory. \n\ + \t $tcltest::testsDirectory. \n\ -outfile file \t Send output from test runs to the \n\ \t specified file. The default is \n\ \t stdout. \n\ @@ -762,207 +1635,98 @@ proc ::tcltest::PrintUsageInfo {} { -load script \t Specifies the script to load the tested \n\ \t commands. \n\ -debug level \t Internal debug flag."] - ::tcltest::PrintUsageInfoHook + tcltest::PrintUsageInfoHook return } -# ::tcltest::CheckDirectory -- -# -# This procedure checks whether the specified path is a readable -# and/or writable directory. If one of the conditions is not -# satisfied an error is printed and the application aborted. The -# procedure assumes that the caller already checked the existence -# of the path. -# -# Arguments -# rw Information what attributes to check. Allowed values: -# r, w, rw, wr. If 'r' is part of the value the directory -# must be readable. 'w' associates to 'writable'. -# dir The directory to check. -# errMsg The string to prepend to the actual error message before -# printing it. -# -# Results -# none -# - -proc ::tcltest::CheckDirectory {rw dir errMsg} { - # Allowed values for 'rw': r, w, rw, wr - - if {![file isdir $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not a directory" - exit 1 - } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not writeable" - exit 1 - } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not readable" - exit 1 - } -} - -# ::tcltest::normalizePath -- -# -# This procedure resolves any symlinks in the path thus creating a -# path without internal redirection. It assumes that the incoming -# path is absolute. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::normalizePath {pathVar} { - upvar $pathVar path - - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd -} - -# ::tcltest::MakeAbsolutePath -- -# -# This procedure checks whether the incoming path is absolute or not. -# Makes it absolute if it was not. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# prefix is optional, contains the path to use to make the other an -# absolute one. The current working directory is used if it was -# not specified. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} { - upvar $pathVar path - - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { - set prefix [pwd] - } - - set path [file join $prefix $path] - } -} - -# ::tcltest::processCmdLineArgsFlagsHook -- +# tcltest::processCmdLineArgsFlagsHook -- # # This hook is used to add to the list of command line arguments that are -# processed by ::tcltest::processCmdLineArgs. +# processed by tcltest::ProcessFlags. It is called at the beginning of +# ProcessFlags. # -if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { - proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} +if {[namespace inscope tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { + proc tcltest::processCmdLineArgsAddFlagsHook {} {} } -# ::tcltest::processCmdLineArgsHook -- +# tcltest::processCmdLineArgsHook -- # # This hook is used to actually process the flags added by -# ::tcltest::processCmdLineArgsAddFlagsHook. +# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of +# ProcessFlags. # # Arguments: # flags The flags that have been pulled out of argv # -if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} { - proc ::tcltest::processCmdLineArgsHook {flag} {} +if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} { + proc tcltest::processCmdLineArgsHook {flag} {} } -# ::tcltest::processCmdLineArgs -- +# tcltest::ProcessFlags -- # -# Use command line args to set the verbose, skip, and -# match, outputChannel, errorChannel, debug, and temporaryDirectory -# variables. -# -# This procedure must be run after constraints are initialized, because -# some constraints can be overridden. +# process command line arguments supplied in the flagArray - this is +# called by processCmdLineArgs +# modifies tcltest variables according to the content of the flagArray. # # Arguments: -# none +# flagArray - array containing name/value pairs of flags # # Results: -# Sets the above-named variables in the tcltest namespace. - -proc ::tcltest::processCmdLineArgs {} { - global argv - - # The "argv" var doesn't exist in some cases, so use {}. - - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv - } - - # Allow for 1-char abbreviations, where applicable (e.g., -match == -m). - # Note that -verbose cannot be abbreviated to -v in wish because it - # conflicts with the wish option -visual. +# sets tcltest variables according to their values as defined by +# flagArray +# +# Side effects: +# None. +proc tcltest::ProcessFlags {flagArray} { # Process -help first - if {([lsearch -exact $flagArray {-help}] != -1) || \ - ([lsearch -exact $flagArray {-h}] != -1)} { - ::tcltest::PrintUsageInfo - exit 1 - } - - if {[catch {array set flag $flagArray}]} { - ::tcltest::PrintError "odd number of arguments specified on command line: \ - $argv" - ::tcltest::PrintUsageInfo + if {[lsearch -exact $flagArray {-help}] != -1} { + tcltest::PrintUsageInfo exit 1 } + + catch {array set flag $flagArray} # -help is not listed since it has already been processed lappend defaultFlags -verbose -match -skip -constraints \ -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints -args -testdir \ - -load -loadfile + -preservecore -limitconstraints -testdir \ + -load -loadfile -asidefromdir \ + -relateddir -singleproc set defaultFlags [concat $defaultFlags \ - [ ::tcltest::processCmdLineArgsAddFlagsHook ]] - - foreach arg $defaultFlags { - set abbrev [string range $arg 0 1] - if {([info exists flag($abbrev)]) && \ - ([lsearch -exact $flagArray $arg] < [lsearch -exact \ - $flagArray $abbrev])} { - set flag($arg) $flag($abbrev) - } - } - - # Set ::tcltest::parameters to the arg of the -args flag, if given - if {[info exists flag(-args)]} { - set ::tcltest::parameters $flag(-args) - } - - # Set ::tcltest::verbose to the arg of the -verbose flag, if given + [tcltest::processCmdLineArgsAddFlagsHook ]] + # Set tcltest::verbose to the arg of the -verbose flag, if given if {[info exists flag(-verbose)]} { - set ::tcltest::verbose $flag(-verbose) + tcltest::verbose $flag(-verbose) } - # Set ::tcltest::match to the arg of the -match flag, if given. - + # Set tcltest::match to the arg of the -match flag, if given. if {[info exists flag(-match)]} { - set ::tcltest::match $flag(-match) + tcltest::match $flag(-match) } - # Set ::tcltest::skip to the arg of the -skip flag, if given - + # Set tcltest::skip to the arg of the -skip flag, if given if {[info exists flag(-skip)]} { - set ::tcltest::skip $flag(-skip) + tcltest::skip $flag(-skip) } # Handle the -file and -notfile flags if {[info exists flag(-file)]} { - set ::tcltest::matchFiles $flag(-file) + tcltest::matchFiles $flag(-file) } if {[info exists flag(-notfile)]} { - set ::tcltest::skipFiles $flag(-notfile) + tcltest::skipFiles $flag(-notfile) + } + + # Handle -relateddir and -asidefromdir flags + if {[info exists flag(-relateddir)]} { + tcltest::matchDirectories $flag(-relateddir) + } + if {[info exists flag(-asidefromdir)]} { + tcltest::skipDirectories $flag(-asidefromdir) } # Use the -constraints flag, if given, to turn on constraints that are @@ -971,7 +1735,7 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-constraints)]} { foreach elt $flag(-constraints) { - set ::tcltest::testConstraints($elt) 1 + tcltest::testConstraint $elt 1 } } @@ -980,87 +1744,35 @@ proc ::tcltest::processCmdLineArgs {} { # the -constraints flag was not specified, print out an error and exit. if {[info exists flag(-limitconstraints)]} { if {![info exists flag(-constraints)]} { - puts "You can only use the -limitconstraints flag with \ - -constraints" - exit 1 - } - set ::tcltest::limitConstraints $flag(-limitconstraints) - foreach elt [array names ::tcltest::testConstraints] { - if {[lsearch -exact $flag(-constraints) $elt] == -1} { - set ::tcltest::testConstraints($elt) 0 - } + set msg "-limitconstraints flag can only be used with -constraints" + error $msg } + tcltest::limitConstraints $flag(-limitconstraints) } - # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if + # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist, create it. - # If you cannot create it, then return an error. - set tmpDirError "" if {[info exists flag(-tmpdir)]} { - set ::tcltest::temporaryDirectory $flag(-tmpdir) - - MakeAbsolutePath ::tcltest::temporaryDirectory - set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: " - } - if {[file exists $::tcltest::temporaryDirectory]} { - ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError - } else { - file mkdir $::tcltest::temporaryDirectory + tcltest::temporaryDirectory $flag(-tmpdir) } - normalizePath ::tcltest::temporaryDirectory - - # Set the ::tcltest::testsDirectory to the arg of -testdir, if + # Set the tcltest::testsDirectory to the arg of -testdir, if # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist return an error. - set testDirError "" if {[info exists flag(-testdir)]} { - set ::tcltest::testsDirectory $flag(-testdir) - - MakeAbsolutePath ::tcltest::testsDirectory - set testDirError "bad argument \"$flag(-testdir)\" to -testdir: " - } - if {[file exists $::tcltest::testsDirectory]} { - ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError - } else { - ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \ - does not exist" - exit 1 - } - - normalizePath ::tcltest::testsDirectory - - # Save the names of files that already exist in - # the output directory. - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend ::tcltest::filesExisted [file tail $file] + tcltest::testsDirectory $flag(-testdir) } # If an alternate error or output files are specified, change the # default channels. if {[info exists flag(-outfile)]} { - set tmp $flag(-outfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::outputChannel [open $tmp w] + tcltest::outputFile $flag(-outfile) } if {[info exists flag(-errfile)]} { - set tmp $flag(-errfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::errorChannel [open $tmp w] + tcltest::errorFile $flag(-errfile) } # If a load script was specified, either directly or through @@ -1068,294 +1780,647 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-load)] && \ ([lsearch -exact $flagArray -load] > \ - [lsearch -exact $flagArray -loadfile])} { - set ::tcltest::loadScript $flag(-load) + [lsearch -exact $flagArray -loadfile])} { + tcltest::loadScript $flag(-load) } if {[info exists flag(-loadfile)] && \ ([lsearch -exact $flagArray -loadfile] > \ - [lsearch -exact $flagArray -load]) } { - set tmp $flag(-loadfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set tmp [open $tmp r] - set ::tcltest::loadScript [read $tmp] - close $tmp + [lsearch -exact $flagArray -load]) } { + tcltest::loadFile $flag(-loadfile) } # If the user specifies debug testing, print out extra information during # the run. if {[info exists flag(-debug)]} { - set ::tcltest::debug $flag(-debug) + tcltest::debug $flag(-debug) } # Handle -preservecore if {[info exists flag(-preservecore)]} { - set ::tcltest::preserveCore $flag(-preservecore) + tcltest::preserveCore $flag(-preservecore) + } + + # Handle -singleproc flag + if {[info exists flag(-singleproc)]} { + tcltest::singleProcess $flag(-singleproc) } # Call the hook - ::tcltest::processCmdLineArgsHook [array get flag] + tcltest::processCmdLineArgsHook [array get flag] + return +} - # Spit out everything you know if we're at a debug level 2 or greater +# tcltest::processCmdLineArgs -- +# +# Use command line args to set tcltest namespace variables. +# +# This procedure must be run after constraints are initialized, because +# some constraints can be overridden. +# +# Set variables based on the contents of the environment variable +# TCLTEST_OPTIONS first, then override with command-line options, if +# specified. +# +# Arguments: +# none +# +# Results: +# Sets the above-named variables in the tcltest namespace. +# +# Side Effects: +# None. +# + +proc tcltest::processCmdLineArgs {} { + global argv + + # If the TCLTEST_OPTIONS environment variable exists, parse it first, then + # the argv list. The command line argument parsing will be a two-pass + # affair from now on, so that TCLTEST_OPTIONS contain the default options. + # These can be overridden by the command line flags. + + if {[info exists ::env(TCLTEST_OPTIONS)]} { + tcltest::ProcessFlags $::env(TCLTEST_OPTIONS) + } + + # The "argv" var doesn't exist in some cases, so use {}. + if {(![info exists argv]) || ([llength $argv] < 1)} { + set flagArray {} + } else { + set flagArray $argv + } + + tcltest::ProcessFlags $flagArray - DebugPuts 2 "Flags passed into tcltest:" - DebugPArray 2 flag - DebugPuts 2 "::tcltest::debug = $::tcltest::debug" - DebugPuts 2 "::tcltest::testsDirectory = $::tcltest::testsDirectory" - DebugPuts 2 "::tcltest::workingDirectory = $::tcltest::workingDirectory" - DebugPuts 2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory" - DebugPuts 2 "::tcltest::outputChannel = $::tcltest::outputChannel" - DebugPuts 2 "::tcltest::errorChannel = $::tcltest::errorChannel" - DebugPuts 2 "Original environment (::tcltest::originalEnv):" - DebugPArray 2 ::tcltest::originalEnv + # Spit out everything you know if we're at a debug level 2 or greater + DebugPuts 2 "Flags passed into tcltest:" + if {[info exists ::env(TCLTEST_OPTIONS)]} { + DebugPuts 2 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" + } + if {[info exists argv]} { + DebugPuts 2 " argv: $argv" + } + DebugPuts 2 "tcltest::debug = [tcltest::debug]" + DebugPuts 2 "tcltest::testsDirectory = [tcltest::testsDirectory]" + DebugPuts 2 "tcltest::workingDirectory = [tcltest::workingDirectory]" + DebugPuts 2 "tcltest::temporaryDirectory = [tcltest::temporaryDirectory]" + DebugPuts 2 "tcltest::outputChannel = [outputChannel]" + DebugPuts 2 "tcltest::errorChannel = [errorChannel]" + DebugPuts 2 "Original environment (tcltest::originalEnv):" + DebugPArray 2 tcltest::originalEnv DebugPuts 2 "Constraints:" - DebugPArray 2 ::tcltest::testConstraints + DebugPArray 2 tcltest::testConstraints + return } -# ::tcltest::loadTestedCommands -- +##################################################################### + +# Code to run the tests goes here. + +# tcltest::testPuts -- # -# Uses the specified script to load the commands to test. Allowed to -# be empty, as the tested commands could have been compiled into the -# interpreter. +# Used to redefine puts in test environment. +# Stores whatever goes out on stdout in tcltest::outData and stderr in +# tcltest::errData before sending it on to the regular puts. # -# Arguments -# none +# Arguments: +# same as standard puts # -# Results -# none +# Results: +# none +# +# Side effects: +# Intercepts puts; data that would otherwise go to stdout, stderr, or +# file channels specified in tcltest::outputChannel and errorChannel does +# not get sent to the normal puts function. + +proc tcltest::testPuts {args} { + set len [llength $args] + if {$len == 1} { + # Only the string to be printed is specified + append tcltest::outData "[lindex $args 0]\n" + return +# return [tcltest::normalPuts [lindex $args 0]] + } elseif {$len == 2} { + # Either -nonewline or channelId has been specified + if {[regexp {^-nonewline} [lindex $args 0]]} { + append tcltest::outData "[lindex $args end]" + return +# return [tcltest::normalPuts -nonewline [lindex $args end]] + } else { + set channel [lindex $args 0] + } + } elseif {$len == 3} { + if {[lindex $args 0] == "-nonewline"} { + # Both -nonewline and channelId are specified, unless it's an + # error. -nonewline is supposed to be argv[0]. + set channel [lindex $args 1] + } + } -proc ::tcltest::loadTestedCommands {} { - if {$::tcltest::loadScript == {}} { + if {[info exists channel]} { + if {($channel == [outputChannel]) || ($channel == "stdout")} { + append tcltest::outData "[lindex $args end]\n" + } elseif {($channel == [errorChannel]) || ($channel == "stderr")} { + append tcltest::errData "[lindex $args end]\n" + } return + # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]] } - - uplevel #0 $::tcltest::loadScript + + # If we haven't returned by now, we don't know how to handle the input. + # Let puts handle it. + return [eval tcltest::normalPuts $args] } -# ::tcltest::cleanupTests -- +# tcltest::testEval -- # -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. +# Evaluate the script in the test environment. If ignoreOutput is +# false, store data sent to stderr and stdout in tcltest::outData and +# tcltest::errData. Otherwise, ignore this output altogether. # -# Print the names of the files created without the makeFile command -# since the tests were invoked. +# Arguments: +# script Script to evaluate +# ?ignoreOutput? Indicates whether or not to ignore output sent to +# stdout & stderr # -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). - -proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { - - set testFileName [file tail [info script]] +# Results: +# result from running the script +# +# Side effects: +# Empties the contents of tcltest::outData and tcltest::errData before +# running a test if ignoreOutput is set to 0. - # Call the cleanup hook - ::tcltest::cleanupTestsHook +proc tcltest::testEval {script {ignoreOutput 1}} { + DebugPuts 3 "testEval called" + if {!$ignoreOutput} { + set tcltest::outData {} + set tcltest::errData {} + uplevel rename ::puts tcltest::normalPuts + uplevel rename tcltest::testPuts ::puts + } + set result [uplevel $script] + if {!$ignoreOutput} { + uplevel rename ::puts tcltest::testPuts + uplevel rename tcltest::normalPuts ::puts + } + return $result +} - # Remove files and directories created by the :tcltest::makeFile and - # ::tcltest::makeDirectory procedures. - # Record the names of files in ::tcltest::workingDirectory that were not - # pre-existing, and associate them with the test file that created them. +# compareStrings -- +# +# compares the expected answer to the actual answer, depending on the +# mode provided. Mode determines whether a regexp, exact, or glob +# comparison is done. +# +# Arguments: +# actual - string containing the actual result +# expected - pattern to be matched against +# mode - type of comparison to be done +# +# Results: +# result of the match +# +# Side effects: +# None. - if {!$calledFromAllFile} { - foreach file $::tcltest::filesMade { - if {[file exists $file]} { - catch {file delete -force $file} - } +proc tcltest::compareStrings {actual expected mode} { + switch -- $mode { + exact { + set retval [string equal $actual $expected] } - set currentFiles {} - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend currentFiles [file tail $file] + glob { + set retval [string match $expected $actual] } - set newFiles {} - foreach file $currentFiles { - if {[lsearch -exact $::tcltest::filesExisted $file] == -1} { - lappend newFiles $file - } - } - set ::tcltest::filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set ::tcltest::createdNewFiles($testFileName) $newFiles + regexp { + set retval [regexp -- $expected $actual] } } + return $retval +} - if {$calledFromAllFile || $::tcltest::testSingleFile} { - # print stats +# +# tcltest::substArguments list +# +# This helper function takes in a list of words, then perform a +# substitution on the list as though each word in the list is a +# separate argument to the Tcl function. For example, if this +# function is invoked as: +# +# substArguments {$a {$a}} +# +# Then it is as though the function is invoked as: +# +# substArguments $a {$a} +# +# This code is adapted from Paul Duffin's function "SplitIntoWords". +# The original function can be found on: +# +# http://purl.org/thecliff/tcl/wiki/858.html +# +# Results: +# a list containing the result of the substitution +# +# Exceptions: +# An error may occur if the list containing unbalanced quote or +# unknown variable. +# +# Side Effects: +# None. +# + +proc tcltest::substArguments {argList} { + + # We need to split the argList up into tokens but cannot use + # list operations as they throw away some significant + # quoting, and [split] ignores braces as it should. + # Therefore what we do is gradually build up a string out of + # whitespace seperated strings. We cannot use [split] to + # split the argList into whitespace seperated strings as it + # throws away the whitespace which maybe important so we + # have to do it all by hand. + + set result {} + set token "" + + while {[string length $argList]} { + # Look for the next word containing a quote: " { } + if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ + $argList all]} { + # Get the text leading up to this word, but not + # including this word, from the argList. + set text [string range $argList 0 \ + [expr {[lindex $all 0] - 1}]] + # Get the word with the quote + set word [string range $argList \ + [lindex $all 0] [lindex $all 1]] + + # Remove all text up to and including the word from the + # argList. + set argList [string range $argList \ + [expr {[lindex $all 1] + 1}] end] + } else { + # Take everything up to the end of the argList. + set text $argList + set word {} + set argList {} + } + + if {$token != {}} { + # If we saw a word with quote before, then there is a + # multi-word token starting with that word. In this case, + # add the text and the current word to this token. + append token $text $word + } else { + # Add the text to the result. There is no need to parse + # the text because it couldn't be a part of any multi-word + # token. Then start a new multi-word token with the word + # because we need to pass this token to the Tcl parser to + # check for balancing quotes + append result $text + set token $word + } + + if { [catch {llength $token} length] == 0 && $length == 1} { + # The token is a valid list so add it to the result. + # lappend result [string trim $token] + append result \{$token\} + set token {} + } + } - puts -nonewline $::tcltest::outputChannel "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline $::tcltest::outputChannel \ - "\t$index\t$::tcltest::numTests($index)" - } - puts $::tcltest::outputChannel "" + # If the last token has not been added to the list then there + # is a problem. + if { [string length $token] } { + error "incomplete token \"$token\"" + } - # print number test files sourced - # print names of files that ran tests which failed + return $result +} - if {$calledFromAllFile} { - puts $::tcltest::outputChannel \ - "Sourced $::tcltest::numTestFiles Test Files." - set ::tcltest::numTestFiles 0 - if {[llength $::tcltest::failFiles] > 0} { - puts $::tcltest::outputChannel \ - "Files with failing tests: $::tcltest::failFiles" - set ::tcltest::failFiles {} - } - } - # if any tests were skipped, print the constraints that kept them - # from running. +# tcltest::test -- +# +# This procedure runs a test and prints an error message if the test fails. +# If tcltest::verbose has been set, it also prints a message even if the +# test succeeds. The test will be skipped if it doesn't match the +# tcltest::match variable, if it matches an element in +# tcltest::skip, or if one of the elements of "constraints" turns +# out not to be true. +# +# If testLevel is 1, then this is a top level test, and we record pass/fail +# information; otherwise, this information is not logged and is not added to +# running totals. +# +# Attributes: +# Only description is a required attribute. All others are optional. +# Default values are indicated. +# +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "tcltest::testConstraints". If any +# of these elements is zero, the test is +# skipped. This attribute is optional; default is {} +# body - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. This attribute is optional; +# default is {} +# result - Expected result from script. This attribute is +# optional; default is {}. +# output - Expected output sent to stdout. This attribute +# is optional; default is {}. +# errorOutput - Expected output sent to stderr. This attribute +# is optional; default is {}. +# returnCodes - Expected return codes. This attribute is +# optional; default is {0 2}. +# setup - Code to run before $script (above). This +# attribute is optional; default is {}. +# cleanup - Code to run after $script (above). This +# attribute is optional; default is {}. +# match - specifies type of matching to do on result, +# output, errorOutput; this must be one of: exact, +# glob, regexp. default is exact. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# +# Results: +# 0 if the command ran successfully; 1 otherwise. +# +# Side effects: +# None. +# - set constraintList [array names ::tcltest::skippedBecause] - if {[llength $constraintList] > 0} { - puts $::tcltest::outputChannel \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts $::tcltest::outputChannel \ - "\t$::tcltest::skippedBecause($constraint)\t$constraint" - unset ::tcltest::skippedBecause($constraint) - } - } +proc tcltest::test {name description args} { + DebugPuts 3 "Test $name $args" - # report the names of test files in ::tcltest::createdNewFiles, and - # reset the array to be empty. + incr tcltest::testLevel - set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts $::tcltest::outputChannel "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts $::tcltest::outputChannel \ - "\t$testFile:\t$::tcltest::createdNewFiles($testFile)" - unset ::tcltest::createdNewFiles($testFile) + # Pre-define everything to null except output and errorOutput. We + # determine whether or not to trap output based on whether or not these + # variables (output & errorOutput) are defined. + foreach item {constraints setup cleanup body result returnCodes match} { + set $item {} + } + + # Set the default match mode + set match exact + + # Set the default match values for return codes (0 is the standard expected + # return value if everything went well; 2 represents 'return' being used in + # the test script). + set returnCodes [list 0 2] + + # The old test format can't have a 3rd argument (constraints or script) + # that starts with '-'. + if {[llength $args] == 0} { + puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}" + incr tcltest::testLevel -1 + return 1 + } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} { + + if {[llength $args] == 1} { + set list [substArguments [lindex $args 0]] + foreach {element value} $list { + set testAttributes($element) $value + } + foreach item {constraints match setup body cleanup \ + result returnCodes output errorOutput} { + if {[info exists testAttributes([subst -$item])]} { + set testAttributes([subst -$item]) \ + [uplevel concat $testAttributes([subst -$item])] + } } + } else { + array set testAttributes $args } - # reset filesMade, filesExisted, and numTests + set validFlags {-setup -cleanup -body -result -returnCodes -match \ + -output -errorOutput -constraints} - set ::tcltest::filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set ::tcltest::numTests($index) 0 + foreach flag [array names testAttributes] { + if {[lsearch -exact $validFlags $flag] == -1} { + puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test" + incr tcltest::testLevel -1 + return 1 + } } - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && ![info exists tcl_interactive]} { - exit + # store whatever the user gave us + foreach item [array names testAttributes] { + set [string trimleft $item "-"] $testAttributes($item) } - } else { - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed + # Check the values supplied for -match + if {[lsearch {regexp glob exact} $match] == -1} { + puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}" + incr tcltest::testLevel -1 + return 1 + } - incr ::tcltest::numTestFiles - if {($::tcltest::currentFailure) && \ - ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} { - lappend ::tcltest::failFiles $testFileName + # Replace symbolic valies supplied for -returnCodes + regsub -nocase normal $returnCodes 0 returnCodes + regsub -nocase error $returnCodes 1 returnCodes + regsub -nocase return $returnCodes 2 returnCodes + regsub -nocase break $returnCodes 3 returnCodes + regsub -nocase continue $returnCodes 4 returnCodes + } else { + # This is parsing for the old test command format; it is here for + # backward compatibility. + set result [lindex $args end] + if {[llength $args] == 2} { + set body [lindex $args 0] + } elseif {[llength $args] == 3} { + set constraints [lindex $args 0] + set body [lindex $args 1] + } else { + puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}" + incr tcltest::testLevel -1 + return 1 } - set ::tcltest::currentFailure false + } - # restore the environment to the state it was in before this package - # was loaded + set setupFailure 0 + set cleanupFailure 0 - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists ::tcltest::originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { - if {$::env($index) != $::tcltest::originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $::tcltest::originalEnv($index) - } - } + # Run the setup script + if {[catch {uplevel $setup} setupMsg]} { + set setupFailure 1 + } + + # run the test script + set command [list tcltest::runTest $name $description $body \ + $result $constraints] + if {!$setupFailure} { + if {[info exists output] || [info exists errorOutput]} { + set testResult [uplevel tcltest::testEval [list $command] 0] + } else { + set testResult [uplevel tcltest::testEval [list $command] 1] } - foreach index [array names ::tcltest::originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $::tcltest::originalEnv($index) + } else { + set testResult setupFailure + } + + # Run the cleanup code + if {[catch {uplevel $cleanup} cleanupMsg]} { + set cleanupFailure 1 + } + + # If testResult is an empty list, then the test was skipped + if {$testResult != {}} { + set coreFailure 0 + set coreMsg "" + # check for a core file first - if one was created by the test, then + # the test failed + if {$tcltest::preserveCore} { + set currentTclPlatform [array get tcl_platform] + if {[file exists [file join [tcltest::workingDirectory] core]]} { + # There's only a test failure if there is a core file and (1) + # there previously wasn't one or (2) the new one is different + # from the old one. + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [tcltest::workingDirectory] core]]} { + set coreFailure 1 + } + } else { + set coreFailure 1 + } + + if {($tcltest::preserveCore > 1) && ($coreFailure)} { + append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]" + catch {file rename -force \ + [file join [tcltest::workingDirectory] core] \ + [file join $tcltest::temporaryDirectory \ + core-$name]} msg + if {[string length $msg] > 0} { + append coreMsg "\nError: Problem renaming core file: $msg" + } + } } + array set tcl_platform $currentTclPlatform } - if {[llength $newEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements changed:\t$changedEnv" + + set actualAnswer [lindex $testResult 0] + set code [lindex $testResult end] + + # If expected output/error strings exist, we have to compare + # them. If the comparison fails, then so did the test. + set outputFailure 0 + set errorFailure 0 + if {[info exists output]} { + set outputFailure [expr ![compareStrings $tcltest::outData \ + $output $match]] + } + if {[info exists errorOutput]} { + set errorFailure [expr ![compareStrings $tcltest::errData \ + $errorOutput $match]] } - if {[llength $removedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements removed:\t$removedEnv" + + set testFailed 1 + set codeFailure 0 + set scriptFailure 0 + + # check if the return code matched the expected return code + if {[lsearch -exact $returnCodes $code] == -1} { + set codeFailure 1 + } + + # check if the answer matched the expected answer + if {[compareStrings $actualAnswer $result $match] == 0} { + set scriptFailure 1 } - set changedTclPlatform {} - foreach index [array names ::tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $::tcltest::originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $::tcltest::originalTclPlatform($index) + # if we didn't experience any failures, then we passed + if {!($setupFailure || $cleanupFailure || $coreFailure || \ + $outputFailure || $errorFailure || $codeFailure || \ + $scriptFailure)} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Passed) + if {[tcltest::isVerbose pass]} { + puts [outputChannel] "++++ $name PASSED" + } } + set testFailed 0 } - if {[llength $changedTclPlatform] > 0} { - puts $::tcltest::outputChannel \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "produced core file! \ - Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" - flush $::tcltest::outputChannel - catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" + if {$testFailed} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Failed) + } + set tcltest::currentFailure true + if {![tcltest::isVerbose body]} { + set body "" + } + puts [outputChannel] "\n==== $name [string trim $description] FAILED" + if {$body != ""} { + puts [outputChannel] "==== Contents of test case:" + puts [outputChannel] $body + } + if {$setupFailure} { + puts [outputChannel] "---- Test setup failed:\n$setupMsg" + } + if {$scriptFailure} { + puts [outputChannel] "---- Result was:\n$actualAnswer" + puts [outputChannel] "---- Result should have been ($match matching):\n$result" + } + if {$codeFailure} { + switch -- $code { + 0 { set msg "Test completed normally" } + 1 { set msg "Test generated error" } + 2 { set msg "Test generated return exception" } + 3 { set msg "Test generated break exception" } + 4 { set msg "Test generated continue exception" } + default { set msg "Test generated exception" } } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists ::tcltest::coreModificationTime]} { - if {$::tcltest::coreModificationTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "A core file was created!" + puts [outputChannel] "---- $msg; Return code was: $code" + puts [outputChannel] "---- Return code should have been one of: $returnCodes" + if {[tcltest::isVerbose error]} { + if {[info exists ::errorInfo]} { + puts [outputChannel] "---- errorInfo: $::errorInfo" + puts [outputChannel] "---- errorCode: $::errorCode" } - } else { - puts $::tcltest::outputChannel "A core file was created!" - } + } + } + if {$outputFailure} { + puts [outputChannel] "---- Output was:\n$tcltest::outData" + puts [outputChannel] "---- Output should have been ($match matching):\n$output" + } + if {$errorFailure} { + puts [outputChannel] "---- Error output was:\n$tcltest::errData" + puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput" + } + if {$cleanupFailure} { + puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" } + if {$coreFailure} { + puts [outputChannel] "---- Core file produced while running test! $coreMsg" + } + puts [outputChannel] "==== $name FAILED\n" + } } + + incr tcltest::testLevel -1 + return 0 } -# ::tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { - proc ::tcltest::cleanupTestsHook {} {} -} -# test -- +# runTest -- # +# This is the defnition of the version 1.0 test routine for tcltest. It is +# provided here for backward compatibility. It is also used as the 'backbone' +# of the test procedure, as in, this is where all the work really gets done. +# # This procedure runs a test and prints an error message if the test fails. -# If ::tcltest::verbose has been set, it also prints a message even if the +# If tcltest::verbose has been set, it also prints a message even if the # test succeeds. The test will be skipped if it doesn't match the -# ::tcltest::match variable, if it matches an element in -# ::tcltest::skip, or if one of the elements of "constraints" turns +# tcltest::match variable, if it matches an element in +# tcltest::skip, or if one of the elements of "constraints" turns # out not to be true. # # Arguments: @@ -1364,81 +2429,93 @@ if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { # help humans understand what it does. # constraints - A list of one or more keywords, each of # which must be the name of an element in -# the array "::tcltest::testConstraints". If any of these +# the array "tcltest::testConstraints". If any of these # elements is zero, the test is skipped. # This argument may be omitted. # script - Script to run to carry out the test. It must # return a result that can be checked for # correctness. # expectedAnswer - Expected result from script. +# +# Behavior depends on the value of testLevel; if testLevel is 1 (top level), +# then events are logged and we track the number of tests run/skipped and why. +# Otherwise, we don't track this information. +# +# Results: +# empty list if test is skipped; otherwise returns list containing +# actual returned value from the test and the return code. +# +# Side Effects: +# none. +# -proc ::tcltest::test {name description script expectedAnswer args} { - - DebugPuts 3 "Running $name ($description)" - - incr ::tcltest::numTests(Total) +proc tcltest::runTest {name description script expectedAnswer constraints} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Total) + } + # skip the test if it's name matches an element of skip - - foreach pattern $::tcltest::skip { + foreach pattern $tcltest::skip { if {[string match $pattern $name]} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip} + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip} + } return } } # skip the test if it's name doesn't match any element of match - - if {[llength $::tcltest::match] > 0} { + if {[llength $tcltest::match] > 0} { set ok 0 - foreach pattern $::tcltest::match { + foreach pattern $tcltest::match { if {[string match $pattern $name]} { set ok 1 break } } if {!$ok} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch} + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch} + } return } } - set i [llength $args] - if {$i == 0} { - set constraints {} + DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints" + + if {$constraints == {}} { # If we're limited to the listed constraints and there aren't any # listed, then we shouldn't run the test. - if {$::tcltest::limitConstraints} { - ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint - incr ::tcltest::numTests(Skipped) + if {$tcltest::limitConstraints} { + tcltest::AddToSkippedBecause userSpecifiedLimitConstraint + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + } return } - } elseif {$i == 1} { - - # "constraints" argument exists; shuffle arguments down, then + } else { + # "constraints" argument exists; # make sure that the constraints are satisfied. - set constraints $script - set script $expectedAnswer - set expectedAnswer [lindex $args 0] set doTest 0 if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 expr $constraints]} } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { # something like {a || b} should be turned into - # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$::tcltest::testConstraints(&)} c + # $tcltest::testConstraints(a) || $tcltest::testConstraints(b). + regsub -all {[.\w]+} $constraints \ + {$tcltest::testConstraints(&)} c catch {set doTest [eval expr $c]} } else { # just simple constraints such as {unixOnly fonts}. set doTest 1 foreach constraint $constraints { - if {(![info exists ::tcltest::testConstraints($constraint)]) \ - || (!$::tcltest::testConstraints($constraint))} { + if {(![info exists tcltest::testConstraints($constraint)]) \ + || (!$tcltest::testConstraints($constraint))} { set doTest 0 # store the constraint that kept the test from running @@ -1447,28 +2524,30 @@ proc ::tcltest::test {name description script expectedAnswer args} { } } } + if {$doTest == 0} { - if {[string first s $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints" + if {[tcltest::isVerbose skip]} { + puts [outputChannel] "++++ $name SKIPPED: $constraints" + } + + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + tcltest::AddToSkippedBecause $constraints } - - incr ::tcltest::numTests(Skipped) - ::tcltest::AddToSkippedBecause $constraints return } - } else { - error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" - } + } # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with tcl_platform. + # tcl_platform environment because some of the tests mess with + # tcl_platform. - if {$::tcltest::preserveCore} { + if {$tcltest::preserveCore} { set currentTclPlatform [array get tcl_platform] - array set tcl_platform $::tcltest::originalTclPlatform - if {[file exists [file join $::tcltest::workingDirectory core]]} { + array set tcl_platform $tcltest::originalTclPlatform + if {[file exists [file join [tcltest::workingDirectory] core]]} { set coreModTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + [tcltest::workingDirectory] core]] } array set tcl_platform $currentTclPlatform } @@ -1480,107 +2559,288 @@ proc ::tcltest::test {name description script expectedAnswer args} { memory tag $name } + if {[tcltest::isVerbose start]} { + puts [outputChannel] "---- $name start" + flush [outputChannel] + } + set code [catch {uplevel $script} actualAnswer] - if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} { - incr ::tcltest::numTests(Passed) - if {[string first p $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name PASSED" + + return [list $actualAnswer $code] +} + +##################################################################### + +# tcltest::cleanupTestsHook -- +# +# This hook allows a harness that builds upon tcltest to specify +# additional things that should be done at cleanup. +# + +if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} { + proc tcltest::cleanupTestsHook {} {} +} + +# tcltest::cleanupTests -- +# +# Remove files and dirs created using the makeFile and makeDirectory +# commands since the last time this proc was invoked. +# +# Print the names of the files created without the makeFile command +# since the tests were invoked. +# +# Print the number tests (total, passed, failed, and skipped) since the +# tests were invoked. +# +# Restore original environment (as reported by special variable env). +# +# Arguments: +# calledFromAllFile - if 0, behave as if we are running a single test file +# within an entire suite of tests. if we aren't running a single test +# file, then don't report status. check for new files created during the +# test run and report on them. if 1, report collated status from all the +# test file runs. +# +# Results: +# None. +# +# Side Effects: +# None +# + +proc tcltest::cleanupTests {{calledFromAllFile 0}} { + + set testFileName [file tail [info script]] + + # Call the cleanup hook + tcltest::cleanupTestsHook + + # Remove files and directories created by the :tcltest::makeFile and + # tcltest::makeDirectory procedures. + # Record the names of files in tcltest::workingDirectory that were not + # pre-existing, and associate them with the test file that created them. + + if {!$calledFromAllFile} { + foreach file $tcltest::filesMade { + if {[file exists $file]} { + catch {file delete -force $file} + } + } + set currentFiles {} + foreach file [glob -nocomplain \ + [file join $tcltest::temporaryDirectory *]] { + lappend currentFiles [file tail $file] + } + set newFiles {} + foreach file $currentFiles { + if {[lsearch -exact $tcltest::filesExisted $file] == -1} { + lappend newFiles $file + } + } + set tcltest::filesExisted $currentFiles + if {[llength $newFiles] > 0} { + set tcltest::createdNewFiles($testFileName) $newFiles + } + } + + if {$calledFromAllFile || $tcltest::testSingleFile} { + + # print stats + + puts -nonewline [outputChannel] "$testFileName:" + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + puts -nonewline [outputChannel] \ + "\t$index\t$tcltest::numTests($index)" + } + puts [outputChannel] "" + + # print number test files sourced + # print names of files that ran tests which failed + + if {$calledFromAllFile} { + puts [outputChannel] \ + "Sourced $tcltest::numTestFiles Test Files." + set tcltest::numTestFiles 0 + if {[llength $tcltest::failFiles] > 0} { + puts [outputChannel] \ + "Files with failing tests: $tcltest::failFiles" + set tcltest::failFiles {} + } + } + + # if any tests were skipped, print the constraints that kept them + # from running. + + set constraintList [array names tcltest::skippedBecause] + if {[llength $constraintList] > 0} { + puts [outputChannel] \ + "Number of tests skipped for each constraint:" + foreach constraint [lsort $constraintList] { + puts [outputChannel] \ + "\t$tcltest::skippedBecause($constraint)\t$constraint" + unset tcltest::skippedBecause($constraint) + } + } + + # report the names of test files in tcltest::createdNewFiles, and + # reset the array to be empty. + + set testFilesThatTurded [lsort [array names tcltest::createdNewFiles]] + if {[llength $testFilesThatTurded] > 0} { + puts [outputChannel] "Warning: files left behind:" + foreach testFile $testFilesThatTurded { + puts [outputChannel] \ + "\t$testFile:\t$tcltest::createdNewFiles($testFile)" + unset tcltest::createdNewFiles($testFile) + } + } + + # reset filesMade, filesExisted, and numTests + + set tcltest::filesMade {} + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + set tcltest::numTests($index) 0 + } + + # exit only if running Tk in non-interactive mode + + global tk_version tcl_interactive + if {[info exists tk_version] && ![info exists tcl_interactive]} { + exit } } else { - incr ::tcltest::numTests(Failed) - set ::tcltest::currentFailure true - if {[string first b $::tcltest::verbose] == -1} { - set script "" - } - puts $::tcltest::outputChannel "\n==== $name $description FAILED" - if {$script != ""} { - puts $::tcltest::outputChannel "==== Contents of test case:" - puts $::tcltest::outputChannel $script - } - if {$code != 0} { - if {$code == 1} { - puts $::tcltest::outputChannel "==== Test generated error:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 2} { - puts $::tcltest::outputChannel "==== Test generated return exception; result was:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 3} { - puts $::tcltest::outputChannel "==== Test generated break exception" - } elseif {$code == 4} { - puts $::tcltest::outputChannel "==== Test generated continue exception" + + # if we're deferring stat-reporting until all files are sourced, + # then add current file to failFile list if any tests in this file + # failed + + incr tcltest::numTestFiles + if {($tcltest::currentFailure) && \ + ([lsearch -exact $tcltest::failFiles $testFileName] == -1)} { + lappend tcltest::failFiles $testFileName + } + set tcltest::currentFailure false + + # restore the environment to the state it was in before this package + # was loaded + + set newEnv {} + set changedEnv {} + set removedEnv {} + foreach index [array names ::env] { + if {![info exists tcltest::originalEnv($index)]} { + lappend newEnv $index + unset ::env($index) } else { - puts $::tcltest::outputChannel "==== Test generated exception $code; message was:" - puts $::tcltest::outputChannel $actualAnswer + if {$::env($index) != $tcltest::originalEnv($index)} { + lappend changedEnv $index + set ::env($index) $tcltest::originalEnv($index) + } } - } else { - puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer" } - puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer" - puts $::tcltest::outputChannel "==== $name FAILED\n" - } - if {$::tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "==== $name produced core file! \ + foreach index [array names tcltest::originalEnv] { + if {![info exists ::env($index)]} { + lappend removedEnv $index + set ::env($index) $tcltest::originalEnv($index) + } + } + if {[llength $newEnv] > 0} { + puts [outputChannel] \ + "env array elements created:\t$newEnv" + } + if {[llength $changedEnv] > 0} { + puts [outputChannel] \ + "env array elements changed:\t$changedEnv" + } + if {[llength $removedEnv] > 0} { + puts [outputChannel] \ + "env array elements removed:\t$removedEnv" + } + + set changedTclPlatform {} + foreach index [array names tcltest::originalTclPlatform] { + if {$::tcl_platform($index) != \ + $tcltest::originalTclPlatform($index)} { + lappend changedTclPlatform $index + set ::tcl_platform($index) \ + $tcltest::originalTclPlatform($index) + } + } + if {[llength $changedTclPlatform] > 0} { + puts [outputChannel] \ + "tcl_platform array elements changed:\t$changedTclPlatform" + } + + if {[file exists [file join [tcltest::workingDirectory] core]]} { + if {$tcltest::preserveCore > 1} { + puts "rename core file (> 1)" + puts [outputChannel] "produced core file! \ Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" + [file join $tcltest::temporaryDirectory core-$name]" catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg + [file join [tcltest::workingDirectory] core] \ + [file join $tcltest::temporaryDirectory \ + core-$name]} msg if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" + tcltest::PrintError "Problem renaming file: $msg" } } else { # Print a message if there is a core file and (1) there # previously wasn't one or (2) the new one is different from # the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "==== $name produced core file!" + if {[info exists tcltest::coreModificationTime]} { + if {$tcltest::coreModificationTime != [file mtime \ + [file join [tcltest::workingDirectory] core]]} { + puts [outputChannel] "A core file was created!" } } else { - puts $::tcltest::outputChannel "==== $name produced core file!" + puts [outputChannel] "A core file was created!" } } } - array set tcl_platform $currentTclPlatform } + flush [outputChannel] + flush [errorChannel] + return } -# ::tcltest::getMatchingFiles +##################################################################### + +# Procs that determine which tests/test files to run + +# tcltest::getMatchingFiles # # Looks at the patterns given to match and skip files # and uses them to put together a list of the tests that will be run. # # Arguments: -# none +# directory to search # # Results: # The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. +# be used in 'all.tcl' files. It is used in runAllTests. +# +# Side Effects: +# None -proc ::tcltest::getMatchingFiles {args} { - set matchingFiles {} - if {[llength $args]} { - set searchDirectory $args - } else { - set searchDirectory [list $::tcltest::testsDirectory] +proc tcltest::getMatchingFiles { {searchDirectory ""} } { + if {[llength [info level 0]] == 1} { + set searchDirectory [tcltest::testsDirectory] } + set matchingFiles {} + # Find the matching files in the list of directories and then remove the # ones that match the skip pattern foreach directory $searchDirectory { set matchFileList {} - foreach match $::tcltest::matchFiles { + foreach match $tcltest::matchFiles { set matchFileList [concat $matchFileList \ [glob -nocomplain [file join $directory $match]]] } - if {[string compare {} $::tcltest::skipFiles]} { + if {[string compare {} $tcltest::skipFiles]} { set skipFileList {} - foreach skip $::tcltest::skipFiles { + foreach skip $tcltest::skipFiles { set skipFileList [concat $skipFileList \ [glob -nocomplain [file join $directory $skip]]] } @@ -1597,35 +2857,213 @@ proc ::tcltest::getMatchingFiles {args} { } } if {[string equal $matchingFiles {}]} { - ::tcltest::PrintError "No test files remain after applying \ + tcltest::PrintError "No test files remain after applying \ your match and skip patterns!" } return $matchingFiles } -# The following two procs are used in the io tests. - -proc ::tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} +# tcltest::getMatchingDirectories -- +# +# Looks at the patterns given to match and skip directories and uses them +# to put together a list of the test directories that we should attempt +# to run. (Only subdirectories containing an "all.tcl" file are put into +# the list.) +# +# Arguments: +# root directory from which to search +# +# Results: +# The constructed list is returned to the user. This is used in the +# primary all.tcl file. Lower-level all.tcl files should use the +# tcltest::testAllFiles proc instead. +# +# Side Effects: +# None. + +proc tcltest::getMatchingDirectories {rootdir} { + set matchingDirs {} + set matchDirList {} + # Find the matching directories in tcltest::testsDirectory and then + # remove the ones that match the skip pattern + foreach match $tcltest::matchDirectories { + foreach file [glob -nocomplain [file join $rootdir $match]] { + if {([file isdirectory $file]) && ($file != $rootdir)} { + set matchDirList [concat $matchDirList \ + [tcltest::getMatchingDirectories $file]] + if {[file exists [file join $file all.tcl]]} { + set matchDirList [concat $matchDirList $file] + } + } + } } - return $result + if {$tcltest::skipDirectories != {}} { + set skipDirs {} + foreach skip $tcltest::skipDirectories { + set skipDirs [concat $skipDirs \ + [glob -nocomplain [file join $tcltest::testsDirectory \ + $skip]]] + } + foreach dir $matchDirList { + # Only include directories that don't match the skip pattern + if {[lsearch -exact $skipDirs $dir] == -1} { + lappend matchingDirs $dir + } + } + } else { + set matchingDirs [concat $matchingDirs $matchDirList] + } + if {$matchingDirs == {}} { + DebugPuts 1 "No test directories remain after applying match and skip patterns!" + } + return $matchingDirs } -proc ::tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} +# tcltest::runAllTests -- +# +# prints output and sources test files according to the match and skip +# patterns provided. after sourcing test files, it goes on to source +# all.tcl files in matching test subdirectories. +# +# Arguments: +# shell being tested +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::runAllTests { {shell ""} } { + global argv + + if {[llength [info level 0]] == 1} { + set shell [tcltest::interpreter] } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p + + set tcltest::testSingleFile false + + puts [outputChannel] "Tests running in interp: $shell" + puts [outputChannel] "Tests located in: $tcltest::testsDirectory" + puts [outputChannel] "Tests running in: [tcltest::workingDirectory]" + puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory" + if {[tcltest::singleProcess]} { + puts [outputChannel] "Test files sourced into current interpreter" + } else { + puts [outputChannel] "Test files run in separate interpreters" + } + if {[llength $tcltest::skip] > 0} { + puts [outputChannel] "Skipping tests that match: $tcltest::skip" + } + if {[llength $tcltest::match] > 0} { + puts [outputChannel] "Only running tests that match: $tcltest::match" + } + + if {[llength $tcltest::skipFiles] > 0} { + puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles" + } + if {[llength $tcltest::matchFiles] > 0} { + puts [outputChannel] "Only running test files that match: $tcltest::matchFiles" + } + + set timeCmd {clock format [clock seconds]} + puts [outputChannel] "Tests began at [eval $timeCmd]" + + # Run each of the specified tests + foreach file [lsort [tcltest::getMatchingFiles]] { + set tail [file tail $file] + puts [outputChannel] $tail + + if {$tcltest::singleProcess} { + incr tcltest::numTestFiles + uplevel [list source $file] + } else { + # Change to the tests directory so the value of the following + # variable is set correctly when we spawn the child test processes + cd $tcltest::testsDirectory + set cmd [concat [list | $shell $file] [split $argv]] + if {[catch { + incr tcltest::numTestFiles + set pipeFd [open $cmd "r"] + while {[gets $pipeFd line] >= 0} { + if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + incr tcltest::numTests($index) [set $index] + } + if {$Failed > 0} { + lappend tcltest::failFiles $testFile + } + } elseif {[regexp {^Number of tests skipped for each constraint:|^\t(\d+)\t(.+)$} $line match skipped constraint]} { + if {$match != "Number of tests skipped for each constraint:"} { + tcltest::AddToSkippedBecause $constraint $skipped + } + } else { + puts [outputChannel] $line + } + } + close $pipeFd + } msg]} { + # Print results to tcltest::outputChannel. + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported later + lappend testFileFailures $file + } } } - return $leak + + # cleanup + puts [outputChannel] "\nTests ended at [eval $timeCmd]" + tcltest::cleanupTests 1 + if {[info exists testFileFailures]} { + puts [outputChannel] "\nTest files exiting with errors: \n" + foreach file $testFileFailures { + puts " [file tail $file]\n" + } + } + + # Checking for subdirectories in which to run tests + foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] { + set dir [file tail $directory] + puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + puts [outputChannel] "$dir test began at [eval $timeCmd]\n" + + uplevel "source [file join $directory all.tcl]" + + set endTime [eval $timeCmd] + puts [outputChannel] "\n$dir test ended at $endTime" + puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + } + return +} + +##################################################################### + +# Test utility procs - not used in tcltest, but may be useful for testing. + +# tcltest::loadTestedCommands -- +# +# Uses the specified script to load the commands to test. Allowed to +# be empty, as the tested commands could have been compiled into the +# interpreter. +# +# Arguments +# none +# +# Results +# none +# +# Side Effects: +# none. + +proc tcltest::loadTestedCommands {} { + if {$tcltest::loadScript == {}} { + return + } + + return [uplevel $tcltest::loadScript] } -# ::tcltest::saveState -- +# tcltest::saveState -- # # Save information regarding what procs and variables exist. # @@ -1633,58 +3071,71 @@ proc ::tcltest::leakfiles {old} { # none # # Results: -# Modifies the variable ::tcltest::saveState +# Modifies the variable tcltest::saveState +# +# Side effects: +# None. -proc ::tcltest::saveState {} { - uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState" +proc tcltest::saveState {} { + uplevel {set tcltest::saveState [list [info procs] [info vars]]} + DebugPuts 2 "tcltest::saveState: $tcltest::saveState" + return } -# ::tcltest::restoreState -- +# tcltest::restoreState -- # # Remove procs and variables that didn't exist before the call to -# ::tcltest::saveState. +# tcltest::saveState. # # Arguments: # none # # Results: # Removes procs and variables from your environment if they don't exist -# in the ::tcltest::saveState variable. +# in the tcltest::saveState variable. +# +# Side effects: +# None. -proc ::tcltest::restoreState {} { +proc tcltest::restoreState {} { foreach p [info procs] { - if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \ - (![string equal ::tcltest::$p [namespace origin $p]])} { + if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \ + (![string match "*tcltest::$p" [namespace origin $p]])} { - DebugPuts 2 "::tcltest::restoreState: Removing proc $p" + DebugPuts 2 "tcltest::restoreState: Removing proc $p" rename $p {} } } - foreach p [uplevel #0 {info vars}] { - if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { - DebugPuts 2 "::tcltest::restoreState: Removing variable $p" - uplevel #0 "catch {unset $p}" + foreach p [uplevel {info vars}] { + if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} { + DebugPuts 2 "tcltest::restoreState: Removing variable $p" + uplevel "catch {unset $p}" } } + return } -# ::tcltest::normalizeMsg -- +# tcltest::normalizeMsg -- # # Removes "extra" newlines from a string. # # Arguments: # msg String to be modified # +# Results: +# string with extra newlines removed +# +# Side effects: +# None. -proc ::tcltest::normalizeMsg {msg} { +proc tcltest::normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg regsub -all "\n\n" $msg "\n" msg regsub -all "\n\}" $msg "\}" msg return $msg } -# makeFile -- +# tcltest::makeFile -- # # Create a new file with the name <name>, and write <contents> to it. # @@ -1692,12 +3143,28 @@ proc ::tcltest::normalizeMsg {msg} { # cleanupTests was called, add it to the $filesMade list, so it will # be removed by the next call to cleanupTests. # -proc ::tcltest::makeFile {contents name} { +# Arguments: +# contents content of the new file +# name name of the new file +# directory directory name for new file +# +# Results: +# absolute path to the file created +# +# Side effects: +# None. + +proc tcltest::makeFile {contents name {directory ""}} { global tcl_platform + + if {[llength [info level 0]] == 3} { + set directory [tcltest::temporaryDirectory] + } - DebugPuts 3 "::tcltest::makeFile: putting $contents into $name" + set fullName [file join $directory $name] + + DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" - set fullName [file join $::tcltest::temporaryDirectory $name] set fd [open $fullName w] fconfigure $fd -translation lf @@ -1709,26 +3176,36 @@ proc ::tcltest::makeFile {contents name} { } close $fd - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName + if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { + lappend tcltest::filesMade $fullName } return $fullName } -# ::tcltest::removeFile -- +# tcltest::removeFile -- # # Removes the named file from the filesystem # # Arguments: -# name file to be removed +# name file to be removed +# directory directory from which to remove file # +# Results: +# return value from [file delete] +# +# Side effects: +# None. -proc ::tcltest::removeFile {name} { - DebugPuts 3 "::tcltest::removeFile: removing $name" - file delete [file join $::tcltest::temporaryDirectory $name] +proc tcltest::removeFile {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeFile: removing $fullName" + return [file delete $fullName] } -# makeDirectory -- +# tcltest::makeDirectory -- # # Create a new dir with the name <name>. # @@ -1736,75 +3213,85 @@ proc ::tcltest::removeFile {name} { # cleanupTests was called, add it to the $directoriesMade list, so it will # be removed by the next call to cleanupTests. # -proc ::tcltest::makeDirectory {name} { - file mkdir $name +# Arguments: +# name name of the new directory +# directory directory in which to create new dir +# +# Results: +# absolute path to the directory created +# +# Side effects: +# None. - set fullName [file join [pwd] $name] - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName +proc tcltest::makeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::makeDirectory: creating $fullName" + file mkdir $fullName + if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { + lappend tcltest::filesMade $fullName + } + return $fullName } -# ::tcltest::removeDirectory -- +# tcltest::removeDirectory -- # # Removes a named directory from the file system. # # Arguments: -# name Name of the directory to remove +# name Name of the directory to remove +# directory Directory from which to remove # +# Results: +# return value from [file delete] +# +# Side effects: +# None -proc ::tcltest::removeDirectory {name} { - file delete -force $name -} - -proc ::tcltest::viewFile {name} { - global tcl_platform - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ($::tcltest::testConstraints(unixExecs) == 0)} { - set f [open [file join $::tcltest::temporaryDirectory $name]] - set data [read -nonewline $f] - close $f - return $data - } else { - exec cat [file join $::tcltest::temporaryDirectory $name] +proc tcltest::removeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" + return [file delete -force $fullName] } -# grep -- +# tcltest::viewFile -- # -# Evaluate a given expression against each element of a list and return all -# elements for which the expression evaluates to true. For the purposes of -# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the -# value of the current element within the expression. This is equivalent to -# the perl grep command where CURRENT_ELEMENT would be the name for the special -# variable $_. +# reads the content of a file and returns it # -# Examples of usage would be: -# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] -# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] +# Arguments: +# name of the file to read +# directory in which file is located # -# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is -# assumed to be the final argument to the expression provided. -# -# Example: -# grep {regexp a} $someList +# Results: +# content of the named file # -proc ::tcltest::grep { expression searchList } { - foreach element $searchList { - if {[regsub -all CURRENT_ELEMENT $expression $element \ - newExpression] == 0} { - set newExpression "$expression {$element}" - } - if {[eval $newExpression] == 1} { - lappend returnList $element - } +# Side effects: +# None. + +proc tcltest::viewFile {name {directory ""}} { + global tcl_platform + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } - if {[info exists returnList]} { - return $returnList + set fullName [file join $directory $name] + if {([string equal $tcl_platform(platform) "macintosh"]) || \ + ([tcltest::testConstraint unixExecs] == 0)} { + set f [open $fullName] + set data [read -nonewline $f] + close $f + return $data + } else { + return [exec cat $fullName] } return } +# tcltest::bytestring -- # # Construct a string that consists of the requested sequence of bytes, # as opposed to a string of properly formed UTF-8 characters. @@ -1818,30 +3305,112 @@ proc ::tcltest::grep { expression searchList } { # Generally, it's a bad idea to examine the bytes in a Tcl string or to # construct improperly formed strings in this manner, because it involves # exposing that Tcl uses UTF-8 internally. +# +# Arguments: +# string being converted +# +# Results: +# result fom encoding +# +# Side effects: +# None + +proc tcltest::bytestring {string} { + return [encoding convertfrom identity $string] +} + +# tcltest::openfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. -proc ::tcltest::bytestring {string} { - encoding convertfrom identity $string +proc tcltest::openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +# tcltest::leakfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak } # # Internationalization / ISO support procs -- dl # -proc ::tcltest::set_iso8859_1_locale {} { + +# tcltest::set_iso8859_1_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::set_iso8859_1_locale {} { if {[info commands testlocale] != ""} { - set ::tcltest::previousLocale [testlocale ctype] - testlocale ctype $::tcltest::isoLocale + set tcltest::previousLocale [testlocale ctype] + testlocale ctype $tcltest::isoLocale } return } -proc ::tcltest::restore_locale {} { +# tcltest::restore_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::restore_locale {} { if {[info commands testlocale] != ""} { - testlocale ctype $::tcltest::previousLocale + testlocale ctype $tcltest::previousLocale } return } -# threadReap -- +# tcltest::threadReap -- # # Kill all threads except for the main thread. # Do nothing if testthread is not defined. @@ -1851,7 +3420,12 @@ proc ::tcltest::restore_locale {} { # # Results: # Returns the number of existing threads. -proc ::tcltest::threadReap {} { +# +# Side Effects: +# none. +# + +proc tcltest::threadReap {} { if {[info commands testthread] != {}} { # testthread built into tcltest @@ -1859,7 +3433,7 @@ proc ::tcltest::threadReap {} { testthread errorproc ThreadNullError while {[llength [testthread names]] > 1} { foreach tid [testthread names] { - if {$tid != $::tcltest::mainThread} { + if {$tid != $tcltest::mainThread} { catch {testthread send -async $tid {testthread exit}} } } @@ -1877,7 +3451,7 @@ proc ::tcltest::threadReap {} { thread::errorproc ThreadNullError while {[llength [thread::names]] > 1} { foreach tid [thread::names] { - if {$tid != $::tcltest::mainThread} { + if {$tid != $tcltest::mainThread} { catch {thread::send -async $tid {thread::exit}} } } @@ -1891,6 +3465,7 @@ proc ::tcltest::threadReap {} { } else { return 1 } + return 0 } # Initialize the constraints and set up command line arguments @@ -1898,8 +3473,18 @@ namespace eval tcltest { # Ensure that we have a minimal auto_path so we don't pick up extra junk. set ::auto_path [list [info library]] - ::tcltest::initConstraints - if {[namespace children ::tcltest] == {}} { - ::tcltest::processCmdLineArgs + tcltest::initConstraints + if {[namespace children [namespace current]] == {}} { + tcltest::processCmdLineArgs + } + + # Save the names of files that already exist in + # the output directory. + foreach file [glob -nocomplain \ + [file join $tcltest::temporaryDirectory *]] { + lappend tcltest::filesExisted [file tail $file] } } + +package provide tcltest 2.0 + diff --git a/library/tcltest/tcltest2.tcl b/library/tcltest/tcltest2.tcl deleted file mode 100755 index c05732d..0000000 --- a/library/tcltest/tcltest2.tcl +++ /dev/null @@ -1,3490 +0,0 @@ -# tcltest.tcl -- -# -# This file contains support code for the Tcl test suite. It -# defines the tcltest namespace and finds and defines the output -# directory, constraints available, output and error channels, etc. used -# by Tcl tests. See the tcltest man page for more details. -# -# This design was based on the Tcl testing approach designed and -# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. -# -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions -# All rights reserved. -# -# RCS: @(#) $Id: tcltest2.tcl,v 1.4 2000/10/19 18:00:58 jenn Exp $ - -# create the "tcltest" namespace for all testing variables and procedures - -namespace eval tcltest { - - # Export the public tcltest procs - set procList [list test cleanupTests saveState restoreState \ - normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring threadReap debug testConstraint \ - limitConstraints loadTestedCommands normalizePath verbose match \ - skip matchFiles skipFiles preserveCore loadScript loadFile \ - mainThread workingDirectory singleProcess interpreter runAllTests \ - outputChannel outputFile errorChannel \ - errorFile temporaryDirectory testsDirectory matchDirectories \ - skipDirectories ] - foreach proc $procList { - namespace export $proc - } - - # tcltest::verbose defaults to {body} - if {![info exists verbose]} { - variable verbose {body} - } - - # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory and - # matchDirectories, which defaults to all directories. - - if {![info exists match]} { - variable match {} - } - if {![info exists skip]} { - variable skip {} - } - if {![info exists matchFiles]} { - variable matchFiles {*.test} - } - if {![info exists skipFiles]} { - variable skipFiles {} - } - if {![info exists matchDirectories]} { - variable matchDirectories {*} - } - if {![info exists skipDirectories]} { - variable skipDirectories {} - } - - # By default, don't save core files - if {![info exists preserveCore]} { - variable preserveCore 0 - } - - # output goes to stdout by default - if {![info exists outputChannel]} { - variable outputChannel stdout - } - if {![info exists outputFile]} { - variable outputFile stdout - } - - # errors go to stderr by default - if {![info exists errorChannel]} { - variable errorChannel stderr - } - if {![info exists errorFile]} { - variable errorFile stderr - } - - # debug output doesn't get printed by default; debug level 1 spits - # up only the tests that were skipped because they didn't match or were - # specifically skipped. A debug level of 2 would spit up the tcltest - # variables and flags provided; a debug level of 3 causes some additional - # output regarding operations of the test harness. The tcltest package - # currently implements only up to debug level 3. - if {![info exists debug]} { - variable debug 0 - } - - # Save any arguments that we might want to pass through to other programs. - # This is used by the -args flag. - if {![info exists parameters]} { - variable parameters {} - } - - # Count the number of files tested (0 if runAllTests wasn't called). - # runAllTests will set testSingleFile to false, so stats will - # not be printed until runAllTests calls the cleanupTests proc. - # The currentFailure var stores the boolean value of whether the - # current test file has had any failures. The failFiles list - # stores the names of test files that had failures. - - if {![info exists numTestFiles]} { - variable numTestFiles 0 - } - if {![info exists testSingleFile]} { - variable testSingleFile true - } - if {![info exists currentFailure]} { - variable currentFailure false - } - if {![info exists failFiles]} { - variable failFiles {} - } - - # Tests should remove all files they create. The test suite will - # check the current working dir for files created by the tests. - # tcltest::filesMade keeps track of such files created using the - # tcltest::makeFile and tcltest::makeDirectory procedures. - # tcltest::filesExisted stores the names of pre-existing files. - - if {![info exists filesMade]} { - variable filesMade {} - } - if {![info exists filesExisted]} { - variable filesExisted {} - } - - # tcltest::numTests will store test files as indices and the list - # of files (that should not have been) left behind by the test files. - - if {![info exists createdNewFiles]} { - variable createdNewFiles - array set tcltest::createdNewFiles {} - } - - # initialize tcltest::numTests array to keep track fo the number of - # tests that pass, fail, and are skipped. - - if {![info exists numTests]} { - variable numTests - array set tcltest::numTests \ - [list Total 0 Passed 0 Skipped 0 Failed 0] - } - - # initialize tcltest::skippedBecause array to keep track of - # constraints that kept tests from running; a constraint name of - # "userSpecifiedSkip" means that the test appeared on the list of tests - # that matched the -skip value given to the flag; "userSpecifiedNonMatch" - # means that the test didn't match the argument given to the -match flag; - # both of these constraints are counted only if tcltest::debug is set to - # true. - - if {![info exists skippedBecause]} { - variable skippedBecause - array set tcltest::skippedBecause {} - } - - # initialize the tcltest::testConstraints array to keep track of valid - # predefined constraints (see the explanation for the - # tcltest::initConstraints proc for more details). - - if {![info exists testConstraints]} { - variable testConstraints - array set tcltest::testConstraints {} - } - - if {![info exists constraintsSpecified]} { - variable constraintsSpecified {} - } - - # Don't run only the constrained tests by default - - if {![info exists limitConstraints]} { - variable limitConstraints false - } - - # A test application has to know how to load the tested commands into - # the interpreter. - - if {![info exists loadScript]} { - variable loadScript {} - } - - # and the filename of the script file, if it exists - if {![info exists loadFile]} { - variable loadFile {} - } - - # tests that use threads need to know which is the main thread - - if {![info exists mainThread]} { - variable mainThread 1 - if {[info commands thread::id] != {}} { - set mainThread [thread::id] - } elseif {[info commands testthread] != {}} { - set mainThread [testthread id] - } - } - - # save the original environment so that it can be restored later - - if {![info exists originalEnv]} { - variable originalEnv - array set tcltest::originalEnv [array get ::env] - } - - # Set tcltest::workingDirectory to [pwd]. The default output directory - # for Tcl tests is the working directory. - - if {![info exists workingDirectory]} { - variable workingDirectory [pwd] - } - if {![info exists temporaryDirectory]} { - variable temporaryDirectory $workingDirectory - } - - # Tests should not rely on the current working directory. - # Files that are part of the test suite should be accessed relative to - # tcltest::testsDirectory. - - if {![info exists testsDirectory]} { - set oldpwd [pwd] - catch {cd [file join [file dirname [info script]] .. .. tests]} - variable testsDirectory [pwd] - cd $oldpwd - unset oldpwd - } - - # Default is to run each test file in a separate process - if {![info exists singleProcess]} { - variable singleProcess 0 - } - - # the variables and procs that existed when tcltest::saveState was - # called are stored in a variable of the same name - if {![info exists saveState]} { - variable saveState {} - } - - # Internationalization support -- used in tcltest::set_iso8859_1_locale - # and tcltest::restore_locale. Those commands are used in cmdIL.test. - if {![info exists previousLocale]} { - variable previousLocale - } - - if {![info exists isoLocale]} { - variable isoLocale fr - switch -- $tcl_platform(platform) { - "unix" { - - # Try some 'known' values for some platforms: - - switch -exact -- $tcl_platform(os) { - "FreeBSD" { - set tcltest::isoLocale fr_FR.ISO_8859-1 - } - HP-UX { - set tcltest::isoLocale fr_FR.iso88591 - } - Linux - - IRIX { - set tcltest::isoLocale fr - } - default { - - # Works on SunOS 4 and Solaris, and maybe others... - # define it to something else on your system - #if you want to test those. - - set tcltest::isoLocale iso_8859_1 - } - } - } - "windows" { - set tcltest::isoLocale French - } - } - } - - # Set the location of the execuatble - if {![info exists tcltest]} { - variable tcltest [info nameofexecutable] - } - - # save the platform information so it can be restored later - if {![info exists originalTclPlatform]} { - variable originalTclPlatform [array get tcl_platform] - } - - # If a core file exists, save its modification time. - if {![info exists coreModificationTime]} { - if {[file exists [file join $tcltest::workingDirectory core]]} { - variable coreModificationTime [file mtime [file join \ - $tcltest::workingDirectory core]] - } - } - - # stdout and stderr buffers for use when we want to store them - if {![info exists outData]} { - variable outData {} - } - if {![info exists errData]} { - variable errData {} - } - - # keep track of test level for nested test commands - variable testLevel 0 -} - -##################################################################### - -# tcltest::Debug* -- -# -# Internal helper procedures to write out debug information -# dependent on the chosen level. A test shell may overide -# them, f.e. to redirect the output into a different -# channel, or even into a GUI. - -# tcltest::DebugPuts -- -# -# Prints the specified string if the current debug level is -# higher than the provided level argument. -# -# Arguments: -# level The lowest debug level triggering the output -# string The string to print out. -# -# Results: -# Prints the string. Nothing else is allowed. -# -# Side Effects: -# None. -# - -proc tcltest::DebugPuts {level string} { - variable debug - if {$debug >= $level} { - puts $string - } - return -} - -# tcltest::DebugPArray -- -# -# Prints the contents of the specified array if the current -# debug level is higher than the provided level argument -# -# Arguments: -# level The lowest debug level triggering the output -# arrayvar The name of the array to print out. -# -# Results: -# Prints the contents of the array. Nothing else is allowed. -# -# Side Effects: -# None. -# - -proc tcltest::DebugPArray {level arrayvar} { - variable debug - - if {$debug >= $level} { - catch {upvar $arrayvar $arrayvar} - parray $arrayvar - } - return -} - -# tcltest::DebugDo -- -# -# Executes the script if the current debug level is greater than -# the provided level argument -# -# Arguments: -# level The lowest debug level triggering the execution. -# script The tcl script executed upon a debug level high enough. -# -# Results: -# Arbitrary side effects, dependent on the executed script. -# -# Side Effects: -# None. -# - -proc tcltest::DebugDo {level script} { - variable debug - - if {$debug >= $level} { - uplevel $script - } - return -} - -##################################################################### - -# tcltest::CheckDirectory -- -# -# This procedure checks whether the specified path is a readable -# and/or writable directory. If one of the conditions is not -# satisfied an error is printed and the application aborted. The -# procedure assumes that the caller already checked the existence -# of the path. -# -# Arguments -# rw Information what attributes to check. Allowed values: -# r, w, rw, wr. If 'r' is part of the value the directory -# must be readable. 'w' associates to 'writable'. -# dir The directory to check. -# errMsg The string to prepend to the actual error message before -# printing it. -# -# Results -# none -# -# Side Effects: -# None. -# - -proc tcltest::CheckDirectory {rw dir errMsg} { - # Allowed values for 'rw': r, w, rw, wr - - if {![file isdir $dir]} { - set msg "$errMsg \"$dir\" is not a directory" - error $msg - } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - set msg "$errMsg \"$dir\" is not writeable" - error $msg - } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - set msg "$errMsg \"$dir\" is not readable" - error $msg - } - return -} - -# tcltest::normalizePath -- -# -# This procedure resolves any symlinks in the path thus creating a -# path without internal redirection. It assumes that the incoming -# path is absolute. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# -# Results -# The path is modified in place. -# -# Side Effects: -# None. -# - -proc tcltest::normalizePath {pathVar} { - upvar $pathVar path - - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd - return $path -} - - -# tcltest::MakeAbsolutePath -- -# -# This procedure checks whether the incoming path is absolute or not. -# Makes it absolute if it was not. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# prefix is optional, contains the path to use to make the other an -# absolute one. The current working directory is used if it was -# not specified. -# -# Results -# The path is modified in place. -# -# Side Effects: -# None. -# - -proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { - upvar $pathVar path - - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { - set prefix [pwd] - } - - set path [file join $prefix $path] - } - return $path -} - -##################################################################### - -# tcltest::<variableName> -# -# Accessor functions for tcltest variables that can be modified externally. -# These are vars that could otherwise be modified using command line -# arguments to tcltest. - -# tcltest::verbose -- -# -# Set or return the verbosity level (tcltest::verbose) for tests. This -# determines what gets printed to the screen and when, with regard to the -# running of the tests. The proc does not check for invalid values. It -# assumes that a string that doesn't match its predefined keywords -# is a string containing letter-specified verbosity levels. -# -# Arguments: -# A string containing any combination of 'pbste' or a list of keywords -# (listed in parens) -# p = print output whenever a test passes (pass) -# b = print the body of the test when it fails (body) -# s = print when a test is skipped (skip) -# t = print when a test starts (start) -# e = print errorInfo and errorCode when a test encounters an error -# (error) -# -# Results: -# content of tcltest::verbose - this is always the character combination -# (pbste) instead of the list form. -# -# Side effects: -# None. - -proc tcltest::verbose { {level ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::verbose - } - if {[llength $level] > 1} { - set tcltest::verbose $level - } else { - if {[regexp {pass|body|skip|start|error} $level]} { - set tcltest::verbose $level - } else { - set levelList [split $level {}] - set tcltest::verbose [string map {p pass b body s skip t start e - error} $levelList] - } - } - return $tcltest::verbose -} - -# tcltest::isVerbose -- -# -# Returns true if argument is one of the verbosity levels currently being -# used; returns false otherwise. -# -# Arguments: -# level -# -# Results: -# boolean 1 (true) or 0 (false), depending on whether or not the level -# provided is one of the ones stored in tcltest::verbose. -# -# Side effects: -# None. - -proc tcltest::isVerbose {level} { - if {[lsearch -exact [tcltest::verbose] $level] == -1} { - return 0 - } - return 1 -} - - - -# tcltest::match -- -# -# Set or return the match patterns (tcltest::match) that determine which -# tests are run. -# -# Arguments: -# List containing match patterns (glob format) -# -# Results: -# content of tcltest::match -# -# Side effects: -# none - -proc tcltest::match { {matchList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::match - } - set tcltest::match $matchList -} - -# tcltest::skip -- -# -# Set or return the skip patterns (tcltest::skip) that determine which -# tests are skipped. -# -# Arguments: -# List containing skip patterns (glob format) -# -# Results: -# content of tcltest::skip -# -# Side effects: -# None. - -proc tcltest::skip { {skipList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skip - } - set tcltest::skip $skipList -} - -# tcltest::matchFiles -- -# -# set or return the match patterns for file sourcing -# -# Arguments: -# list containing match file list (glob format) -# -# Results: -# content of tcltest::matchFiles -# -# Side effects: -# None. - -proc tcltest::matchFiles { {matchFileList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::matchFiles - } - set tcltest::matchFiles $matchFileList -} - -# tcltest::skipFiles -- -# -# set or return the skip patterns for file sourcing -# -# Arguments: -# list containing the skip file list (glob format) -# -# Results: -# content of tcltest::skipFiles -# -# Side effects: -# None. - -proc tcltest::skipFiles { {skipFileList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skipFiles - } - set tcltest::skipFiles $skipFileList -} - - -# tcltest::matchDirectories -- -# -# set or return the list of directories for matching (glob pattern list) -# -# Arguments: -# list of glob patterns matching subdirectories of -# tcltest::testsDirectory -# -# Results: -# content of tcltest::matchDirectories -# -# Side effects: -# None. - -proc tcltest::matchDirectories { {dirlist ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::matchDirectories - } - set tcltest::matchDirectories $dirlist -} - -# tcltest::skipDirectories -- -# -# set or return the list of directories to skip (glob pattern list) -# -# Arguments: -# list of glob patterns matching directories to skip; these directories -# are subdirectories of tcltest::testsDirectory -# -# Results: -# content of tcltest::skipDirectories -# -# Side effects: -# None. - -proc tcltest::skipDirectories { {dirlist ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skipDirectories - } - set tcltest::skipDirectories $dirlist -} - -# tcltest::preserveCore -- -# -# set or return the core preservation level. This proc does not do any -# error checking for invalid values. -# -# Arguments: -# core level: -# '0' = don't do anything with core files (default) -# '1' = notify the user if core files are created -# '2' = save any core files produced during testing to -# tcltest::temporaryDirectory -# -# Results: -# content of tcltest::preserveCore -# -# Side effects: -# None. - -proc tcltest::preserveCore { {coreLevel ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::preserveCore - } - set tcltest::preserveCore $coreLevel -} - -# tcltest::outputChannel -- -# -# set or return the output file descriptor based on the supplied file -# name (where tcltest puts all of its output) -# -# Arguments: -# output file descriptor -# -# Results: -# file descriptor corresponding to supplied file name (or currently set -# file descriptor, if no new filename was supplied) - this is the content -# of tcltest::outputChannel -# -# Side effects: -# None. - -proc tcltest::outputChannel { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::outputChannel - } - if {($filename == "stderr") || ($filename == "stdout")} { - set tcltest::outputChannel $filename - } else { - set tcltest::outputChannel [open $filename w] - } - return $tcltest::outputChannel -} - -# tcltest::outputFile -- -# -# set or return the output file name (where tcltest puts all of its -# output); calls tcltest::outputChannel to set the corresponding file -# descriptor -# -# Arguments: -# output file name -# -# Results: -# file name corresponding to supplied file name (or currently set -# file name, if no new filename was supplied) - this is the content -# of tcltest::outputFile -# -# Side effects: -# if the file name supplied is relative, it will be made absolute with -# respect to the predefined temporaryDirectory - -proc tcltest::outputFile { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::outputFile - } - if {($filename != "stderr") && ($filename != "stdout")} { - MakeAbsolutePath filename $tcltest::temporaryDirectory - } - tcltest::outputChannel $filename - set tcltest::outputFile $filename -} - -# tcltest::errorChannel -- -# -# set or return the error file descriptor based on the supplied file name -# (where tcltest sends all its errors) -# -# Arguments: -# error file name -# -# Results: -# file descriptor corresponding to the supplied file name (or currently -# set file descriptor, if no new filename was supplied) - this is the -# content of tcltest::errorChannel -# -# Side effects: -# opens the descriptor in w mode unless the filename is set to stderr or -# stdout - -proc tcltest::errorChannel { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::errorChannel - } - if {($filename == "stderr") || ($filename == "stdout")} { - set tcltest::errorChannel $filename - } else { - set tcltest::errorChannel [open $filename w] - } - return $tcltest::errorChannel -} - -# tcltest::errorFile -- -# -# set or return the error file name; calls tcltest::errorChannel to set -# the corresponding file descriptor -# -# Arguments: -# error file name -# -# Results: -# content of tcltest::errorFile -# -# Side effects: -# if the file name supplied is relative, it will be made absolute with -# respect to the predefined temporaryDirectory - -proc tcltest::errorFile { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::errorFile - } - if {($filename != "stderr") && ($filename != "stdout")} { - MakeAbsolutePath filename $tcltest::temporaryDirectory - } - set tcltest::errorFile $filename - errorChannel $tcltest::errorFile - return $tcltest::errorFile -} - -# tcltest::debug -- -# -# set or return the debug level for tcltest; this proc does not check for -# invalid values -# -# Arguments: -# debug level: -# '0' = no debug output (default) -# '1' = skipped tests -# '2' = tcltest variables and supplied flags -# '3' = harness operations -# -# Results: -# content of tcltest::debug -# -# Side effects: -# None. - -proc tcltest::debug { {debugLevel ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::debug - } - set tcltest::debug $debugLevel -} - -# tcltest::testConstraint -- -# -# sets a test constraint to a value; to do multiple constraints, call -# this proc multiple times. also returns the value of the named -# constraint if no value was supplied. -# -# Arguments: -# constraint - name of the constraint -# value - new value for constraint (should be boolean) - if not supplied, -# this is a query -# -# Results: -# content of tcltest::testConstraints($constraint) -# -# Side effects: -# appends the constraint name to tcltest::constraintsSpecified - -proc tcltest::testConstraint {constraint {value ""}} { - DebugPuts 3 "entering testConstraint $constraint $value" - if {[llength [info level 0]] == 2} { - return $tcltest::testConstraints($constraint) - } - lappend tcltest::constraintsSpecified $constraint - set tcltest::testConstraints($constraint) $value -} - -# tcltest::constraintsSpecified -- -# -# returns a list of all the constraint names specified using -# testConstraint -# -# Arguments: -# None. -# -# Results: -# list of the constraint names in tcltest::constraintsSpecified -# -# Side effects: -# None. - -proc tcltest::constraintsSpecified {} { - return $tcltest::constraintsSpecified -} - -# tcltest::constraintList -- -# -# returns a list of all the constraint names -# -# Arguments: -# None. -# -# Results: -# list of the constraint names in tcltest::testConstraints -# -# Side effects: -# None. - -proc tcltest::constraintList {} { - return [array names tcltest::testConstraints] -} - -# tcltest::limitConstraints -- -# -# sets the limited constraints to tcltest::limitConstraints -# -# Arguments: -# list of constraint names -# -# Results: -# content of tcltest::limitConstraints -# -# Side effects: -# None. - -proc tcltest::limitConstraints { {constraintList ""} } { - DebugPuts 3 "entering limitConstraints $constraintList" - if {[llength [info level 0]] == 1} { - return $tcltest::limitConstraints - } - set tcltest::limitConstraints $constraintList - foreach elt [tcltest::constraintList] { - if {[lsearch -exact [tcltest::constraintsSpecified] $elt] == -1} { - tcltest::testConstraint $elt 0 - } - } - return $tcltest::limitConstraints -} - -# tcltest::loadScript -- -# -# sets the load script -# -# Arguments: -# script to be set -# -# Results: -# contents of tcltest::loadScript -# -# Side effects: -# None. - -proc tcltest::loadScript { {script ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::loadScript - } - set tcltest::loadScript $script -} - -# tcltest::loadFile -- -# -# set the load file (containing the load script); -# put the content of the load file into loadScript -# -# Arguments: -# script's file name -# -# Results: -# content of tcltest::loadFile -# -# Side effects: -# None. - -proc tcltest::loadFile { {scriptFile ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::loadFile - } - MakeAbsolutePath scriptFile $tcltest::temporaryDirectory - set tmp [open $scriptFile r] - tcltest::loadScript [read $tmp] - close $tmp - set tcltest::loadFile $scriptFile -} - -# tcltest::workingDirectory -- -# -# set workingDirectory to the given path. -# If the path is relative, make it absolute. -# change directory to the stated working directory, if resetting the -# value -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::workingDirectory -# -# Side effects: -# None. - -proc tcltest::workingDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::workingDirectory - } - set tcltest::workingDirectory $dir - MakeAbsolutePath tcltest::workingDirectory - cd $tcltest::workingDirectory - return $tcltest::workingDirectory -} - -# tcltest::temporaryDirectory -- -# -# Set tcltest::temporaryDirectory to the given path. -# If the path is relative, make it absolute. If the file exists but -# is not a dir, then return an error. -# -# If tcltest::temporaryDirectory does not already exist, create it. -# If you cannot create it, then return an error (the file mkdir isn't -# caught and will propagate). -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::temporaryDirectory -# -# Side effects: -# None. - -proc tcltest::temporaryDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::temporaryDirectory - } - set tcltest::temporaryDirectory $dir - - MakeAbsolutePath tcltest::temporaryDirectory - set tmpDirError "bad argument for temporary directory: " - - if {[file exists $tcltest::temporaryDirectory]} { - tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError - } else { - file mkdir $tcltest::temporaryDirectory - } - - normalizePath tcltest::temporaryDirectory -} - -# tcltest::testsDirectory -- -# -# Set tcltest::testsDirectory to the given path. -# If the path is relative, make it absolute. If the file exists but -# is not a dir, then return an error. -# -# If tcltest::testsDirectory does not already exist, return an error. -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::testsDirectory -# -# Side effects: -# None. - -proc tcltest::testsDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::testsDirectory - } - - set tcltest::testsDirectory $dir - - MakeAbsolutePath tcltest::testsDirectory - set testDirError "bad argument for tests directory: " - - if {[file exists $tcltest::testsDirectory]} { - tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError - } else { - set msg "$testDirError \"$tcltest::testsDirectory\" does not exist" - error $msg - } - - normalizePath tcltest::testsDirectory -} - -# tcltest::singleProcess -- -# -# sets tcltest::singleProcess to the value provided. -# -# Arguments: -# value for singleProcess: -# 1 = source each test file into the current process -# 0 = run each test file in its own process -# -# Results: -# content of tcltest::singleProcess -# -# Side effects: -# None. - -proc tcltest::singleProcess { {value ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::singleProcess - } - set tcltest::singleProcess $value -} - -# tcltest::interpreter -- -# -# the interpreter name stored in tcltest::tcltest -# -# Arguments: -# executable name -# -# Results: -# content of tcltest::tcltest -# -# Side effects: -# None. - -proc tcltest::interpreter { {interp ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::tcltest - } - set tcltest::tcltest $interp -} - -# tcltest::mainThread -- -# -# sets or returns the thread id stored in tcltest::mainThread -# -# Arguments: -# thread id -# -# Results: -# content of tcltest::mainThread -# -# Side effects: -# None. - -proc tcltest::mainThread { {threadid ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::mainThread - } - set tcltest::mainThread $threadid -} - -##################################################################### - -# tcltest::AddToSkippedBecause -- -# -# Increments the variable used to track how many tests were skipped -# because of a particular constraint. -# -# Arguments: -# constraint The name of the constraint to be modified -# -# Results: -# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't -# previously exist - otherwise, it just increments it. -# -# Side effects: -# None. - -proc tcltest::AddToSkippedBecause { constraint {value 1}} { - # add the constraint to the list of constraints that kept tests - # from running - - if {[info exists tcltest::skippedBecause($constraint)]} { - incr tcltest::skippedBecause($constraint) $value - } else { - set tcltest::skippedBecause($constraint) $value - } - return -} - -# tcltest::PrintError -- -# -# Prints errors to tcltest::errorChannel and then flushes that -# channel, making sure that all messages are < 80 characters per line. -# -# Arguments: -# errorMsg String containing the error to be printed -# -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::PrintError {errorMsg} { - set InitialMessage "Error: " - set InitialMsgLen [string length $InitialMessage] - puts -nonewline [errorChannel] $InitialMessage - - # Keep track of where the end of the string is. - set endingIndex [string length $errorMsg] - - if {$endingIndex < 80} { - puts [errorChannel] $errorMsg - } else { - # Print up to 80 characters on the first line, including the - # InitialMessage. - set beginningIndex [string last " " [string range $errorMsg 0 \ - [expr {80 - $InitialMsgLen}]]] - puts [errorChannel] [string range $errorMsg 0 $beginningIndex] - - while {$beginningIndex != "end"} { - puts -nonewline [errorChannel] \ - [string repeat " " $InitialMsgLen] - if {[expr {$endingIndex - $beginningIndex}] < 72} { - puts [errorChannel] [string trim \ - [string range $errorMsg $beginningIndex end]] - set beginningIndex end - } else { - set newEndingIndex [expr [string last " " [string range \ - $errorMsg $beginningIndex \ - [expr {$beginningIndex + 72}]]] + $beginningIndex] - if {($newEndingIndex <= 0) \ - || ($newEndingIndex <= $beginningIndex)} { - set newEndingIndex end - } - puts [errorChannel] [string trim \ - [string range $errorMsg \ - $beginningIndex $newEndingIndex]] - set beginningIndex $newEndingIndex - } - } - } - flush [errorChannel] - return -} - -if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { - proc tcltest::initConstraintsHook {} {} -} - -# tcltest::safeFetch -- -# -# The following trace procedure makes it so that we can safely refer to -# non-existent members of the tcltest::testConstraints array without -# causing an error. Instead, reading a non-existent member will return -# 0. This is necessary because tests are allowed to use constraint "X" -# without ensuring that tcltest::testConstraints("X") is defined. -# -# Arguments: -# n1 - name of the array (tcltest::testConstraints) -# n2 - array key value (constraint name) -# op - operation performed on tcltest::testConstraints (generally r) -# -# Results: -# none -# -# Side effects: -# sets tcltest::testConstraints($n2) to 0 if it's referenced but never -# before used - -proc tcltest::safeFetch {n1 n2 op} { - DebugPuts 3 "entering safeFetch $n1 $n2 $op" - if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { - tcltest::testConstraint $n2 0 - } -} - -# tcltest::initConstraints -- -# -# Check constraint information that will determine which tests -# to run. To do this, create an array tcltest::testConstraints. Each -# element has a 0 or 1 value. If the element is "true" then tests -# with that constraint will be run, otherwise tests with that constraint -# will be skipped. See the tcltest man page for the list of built-in -# constraints defined in this procedure. -# -# Arguments: -# none -# -# Results: -# The tcltest::testConstraints array is reset to have an index for -# each built-in test constraint. -# -# Side Effects: -# None. -# - -proc tcltest::initConstraints {} { - global tcl_platform tcl_interactive tk_version - - # Safely refer to non-existent members of the tcltest::testConstraints - # array without causing an error. - trace variable tcltest::testConstraints r tcltest::safeFetch - - tcltest::initConstraintsHook - - tcltest::testConstraint singleTestInterp [singleProcess] - - # All the 'pc' constraints are here for backward compatibility and are not - # documented. They have been replaced with equivalent 'win' constraints. - - tcltest::testConstraint unixOnly \ - [string equal $tcl_platform(platform) "unix"] - tcltest::testConstraint macOnly \ - [string equal $tcl_platform(platform) "macintosh"] - tcltest::testConstraint pcOnly \ - [string equal $tcl_platform(platform) "windows"] - tcltest::testConstraint winOnly \ - [string equal $tcl_platform(platform) "windows"] - - tcltest::testConstraint unix [tcltest::testConstraint unixOnly] - tcltest::testConstraint mac [tcltest::testConstraint macOnly] - tcltest::testConstraint pc [tcltest::testConstraint pcOnly] - tcltest::testConstraint win [tcltest::testConstraint winOnly] - - tcltest::testConstraint unixOrPc \ - [expr {[tcltest::testConstraint unix] \ - || [tcltest::testConstraint pc]}] - tcltest::testConstraint macOrPc \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint pc]}] - tcltest::testConstraint unixOrWin \ - [expr {[tcltest::testConstraint unix] \ - || [tcltest::testConstraint win]}] - tcltest::testConstraint macOrWin \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint win]}] - tcltest::testConstraint macOrUnix \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint unix]}] - - tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"] - tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"] - tcltest::testConstraint 98 [string equal $tcl_platform(os) "Windows 98"] - - # The following Constraints switches are used to mark tests that should - # work, but have been temporarily disabled on certain platforms because - # they don't and we haven't gotten around to fixing the underlying - # problem. - - tcltest::testConstraint tempNotPc \ - [expr {![tcltest::testConstraint pc]}] - tcltest::testConstraint tempNotWin \ - [expr {![tcltest::testConstraint win]}] - tcltest::testConstraint tempNotMac \ - [expr {![tcltest::testConstraint mac]}] - tcltest::testConstraint tempNotUnix \ - [expr {![tcltest::testConstraint unix]}] - - # The following Constraints switches are used to mark tests that crash on - # certain platforms, so that they can be reactivated again when the - # underlying problem is fixed. - - tcltest::testConstraint pcCrash \ - [expr {![tcltest::testConstraint pc]}] - tcltest::testConstraint winCrash \ - [expr {![tcltest::testConstraint win]}] - tcltest::testConstraint macCrash \ - [expr {![tcltest::testConstraint mac]}] - tcltest::testConstraint unixCrash \ - [expr {![tcltest::testConstraint unix]}] - - # Skip empty tests - - tcltest::testConstraint emptyTest 0 - - # By default, tests that expose known bugs are skipped. - - tcltest::testConstraint knownBug 0 - - # By default, non-portable tests are skipped. - - tcltest::testConstraint nonPortable 0 - - # Some tests require user interaction. - - tcltest::testConstraint userInteraction 0 - - # Some tests must be skipped if the interpreter is not in interactive mode - - if {[info exists tcl_interactive]} { - tcltest::testConstraint interactive $::tcl_interactive - } else { - tcltest::testConstraint interactive 0 - } - - # Some tests can only be run if the installation came from a CD image - # instead of a web image - # Some tests must be skipped if you are running as root on Unix. - # Other tests can only be run if you are running as root on Unix. - - tcltest::testConstraint root 0 - tcltest::testConstraint notRoot 1 - set user {} - if {[string equal $tcl_platform(platform) "unix"]} { - catch {set user [exec whoami]} - if {[string equal $user ""]} { - catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} - } - if {([string equal $user "root"]) || ([string equal $user ""])} { - tcltest::testConstraint root 1 - tcltest::testConstraint notRoot 0 - } - } - - # Set nonBlockFiles constraint: 1 means this platform supports - # ting files into nonblocking mode. - - if {[catch {set f [open defs r]}]} { - tcltest::testConstraint nonBlockFiles 1 - } else { - if {[catch {fconfigure $f -blocking off}] == 0} { - tcltest::testConstraint nonBlockFiles 1 - } else { - tcltest::testConstraint nonBlockFiles 0 - } - close $f - } - - # Set asyncPipeClose constraint: 1 means this platform supports - # async flush and async close on a pipe. - # - # Test for SCO Unix - cannot run async flushing tests because a - # potential problem with select is apparently interfering. - # (Mark Diekhans). - - if {[string equal $tcl_platform(platform) "unix"]} { - if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - tcltest::testConstraint asyncPipeClose 0 - } else { - tcltest::testConstraint asyncPipeClose 1 - } - } else { - tcltest::testConstraint asyncPipeClose 1 - } - - # Test to see if we have a broken version of sprintf with respect - # to the "e" format of floating-point numbers. - - tcltest::testConstraint eformat 1 - if {![string equal "[format %g 5e-5]" "5e-05"]} { - tcltest::testConstraint eformat 0 - } - - # Test to see if execed commands such as cat, echo, rm and so forth are - # present on this machine. - - tcltest::testConstraint unixExecs 1 - if {[string equal $tcl_platform(platform) "macintosh"]} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([string equal $tcl_platform(platform) "windows"])} { - if {[catch {exec cat defs}] == 1} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec echo hello}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec sh -c echo hello}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec wc defs}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {[tcltest::testConstraint unixExecs] == 1} { - exec echo hello > removeMe - if {[catch {exec rm removeMe}] == 1} { - tcltest::testConstraint unixExecs 0 - } - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec sleep 1}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec fgrep unixExecs defs}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec ps}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec echo abc > removeMe}] == 0) && \ - ([catch {exec chmod 644 removeMe}] == 1) && \ - ([catch {exec rm removeMe}] == 0)} { - tcltest::testConstraint unixExecs 0 - } else { - catch {exec rm -f removeMe} - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec mkdir removeMe}] == 1)} { - tcltest::testConstraint unixExecs 0 - } else { - catch {exec rm -r removeMe} - } - } - - # Locate tcltest executable - - if {![info exists tk_version]} { - set tcltest::tcltest [info nameofexecutable] - - if {$tcltest::tcltest == "{}"} { - set tcltest::tcltest {} - } - } - - tcltest::testConstraint stdio 0 - catch { - catch {file delete -force tmp} - set f [open tmp w] - puts $f { - exit - } - close $f - - set f [open "|[list $tcltest tmp]" r] - close $f - - tcltest::testConstraint stdio 1 - } - catch {file delete -force tmp} - - # Deliberately call socket with the wrong number of arguments. The error - # message you get will indicate whether sockets are available on this - # system. - - catch {socket} msg - tcltest::testConstraint socket \ - [expr {$msg != "sockets are not available on this system"}] - - # Check for internationalization - - if {[info commands testlocale] == ""} { - # No testlocale command, no tests... - tcltest::testConstraint hasIsoLocale 0 - } else { - tcltest::testConstraint hasIsoLocale \ - [string length [tcltest::set_iso8859_1_locale]] - tcltest::restore_locale - } -} - -##################################################################### - -# Handle command line arguments (from argv) and default arg settings -# (in TCLTEST_OPTIONS). - -# tcltest::PrintUsageInfoHook -# -# Hook used for customization of display of usage information. -# - -if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} { - proc tcltest::PrintUsageInfoHook {} {} -} - -# tcltest::PrintUsageInfo -# -# Prints out the usage information for package tcltest. This can be -# customized with the redefinition of tcltest::PrintUsageInfoHook. -# -# Arguments: -# none -# -# Results: -# none -# -# Side Effects: -# none - -proc tcltest::PrintUsageInfo {} { - puts [format "Usage: [file tail [info nameofexecutable]] \ - script ?-help? ?flag value? ... \n\ - Available flags (and valid input values) are: \n\ - -help \t Display this usage information. \n\ - -verbose level \t Takes any combination of the values \n\ - \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\ - \t display all passed tests if 'p' is \n\ - \t specified, all skipped tests if 's' \n\ - \t is specified, the bodies of \n\ - \t failed tests if 'b' is specified, \n\ - \t and when tests start if 't' is specified. \n\ - \t ErrorInfo is displayed if 'e' is specified. \n\ - \t The default value is 'b'. \n\ - -constraints list\t Do not skip the listed constraints\n\ - -limitconstraints bool\t Only run tests with the constraints\n\ - \t listed in -constraints.\n\ - -match pattern \t Run all tests within the specified \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -skip pattern \t Skip all tests within the set of \n\ - \t specified tests (via -match) and \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -file pattern \t Run tests in all test files that \n\ - \t match the glob pattern given. \n\ - -notfile pattern\t Skip all test files that match the \n\ - \t glob pattern given. \n\ - -relateddir pattern\t Run tests in directories that match \n\ - \t the glob pattern given. \n\ - -asidefromdir pattern\t Skip tests in directories that match \n\ - \t the glob pattern given.\n\ - -preservecore level \t If 2, save any core files produced \n\ - \t during testing in the directory \n\ - \t specified by -tmpdir. If 1, notify the\n\ - \t user if core files are created. The default \n\ - \t is $tcltest::preserveCore. \n\ - -tmpdir directory\t Save temporary files in the specified\n\ - \t directory. The default value is \n\ - \t $tcltest::temporaryDirectory. \n\ - -testdir directories\t Search tests in the specified\n\ - \t directories. The default value is \n\ - \t $tcltest::testsDirectory. \n\ - -outfile file \t Send output from test runs to the \n\ - \t specified file. The default is \n\ - \t stdout. \n\ - -errfile file \t Send errors from test runs to the \n\ - \t specified file. The default is \n\ - \t stderr. \n\ - -loadfile file \t Read the script to load the tested \n\ - \t commands from the specified file. \n\ - -load script \t Specifies the script to load the tested \n\ - \t commands. \n\ - -debug level \t Internal debug flag."] - tcltest::PrintUsageInfoHook - return -} - -# tcltest::processCmdLineArgsFlagsHook -- -# -# This hook is used to add to the list of command line arguments that are -# processed by tcltest::ProcessFlags. It is called at the beginning of -# ProcessFlags. -# - -if {[namespace inscope tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { - proc tcltest::processCmdLineArgsAddFlagsHook {} {} -} - -# tcltest::processCmdLineArgsHook -- -# -# This hook is used to actually process the flags added by -# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of -# ProcessFlags. -# -# Arguments: -# flags The flags that have been pulled out of argv -# - -if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} { - proc tcltest::processCmdLineArgsHook {flag} {} -} - -# tcltest::ProcessFlags -- -# -# process command line arguments supplied in the flagArray - this is -# called by processCmdLineArgs -# modifies tcltest variables according to the content of the flagArray. -# -# Arguments: -# flagArray - array containing name/value pairs of flags -# -# Results: -# sets tcltest variables according to their values as defined by -# flagArray -# -# Side effects: -# None. - -proc tcltest::ProcessFlags {flagArray} { - # Process -help first - if {[lsearch -exact $flagArray {-help}] != -1} { - tcltest::PrintUsageInfo - exit 1 - } - - catch {array set flag $flagArray} - - # -help is not listed since it has already been processed - lappend defaultFlags -verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints -testdir \ - -load -loadfile -asidefromdir \ - -relateddir -singleproc - set defaultFlags [concat $defaultFlags \ - [tcltest::processCmdLineArgsAddFlagsHook ]] - - # Set tcltest::verbose to the arg of the -verbose flag, if given - if {[info exists flag(-verbose)]} { - tcltest::verbose $flag(-verbose) - } - - # Set tcltest::match to the arg of the -match flag, if given. - if {[info exists flag(-match)]} { - tcltest::match $flag(-match) - } - - # Set tcltest::skip to the arg of the -skip flag, if given - if {[info exists flag(-skip)]} { - tcltest::skip $flag(-skip) - } - - # Handle the -file and -notfile flags - if {[info exists flag(-file)]} { - tcltest::matchFiles $flag(-file) - } - if {[info exists flag(-notfile)]} { - tcltest::skipFiles $flag(-notfile) - } - - # Handle -relateddir and -asidefromdir flags - if {[info exists flag(-relateddir)]} { - tcltest::matchDirectories $flag(-relateddir) - } - if {[info exists flag(-asidefromdir)]} { - tcltest::skipDirectories $flag(-asidefromdir) - } - - # Use the -constraints flag, if given, to turn on constraints that are - # turned off by default: userInteractive knownBug nonPortable. This - # code fragment must be run after constraints are initialized. - - if {[info exists flag(-constraints)]} { - foreach elt $flag(-constraints) { - tcltest::testConstraint $elt 1 - } - } - - # Use the -limitconstraints flag, if given, to tell the harness to limit - # tests run to those that were specified using the -constraints flag. If - # the -constraints flag was not specified, print out an error and exit. - if {[info exists flag(-limitconstraints)]} { - if {![info exists flag(-constraints)]} { - set msg "-limitconstraints flag can only be used with -constraints" - error $msg - } - tcltest::limitConstraints $flag(-limitconstraints) - } - - # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if - # given. - - if {[info exists flag(-tmpdir)]} { - tcltest::temporaryDirectory $flag(-tmpdir) - } - - # Set the tcltest::testsDirectory to the arg of -testdir, if - # given. - - if {[info exists flag(-testdir)]} { - tcltest::testsDirectory $flag(-testdir) - } - - # If an alternate error or output files are specified, change the - # default channels. - - if {[info exists flag(-outfile)]} { - tcltest::outputFile $flag(-outfile) - } - - if {[info exists flag(-errfile)]} { - tcltest::errorFile $flag(-errfile) - } - - # If a load script was specified, either directly or through - # a file, remember it for later usage. - - if {[info exists flag(-load)] && \ - ([lsearch -exact $flagArray -load] > \ - [lsearch -exact $flagArray -loadfile])} { - tcltest::loadScript $flag(-load) - } - - if {[info exists flag(-loadfile)] && \ - ([lsearch -exact $flagArray -loadfile] > \ - [lsearch -exact $flagArray -load]) } { - tcltest::loadFile $flag(-loadfile) - } - - # If the user specifies debug testing, print out extra information during - # the run. - if {[info exists flag(-debug)]} { - tcltest::debug $flag(-debug) - } - - # Handle -preservecore - if {[info exists flag(-preservecore)]} { - tcltest::preserveCore $flag(-preservecore) - } - - # Handle -singleproc flag - if {[info exists flag(-singleproc)]} { - tcltest::singleProcess $flag(-singleproc) - } - - # Call the hook - tcltest::processCmdLineArgsHook [array get flag] - return -} - -# tcltest::processCmdLineArgs -- -# -# Use command line args to set tcltest namespace variables. -# -# This procedure must be run after constraints are initialized, because -# some constraints can be overridden. -# -# Set variables based on the contents of the environment variable -# TCLTEST_OPTIONS first, then override with command-line options, if -# specified. -# -# Arguments: -# none -# -# Results: -# Sets the above-named variables in the tcltest namespace. -# -# Side Effects: -# None. -# - -proc tcltest::processCmdLineArgs {} { - global argv - - # If the TCLTEST_OPTIONS environment variable exists, parse it first, then - # the argv list. The command line argument parsing will be a two-pass - # affair from now on, so that TCLTEST_OPTIONS contain the default options. - # These can be overridden by the command line flags. - - if {[info exists ::env(TCLTEST_OPTIONS)]} { - tcltest::ProcessFlags $::env(TCLTEST_OPTIONS) - } - - # The "argv" var doesn't exist in some cases, so use {}. - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv - } - - tcltest::ProcessFlags $flagArray - - # Spit out everything you know if we're at a debug level 2 or greater - DebugPuts 2 "Flags passed into tcltest:" - if {[info exists ::env(TCLTEST_OPTIONS)]} { - DebugPuts 2 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" - } - if {[info exists argv]} { - DebugPuts 2 " argv: $argv" - } - DebugPuts 2 "tcltest::debug = [tcltest::debug]" - DebugPuts 2 "tcltest::testsDirectory = [tcltest::testsDirectory]" - DebugPuts 2 "tcltest::workingDirectory = [tcltest::workingDirectory]" - DebugPuts 2 "tcltest::temporaryDirectory = [tcltest::temporaryDirectory]" - DebugPuts 2 "tcltest::outputChannel = [outputChannel]" - DebugPuts 2 "tcltest::errorChannel = [errorChannel]" - DebugPuts 2 "Original environment (tcltest::originalEnv):" - DebugPArray 2 tcltest::originalEnv - DebugPuts 2 "Constraints:" - DebugPArray 2 tcltest::testConstraints - return -} - -##################################################################### - -# Code to run the tests goes here. - -# tcltest::testPuts -- -# -# Used to redefine puts in test environment. -# Stores whatever goes out on stdout in tcltest::outData and stderr in -# tcltest::errData before sending it on to the regular puts. -# -# Arguments: -# same as standard puts -# -# Results: -# none -# -# Side effects: -# Intercepts puts; data that would otherwise go to stdout, stderr, or -# file channels specified in tcltest::outputChannel and errorChannel does -# not get sent to the normal puts function. - -proc tcltest::testPuts {args} { - set len [llength $args] - if {$len == 1} { - # Only the string to be printed is specified - append tcltest::outData "[lindex $args 0]\n" - return -# return [tcltest::normalPuts [lindex $args 0]] - } elseif {$len == 2} { - # Either -nonewline or channelId has been specified - if {[regexp {^-nonewline} [lindex $args 0]]} { - append tcltest::outData "[lindex $args end]" - return -# return [tcltest::normalPuts -nonewline [lindex $args end]] - } else { - set channel [lindex $args 0] - } - } elseif {$len == 3} { - if {[lindex $args 0] == "-nonewline"} { - # Both -nonewline and channelId are specified, unless it's an - # error. -nonewline is supposed to be argv[0]. - set channel [lindex $args 1] - } - } - - if {[info exists channel]} { - if {($channel == [outputChannel]) || ($channel == "stdout")} { - append tcltest::outData "[lindex $args end]\n" - } elseif {($channel == [errorChannel]) || ($channel == "stderr")} { - append tcltest::errData "[lindex $args end]\n" - } - return - # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]] - } - - # If we haven't returned by now, we don't know how to handle the input. - # Let puts handle it. - return [eval tcltest::normalPuts $args] -} - -# tcltest::testEval -- -# -# Evaluate the script in the test environment. If ignoreOutput is -# false, store data sent to stderr and stdout in tcltest::outData and -# tcltest::errData. Otherwise, ignore this output altogether. -# -# Arguments: -# script Script to evaluate -# ?ignoreOutput? Indicates whether or not to ignore output sent to -# stdout & stderr -# -# Results: -# result from running the script -# -# Side effects: -# Empties the contents of tcltest::outData and tcltest::errData before -# running a test if ignoreOutput is set to 0. - -proc tcltest::testEval {script {ignoreOutput 1}} { - DebugPuts 3 "testEval called" - if {!$ignoreOutput} { - set tcltest::outData {} - set tcltest::errData {} - uplevel rename ::puts tcltest::normalPuts - uplevel rename tcltest::testPuts ::puts - } - set result [uplevel $script] - if {!$ignoreOutput} { - uplevel rename ::puts tcltest::testPuts - uplevel rename tcltest::normalPuts ::puts - } - return $result -} - -# compareStrings -- -# -# compares the expected answer to the actual answer, depending on the -# mode provided. Mode determines whether a regexp, exact, or glob -# comparison is done. -# -# Arguments: -# actual - string containing the actual result -# expected - pattern to be matched against -# mode - type of comparison to be done -# -# Results: -# result of the match -# -# Side effects: -# None. - -proc tcltest::compareStrings {actual expected mode} { - switch -- $mode { - exact { - set retval [string equal $actual $expected] - } - glob { - set retval [string match $expected $actual] - } - regexp { - set retval [regexp -- $expected $actual] - } - } - return $retval -} - - -# -# tcltest::substArguments list -# -# This helper function takes in a list of words, then perform a -# substitution on the list as though each word in the list is a -# separate argument to the Tcl function. For example, if this -# function is invoked as: -# -# substArguments {$a {$a}} -# -# Then it is as though the function is invoked as: -# -# substArguments $a {$a} -# -# This code is adapted from Paul Duffin's function "SplitIntoWords". -# The original function can be found on: -# -# http://purl.org/thecliff/tcl/wiki/858.html -# -# Results: -# a list containing the result of the substitution -# -# Exceptions: -# An error may occur if the list containing unbalanced quote or -# unknown variable. -# -# Side Effects: -# None. -# - -proc tcltest::substArguments {argList} { - - # We need to split the argList up into tokens but cannot use - # list operations as they throw away some significant - # quoting, and [split] ignores braces as it should. - # Therefore what we do is gradually build up a string out of - # whitespace seperated strings. We cannot use [split] to - # split the argList into whitespace seperated strings as it - # throws away the whitespace which maybe important so we - # have to do it all by hand. - - set result {} - set token "" - - while {[string length $argList]} { - # Look for the next word containing a quote: " { } - if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ - $argList all]} { - # Get the text leading up to this word, but not - # including this word, from the argList. - set text [string range $argList 0 \ - [expr {[lindex $all 0] - 1}]] - # Get the word with the quote - set word [string range $argList \ - [lindex $all 0] [lindex $all 1]] - - # Remove all text up to and including the word from the - # argList. - set argList [string range $argList \ - [expr {[lindex $all 1] + 1}] end] - } else { - # Take everything up to the end of the argList. - set text $argList - set word {} - set argList {} - } - - if {$token != {}} { - # If we saw a word with quote before, then there is a - # multi-word token starting with that word. In this case, - # add the text and the current word to this token. - append token $text $word - } else { - # Add the text to the result. There is no need to parse - # the text because it couldn't be a part of any multi-word - # token. Then start a new multi-word token with the word - # because we need to pass this token to the Tcl parser to - # check for balancing quotes - append result $text - set token $word - } - - if { [catch {llength $token} length] == 0 && $length == 1} { - # The token is a valid list so add it to the result. - # lappend result [string trim $token] - append result \{$token\} - set token {} - } - } - - # If the last token has not been added to the list then there - # is a problem. - if { [string length $token] } { - error "incomplete token \"$token\"" - } - - return $result -} - - -# tcltest::test -- -# -# This procedure runs a test and prints an error message if the test fails. -# If tcltest::verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# tcltest::match variable, if it matches an element in -# tcltest::skip, or if one of the elements of "constraints" turns -# out not to be true. -# -# If testLevel is 1, then this is a top level test, and we record pass/fail -# information; otherwise, this information is not logged and is not added to -# running totals. -# -# Attributes: -# Only description is a required attribute. All others are optional. -# Default values are indicated. -# -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "tcltest::testConstraints". If any -# of these elements is zero, the test is -# skipped. This attribute is optional; default is {} -# body - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. This attribute is optional; -# default is {} -# result - Expected result from script. This attribute is -# optional; default is {}. -# output - Expected output sent to stdout. This attribute -# is optional; default is {}. -# errorOutput - Expected output sent to stderr. This attribute -# is optional; default is {}. -# returnCodes - Expected return codes. This attribute is -# optional; default is {0 2}. -# setup - Code to run before $script (above). This -# attribute is optional; default is {}. -# cleanup - Code to run after $script (above). This -# attribute is optional; default is {}. -# match - specifies type of matching to do on result, -# output, errorOutput; this must be one of: exact, -# glob, regexp. default is exact. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# -# Results: -# 0 if the command ran successfully; 1 otherwise. -# -# Side effects: -# None. -# - -proc tcltest::test {name description args} { - DebugPuts 3 "Test $name $args" - - incr tcltest::testLevel - - # Pre-define everything to null except output and errorOutput. We - # determine whether or not to trap output based on whether or not these - # variables (output & errorOutput) are defined. - foreach item {constraints setup cleanup body result returnCodes match} { - set $item {} - } - - # Set the default match mode - set match exact - - # Set the default match values for return codes (0 is the standard expected - # return value if everything went well; 2 represents 'return' being used in - # the test script). - set returnCodes [list 0 2] - - # The old test format can't have a 3rd argument (constraints or script) - # that starts with '-'. - if {[llength $args] == 0} { - puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}" - incr tcltest::testLevel -1 - return 1 - } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} { - - if {[llength $args] == 1} { - set list [substArguments [lindex $args 0]] - foreach {element value} $list { - set testAttributes($element) $value - } - foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { - if {[info exists testAttributes([subst -$item])]} { - set testAttributes([subst -$item]) \ - [uplevel concat $testAttributes([subst -$item])] - } - } - } else { - array set testAttributes $args - } - - set validFlags {-setup -cleanup -body -result -returnCodes -match \ - -output -errorOutput -constraints} - - foreach flag [array names testAttributes] { - if {[lsearch -exact $validFlags $flag] == -1} { - puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test" - incr tcltest::testLevel -1 - return 1 - } - } - - # store whatever the user gave us - foreach item [array names testAttributes] { - set [string trimleft $item "-"] $testAttributes($item) - } - - # Check the values supplied for -match - if {[lsearch {regexp glob exact} $match] == -1} { - puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}" - incr tcltest::testLevel -1 - return 1 - } - - # Replace symbolic valies supplied for -returnCodes - regsub -nocase normal $returnCodes 0 returnCodes - regsub -nocase error $returnCodes 1 returnCodes - regsub -nocase return $returnCodes 2 returnCodes - regsub -nocase break $returnCodes 3 returnCodes - regsub -nocase continue $returnCodes 4 returnCodes - } else { - # This is parsing for the old test command format; it is here for - # backward compatibility. - set result [lindex $args end] - if {[llength $args] == 2} { - set body [lindex $args 0] - } elseif {[llength $args] == 3} { - set constraints [lindex $args 0] - set body [lindex $args 1] - } else { - puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}" - incr tcltest::testLevel -1 - return 1 - } - } - - set setupFailure 0 - set cleanupFailure 0 - - # Run the setup script - if {[catch {uplevel $setup} setupMsg]} { - set setupFailure 1 - } - - # run the test script - set command [list tcltest::runTest $name $description $body \ - $result $constraints] - if {!$setupFailure} { - if {[info exists output] || [info exists errorOutput]} { - set testResult [uplevel tcltest::testEval [list $command] 0] - } else { - set testResult [uplevel tcltest::testEval [list $command] 1] - } - } else { - set testResult setupFailure - } - - # Run the cleanup code - if {[catch {uplevel $cleanup} cleanupMsg]} { - set cleanupFailure 1 - } - - # If testResult is an empty list, then the test was skipped - if {$testResult != {}} { - set coreFailure 0 - set coreMsg "" - # check for a core file first - if one was created by the test, then - # the test failed - if {$tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - if {[file exists [file join [tcltest::workingDirectory] core]]} { - # There's only a test failure if there is a core file and (1) - # there previously wasn't one or (2) the new one is different - # from the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join [tcltest::workingDirectory] core]]} { - set coreFailure 1 - } - } else { - set coreFailure 1 - } - - if {($tcltest::preserveCore > 1) && ($coreFailure)} { - append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]" - catch {file rename -force \ - [file join [tcltest::workingDirectory] core] \ - [file join $tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - append coreMsg "\nError: Problem renaming core file: $msg" - } - } - } - array set tcl_platform $currentTclPlatform - } - - set actualAnswer [lindex $testResult 0] - set code [lindex $testResult end] - - # If expected output/error strings exist, we have to compare - # them. If the comparison fails, then so did the test. - set outputFailure 0 - set errorFailure 0 - if {[info exists output]} { - set outputFailure [expr ![compareStrings $tcltest::outData \ - $output $match]] - } - if {[info exists errorOutput]} { - set errorFailure [expr ![compareStrings $tcltest::errData \ - $errorOutput $match]] - } - - set testFailed 1 - set codeFailure 0 - set scriptFailure 0 - - # check if the return code matched the expected return code - if {[lsearch -exact $returnCodes $code] == -1} { - set codeFailure 1 - } - - # check if the answer matched the expected answer - if {[compareStrings $actualAnswer $result $match] == 0} { - set scriptFailure 1 - } - - # if we didn't experience any failures, then we passed - if {!($setupFailure || $cleanupFailure || $coreFailure || \ - $outputFailure || $errorFailure || $codeFailure || \ - $scriptFailure)} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Passed) - if {[tcltest::isVerbose pass]} { - puts [outputChannel] "++++ $name PASSED" - } - } - set testFailed 0 - } - - if {$testFailed} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Failed) - } - set tcltest::currentFailure true - if {![tcltest::isVerbose body]} { - set body "" - } - puts [outputChannel] "\n==== $name [string trim $description] FAILED" - if {$body != ""} { - puts [outputChannel] "==== Contents of test case:" - puts [outputChannel] $body - } - if {$setupFailure} { - puts [outputChannel] "---- Test setup failed:\n$setupMsg" - } - if {$scriptFailure} { - puts [outputChannel] "---- Result was:\n$actualAnswer" - puts [outputChannel] "---- Result should have been ($match matching):\n$result" - } - if {$codeFailure} { - switch -- $code { - 0 { set msg "Test completed normally" } - 1 { set msg "Test generated error" } - 2 { set msg "Test generated return exception" } - 3 { set msg "Test generated break exception" } - 4 { set msg "Test generated continue exception" } - default { set msg "Test generated exception" } - } - puts [outputChannel] "---- $msg; Return code was: $code" - puts [outputChannel] "---- Return code should have been one of: $returnCodes" - if {[tcltest::isVerbose error]} { - if {[info exists ::errorInfo]} { - puts [outputChannel] "---- errorInfo: $::errorInfo" - puts [outputChannel] "---- errorCode: $::errorCode" - } - } - } - if {$outputFailure} { - puts [outputChannel] "---- Output was:\n$tcltest::outData" - puts [outputChannel] "---- Output should have been ($match matching):\n$output" - } - if {$errorFailure} { - puts [outputChannel] "---- Error output was:\n$tcltest::errData" - puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput" - } - if {$cleanupFailure} { - puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" - } - if {$coreFailure} { - puts [outputChannel] "---- Core file produced while running test! $coreMsg" - } - puts [outputChannel] "==== $name FAILED\n" - - } - } - - incr tcltest::testLevel -1 - return 0 -} - - -# runTest -- -# -# This is the defnition of the version 1.0 test routine for tcltest. It is -# provided here for backward compatibility. It is also used as the 'backbone' -# of the test procedure, as in, this is where all the work really gets done. -# -# This procedure runs a test and prints an error message if the test fails. -# If tcltest::verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# tcltest::match variable, if it matches an element in -# tcltest::skip, or if one of the elements of "constraints" turns -# out not to be true. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "tcltest::testConstraints". If any of these -# elements is zero, the test is skipped. -# This argument may be omitted. -# script - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. -# expectedAnswer - Expected result from script. -# -# Behavior depends on the value of testLevel; if testLevel is 1 (top level), -# then events are logged and we track the number of tests run/skipped and why. -# Otherwise, we don't track this information. -# -# Results: -# empty list if test is skipped; otherwise returns list containing -# actual returned value from the test and the return code. -# -# Side Effects: -# none. -# - -proc tcltest::runTest {name description script expectedAnswer constraints} { - - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Total) - } - - # skip the test if it's name matches an element of skip - foreach pattern $tcltest::skip { - if {[string match $pattern $name]} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip} - } - return - } - } - - # skip the test if it's name doesn't match any element of match - if {[llength $tcltest::match] > 0} { - set ok 0 - foreach pattern $tcltest::match { - if {[string match $pattern $name]} { - set ok 1 - break - } - } - if {!$ok} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch} - } - return - } - } - - DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints" - - if {$constraints == {}} { - # If we're limited to the listed constraints and there aren't any - # listed, then we shouldn't run the test. - if {$tcltest::limitConstraints} { - tcltest::AddToSkippedBecause userSpecifiedLimitConstraint - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - } - return - } - } else { - # "constraints" argument exists; - # make sure that the constraints are satisfied. - - set doTest 0 - if {[string match {*[$\[]*} $constraints] != 0} { - # full expression, e.g. {$foo > [info tclversion]} - catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { - # something like {a || b} should be turned into - # $tcltest::testConstraints(a) || $tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$tcltest::testConstraints(&)} c - catch {set doTest [eval expr $c]} - } else { - # just simple constraints such as {unixOnly fonts}. - set doTest 1 - foreach constraint $constraints { - if {(![info exists tcltest::testConstraints($constraint)]) \ - || (!$tcltest::testConstraints($constraint))} { - set doTest 0 - - # store the constraint that kept the test from running - set constraints $constraint - break - } - } - } - - if {$doTest == 0} { - if {[tcltest::isVerbose skip]} { - puts [outputChannel] "++++ $name SKIPPED: $constraints" - } - - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - tcltest::AddToSkippedBecause $constraints - } - return - } - } - - # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with - # tcl_platform. - - if {$tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - array set tcl_platform $tcltest::originalTclPlatform - if {[file exists [file join [tcltest::workingDirectory] core]]} { - set coreModTime [file mtime [file join \ - [tcltest::workingDirectory] core]] - } - array set tcl_platform $currentTclPlatform - } - - # If there is no "memory" command (because memory debugging isn't - # enabled), then don't attempt to use the command. - - if {[info commands memory] != {}} { - memory tag $name - } - - if {[tcltest::isVerbose start]} { - puts [outputChannel] "---- $name start" - flush [outputChannel] - } - - set code [catch {uplevel $script} actualAnswer] - - return [list $actualAnswer $code] -} - -##################################################################### - -# tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} { - proc tcltest::cleanupTestsHook {} {} -} - -# tcltest::cleanupTests -- -# -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. -# -# Print the names of the files created without the makeFile command -# since the tests were invoked. -# -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). -# -# Arguments: -# calledFromAllFile - if 0, behave as if we are running a single test file -# within an entire suite of tests. if we aren't running a single test -# file, then don't report status. check for new files created during the -# test run and report on them. if 1, report collated status from all the -# test file runs. -# -# Results: -# None. -# -# Side Effects: -# None -# - -proc tcltest::cleanupTests {{calledFromAllFile 0}} { - - set testFileName [file tail [info script]] - - # Call the cleanup hook - tcltest::cleanupTestsHook - - # Remove files and directories created by the :tcltest::makeFile and - # tcltest::makeDirectory procedures. - # Record the names of files in tcltest::workingDirectory that were not - # pre-existing, and associate them with the test file that created them. - - if {!$calledFromAllFile} { - foreach file $tcltest::filesMade { - if {[file exists $file]} { - catch {file delete -force $file} - } - } - set currentFiles {} - foreach file [glob -nocomplain \ - [file join $tcltest::temporaryDirectory *]] { - lappend currentFiles [file tail $file] - } - set newFiles {} - foreach file $currentFiles { - if {[lsearch -exact $tcltest::filesExisted $file] == -1} { - lappend newFiles $file - } - } - set tcltest::filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set tcltest::createdNewFiles($testFileName) $newFiles - } - } - - if {$calledFromAllFile || $tcltest::testSingleFile} { - - # print stats - - puts -nonewline [outputChannel] "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline [outputChannel] \ - "\t$index\t$tcltest::numTests($index)" - } - puts [outputChannel] "" - - # print number test files sourced - # print names of files that ran tests which failed - - if {$calledFromAllFile} { - puts [outputChannel] \ - "Sourced $tcltest::numTestFiles Test Files." - set tcltest::numTestFiles 0 - if {[llength $tcltest::failFiles] > 0} { - puts [outputChannel] \ - "Files with failing tests: $tcltest::failFiles" - set tcltest::failFiles {} - } - } - - # if any tests were skipped, print the constraints that kept them - # from running. - - set constraintList [array names tcltest::skippedBecause] - if {[llength $constraintList] > 0} { - puts [outputChannel] \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts [outputChannel] \ - "\t$tcltest::skippedBecause($constraint)\t$constraint" - unset tcltest::skippedBecause($constraint) - } - } - - # report the names of test files in tcltest::createdNewFiles, and - # reset the array to be empty. - - set testFilesThatTurded [lsort [array names tcltest::createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts [outputChannel] "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts [outputChannel] \ - "\t$testFile:\t$tcltest::createdNewFiles($testFile)" - unset tcltest::createdNewFiles($testFile) - } - } - - # reset filesMade, filesExisted, and numTests - - set tcltest::filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set tcltest::numTests($index) 0 - } - - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && ![info exists tcl_interactive]} { - exit - } - } else { - - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed - - incr tcltest::numTestFiles - if {($tcltest::currentFailure) && \ - ([lsearch -exact $tcltest::failFiles $testFileName] == -1)} { - lappend tcltest::failFiles $testFileName - } - set tcltest::currentFailure false - - # restore the environment to the state it was in before this package - # was loaded - - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists tcltest::originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { - if {$::env($index) != $tcltest::originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $tcltest::originalEnv($index) - } - } - } - foreach index [array names tcltest::originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $tcltest::originalEnv($index) - } - } - if {[llength $newEnv] > 0} { - puts [outputChannel] \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts [outputChannel] \ - "env array elements changed:\t$changedEnv" - } - if {[llength $removedEnv] > 0} { - puts [outputChannel] \ - "env array elements removed:\t$removedEnv" - } - - set changedTclPlatform {} - foreach index [array names tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $tcltest::originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $tcltest::originalTclPlatform($index) - } - } - if {[llength $changedTclPlatform] > 0} { - puts [outputChannel] \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } - - if {[file exists [file join [tcltest::workingDirectory] core]]} { - if {$tcltest::preserveCore > 1} { - puts "rename core file (> 1)" - puts [outputChannel] "produced core file! \ - Moving file to: \ - [file join $tcltest::temporaryDirectory core-$name]" - catch {file rename -force \ - [file join [tcltest::workingDirectory] core] \ - [file join $tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - tcltest::PrintError "Problem renaming file: $msg" - } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists tcltest::coreModificationTime]} { - if {$tcltest::coreModificationTime != [file mtime \ - [file join [tcltest::workingDirectory] core]]} { - puts [outputChannel] "A core file was created!" - } - } else { - puts [outputChannel] "A core file was created!" - } - } - } - } - flush [outputChannel] - flush [errorChannel] - return -} - -##################################################################### - -# Procs that determine which tests/test files to run - -# tcltest::getMatchingFiles -# -# Looks at the patterns given to match and skip files -# and uses them to put together a list of the tests that will be run. -# -# Arguments: -# directory to search -# -# Results: -# The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. It is used in runAllTests. -# -# Side Effects: -# None - -proc tcltest::getMatchingFiles { {searchDirectory ""} } { - if {[llength [info level 0]] == 1} { - set searchDirectory [tcltest::testsDirectory] - } - set matchingFiles {} - - # Find the matching files in the list of directories and then remove the - # ones that match the skip pattern - foreach directory $searchDirectory { - set matchFileList {} - foreach match $tcltest::matchFiles { - set matchFileList [concat $matchFileList \ - [glob -nocomplain [file join $directory $match]]] - } - if {[string compare {} $tcltest::skipFiles]} { - set skipFileList {} - foreach skip $tcltest::skipFiles { - set skipFileList [concat $skipFileList \ - [glob -nocomplain [file join $directory $skip]]] - } - foreach file $matchFileList { - # Only include files that don't match the skip pattern and - # aren't SCCS lock files. - if {([lsearch -exact $skipFileList $file] == -1) && \ - (![string match l.*.test [file tail $file]])} { - lappend matchingFiles $file - } - } - } else { - set matchingFiles [concat $matchingFiles $matchFileList] - } - } - if {[string equal $matchingFiles {}]} { - tcltest::PrintError "No test files remain after applying \ - your match and skip patterns!" - } - return $matchingFiles -} - -# tcltest::getMatchingDirectories -- -# -# Looks at the patterns given to match and skip directories and uses them -# to put together a list of the test directories that we should attempt -# to run. (Only subdirectories containing an "all.tcl" file are put into -# the list.) -# -# Arguments: -# root directory from which to search -# -# Results: -# The constructed list is returned to the user. This is used in the -# primary all.tcl file. Lower-level all.tcl files should use the -# tcltest::testAllFiles proc instead. -# -# Side Effects: -# None. - -proc tcltest::getMatchingDirectories {rootdir} { - set matchingDirs {} - set matchDirList {} - # Find the matching directories in tcltest::testsDirectory and then - # remove the ones that match the skip pattern - foreach match $tcltest::matchDirectories { - foreach file [glob -nocomplain [file join $rootdir $match]] { - if {([file isdirectory $file]) && ($file != $rootdir)} { - set matchDirList [concat $matchDirList \ - [tcltest::getMatchingDirectories $file]] - if {[file exists [file join $file all.tcl]]} { - set matchDirList [concat $matchDirList $file] - } - } - } - } - if {$tcltest::skipDirectories != {}} { - set skipDirs {} - foreach skip $tcltest::skipDirectories { - set skipDirs [concat $skipDirs \ - [glob -nocomplain [file join $tcltest::testsDirectory \ - $skip]]] - } - foreach dir $matchDirList { - # Only include directories that don't match the skip pattern - if {[lsearch -exact $skipDirs $dir] == -1} { - lappend matchingDirs $dir - } - } - } else { - set matchingDirs [concat $matchingDirs $matchDirList] - } - if {$matchingDirs == {}} { - DebugPuts 1 "No test directories remain after applying match and skip patterns!" - } - return $matchingDirs -} - -# tcltest::runAllTests -- -# -# prints output and sources test files according to the match and skip -# patterns provided. after sourcing test files, it goes on to source -# all.tcl files in matching test subdirectories. -# -# Arguments: -# shell being tested -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::runAllTests { {shell ""} } { - global argv - - if {[llength [info level 0]] == 1} { - set shell [tcltest::interpreter] - } - - set tcltest::testSingleFile false - - puts [outputChannel] "Tests running in interp: $shell" - puts [outputChannel] "Tests located in: $tcltest::testsDirectory" - puts [outputChannel] "Tests running in: [tcltest::workingDirectory]" - puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory" - if {[tcltest::singleProcess]} { - puts [outputChannel] "Test files sourced into current interpreter" - } else { - puts [outputChannel] "Test files run in separate interpreters" - } - if {[llength $tcltest::skip] > 0} { - puts [outputChannel] "Skipping tests that match: $tcltest::skip" - } - if {[llength $tcltest::match] > 0} { - puts [outputChannel] "Only running tests that match: $tcltest::match" - } - - if {[llength $tcltest::skipFiles] > 0} { - puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles" - } - if {[llength $tcltest::matchFiles] > 0} { - puts [outputChannel] "Only running test files that match: $tcltest::matchFiles" - } - - set timeCmd {clock format [clock seconds]} - puts [outputChannel] "Tests began at [eval $timeCmd]" - - # Run each of the specified tests - foreach file [lsort [tcltest::getMatchingFiles]] { - set tail [file tail $file] - puts [outputChannel] $tail - - if {$tcltest::singleProcess} { - incr tcltest::numTestFiles - uplevel [list source $file] - } else { - # Change to the tests directory so the value of the following - # variable is set correctly when we spawn the child test processes - cd $tcltest::testsDirectory - set cmd [concat [list | $shell $file] [split $argv]] - if {[catch { - incr tcltest::numTestFiles - set pipeFd [open $cmd "r"] - while {[gets $pipeFd line] >= 0} { - if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - incr tcltest::numTests($index) [set $index] - } - if {$Failed > 0} { - lappend tcltest::failFiles $testFile - } - } elseif {[regexp {^Number of tests skipped for each constraint:|^\t(\d+)\t(.+)$} $line match skipped constraint]} { - if {$match != "Number of tests skipped for each constraint:"} { - tcltest::AddToSkippedBecause $constraint $skipped - } - } else { - puts [outputChannel] $line - } - } - close $pipeFd - } msg]} { - # Print results to tcltest::outputChannel. - puts [outputChannel] "Test file error: $msg" - # append the name of the test to a list to be reported later - lappend testFileFailures $file - } - } - } - - # cleanup - puts [outputChannel] "\nTests ended at [eval $timeCmd]" - tcltest::cleanupTests 1 - if {[info exists testFileFailures]} { - puts [outputChannel] "\nTest files exiting with errors: \n" - foreach file $testFileFailures { - puts " [file tail $file]\n" - } - } - - # Checking for subdirectories in which to run tests - foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] { - set dir [file tail $directory] - puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - puts [outputChannel] "$dir test began at [eval $timeCmd]\n" - - uplevel "source [file join $directory all.tcl]" - - set endTime [eval $timeCmd] - puts [outputChannel] "\n$dir test ended at $endTime" - puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - } - return -} - -##################################################################### - -# Test utility procs - not used in tcltest, but may be useful for testing. - -# tcltest::loadTestedCommands -- -# -# Uses the specified script to load the commands to test. Allowed to -# be empty, as the tested commands could have been compiled into the -# interpreter. -# -# Arguments -# none -# -# Results -# none -# -# Side Effects: -# none. - -proc tcltest::loadTestedCommands {} { - if {$tcltest::loadScript == {}} { - return - } - - return [uplevel $tcltest::loadScript] -} - -# tcltest::saveState -- -# -# Save information regarding what procs and variables exist. -# -# Arguments: -# none -# -# Results: -# Modifies the variable tcltest::saveState -# -# Side effects: -# None. - -proc tcltest::saveState {} { - uplevel {set tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "tcltest::saveState: $tcltest::saveState" - return -} - -# tcltest::restoreState -- -# -# Remove procs and variables that didn't exist before the call to -# tcltest::saveState. -# -# Arguments: -# none -# -# Results: -# Removes procs and variables from your environment if they don't exist -# in the tcltest::saveState variable. -# -# Side effects: -# None. - -proc tcltest::restoreState {} { - foreach p [info procs] { - if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \ - (![string match "*tcltest::$p" [namespace origin $p]])} { - - DebugPuts 2 "tcltest::restoreState: Removing proc $p" - rename $p {} - } - } - foreach p [uplevel {info vars}] { - if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} { - DebugPuts 2 "tcltest::restoreState: Removing variable $p" - uplevel "catch {unset $p}" - } - } - return -} - -# tcltest::normalizeMsg -- -# -# Removes "extra" newlines from a string. -# -# Arguments: -# msg String to be modified -# -# Results: -# string with extra newlines removed -# -# Side effects: -# None. - -proc tcltest::normalizeMsg {msg} { - regsub "\n$" [string tolower $msg] "" msg - regsub -all "\n\n" $msg "\n" msg - regsub -all "\n\}" $msg "\}" msg - return $msg -} - -# tcltest::makeFile -- -# -# Create a new file with the name <name>, and write <contents> to it. -# -# If this file hasn't been created via makeFile since the last time -# cleanupTests was called, add it to the $filesMade list, so it will -# be removed by the next call to cleanupTests. -# -# Arguments: -# contents content of the new file -# name name of the new file -# directory directory name for new file -# -# Results: -# absolute path to the file created -# -# Side effects: -# None. - -proc tcltest::makeFile {contents name {directory ""}} { - global tcl_platform - - if {[llength [info level 0]] == 3} { - set directory [tcltest::temporaryDirectory] - } - - set fullName [file join $directory $name] - - DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" - - set fd [open $fullName w] - - fconfigure $fd -translation lf - - if {[string equal [string index $contents end] "\n"]} { - puts -nonewline $fd $contents - } else { - puts $fd $contents - } - close $fd - - if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { - lappend tcltest::filesMade $fullName - } - return $fullName -} - -# tcltest::removeFile -- -# -# Removes the named file from the filesystem -# -# Arguments: -# name file to be removed -# directory directory from which to remove file -# -# Results: -# return value from [file delete] -# -# Side effects: -# None. - -proc tcltest::removeFile {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::removeFile: removing $fullName" - return [file delete $fullName] -} - -# tcltest::makeDirectory -- -# -# Create a new dir with the name <name>. -# -# If this dir hasn't been created via makeDirectory since the last time -# cleanupTests was called, add it to the $directoriesMade list, so it will -# be removed by the next call to cleanupTests. -# -# Arguments: -# name name of the new directory -# directory directory in which to create new dir -# -# Results: -# absolute path to the directory created -# -# Side effects: -# None. - -proc tcltest::makeDirectory {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::makeDirectory: creating $fullName" - file mkdir $fullName - if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { - lappend tcltest::filesMade $fullName - } - return $fullName -} - -# tcltest::removeDirectory -- -# -# Removes a named directory from the file system. -# -# Arguments: -# name Name of the directory to remove -# directory Directory from which to remove -# -# Results: -# return value from [file delete] -# -# Side effects: -# None - -proc tcltest::removeDirectory {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" - return [file delete -force $fullName] -} - -# tcltest::viewFile -- -# -# reads the content of a file and returns it -# -# Arguments: -# name of the file to read -# directory in which file is located -# -# Results: -# content of the named file -# -# Side effects: -# None. - -proc tcltest::viewFile {name {directory ""}} { - global tcl_platform - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ([tcltest::testConstraint unixExecs] == 0)} { - set f [open $fullName] - set data [read -nonewline $f] - close $f - return $data - } else { - return [exec cat $fullName] - } - return -} - -# tcltest::bytestring -- -# -# Construct a string that consists of the requested sequence of bytes, -# as opposed to a string of properly formed UTF-8 characters. -# This allows the tester to -# 1. Create denormalized or improperly formed strings to pass to C procedures -# that are supposed to accept strings with embedded NULL bytes. -# 2. Confirm that a string result has a certain pattern of bytes, for instance -# to confirm that "\xe0\0" in a Tcl script is stored internally in -# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". -# -# Generally, it's a bad idea to examine the bytes in a Tcl string or to -# construct improperly formed strings in this manner, because it involves -# exposing that Tcl uses UTF-8 internally. -# -# Arguments: -# string being converted -# -# Results: -# result fom encoding -# -# Side effects: -# None - -proc tcltest::bytestring {string} { - return [encoding convertfrom identity $string] -} - -# tcltest::openfiles -- -# -# used in io tests, uses testchannel -# -# Arguments: -# None. -# -# Results: -# ??? -# -# Side effects: -# None. - -proc tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} - } - return $result -} - -# tcltest::leakfiles -- -# -# used in io tests, uses testchannel -# -# Arguments: -# None. -# -# Results: -# ??? -# -# Side effects: -# None. - -proc tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} - } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p - } - } - return $leak -} - -# -# Internationalization / ISO support procs -- dl -# - -# tcltest::set_iso8859_1_locale -- -# -# used in cmdIL.test, uses testlocale -# -# Arguments: -# None. -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::set_iso8859_1_locale {} { - if {[info commands testlocale] != ""} { - set tcltest::previousLocale [testlocale ctype] - testlocale ctype $tcltest::isoLocale - } - return -} - -# tcltest::restore_locale -- -# -# used in cmdIL.test, uses testlocale -# -# Arguments: -# None. -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::restore_locale {} { - if {[info commands testlocale] != ""} { - testlocale ctype $tcltest::previousLocale - } - return -} - -# tcltest::threadReap -- -# -# Kill all threads except for the main thread. -# Do nothing if testthread is not defined. -# -# Arguments: -# none. -# -# Results: -# Returns the number of existing threads. -# -# Side Effects: -# none. -# - -proc tcltest::threadReap {} { - if {[info commands testthread] != {}} { - - # testthread built into tcltest - - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != $tcltest::mainThread} { - catch {testthread send -async $tid {testthread exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - testthread errorproc ThreadError - return [llength [testthread names]] - } elseif {[info commands thread::id] != {}} { - - # Thread extension - - thread::errorproc ThreadNullError - while {[llength [thread::names]] > 1} { - foreach tid [thread::names] { - if {$tid != $tcltest::mainThread} { - catch {thread::send -async $tid {thread::exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - thread::errorproc ThreadError - return [llength [thread::names]] - } else { - return 1 - } - return 0 -} - -# Initialize the constraints and set up command line arguments -namespace eval tcltest { - # Ensure that we have a minimal auto_path so we don't pick up extra junk. - set ::auto_path [list [info library]] - - tcltest::initConstraints - if {[namespace children [namespace current]] == {}} { - tcltest::processCmdLineArgs - } - - # Save the names of files that already exist in - # the output directory. - foreach file [glob -nocomplain \ - [file join $tcltest::temporaryDirectory *]] { - lappend tcltest::filesExisted [file tail $file] - } -} - -package provide tcltest 2.0 - diff --git a/library/tcltest1.0/pkgIndex.tcl b/library/tcltest1.0/pkgIndex.tcl index e3746e2..da93644 100644 --- a/library/tcltest1.0/pkgIndex.tcl +++ b/library/tcltest1.0/pkgIndex.tcl @@ -8,5 +8,4 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded tcltest 1.0 [list source [file join $dir tcltest.tcl]] -package ifneeded tcltest 2.0 [list source [file join $dir tcltest2.tcl]] +package ifneeded tcltest 2.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl index 63639e3..80f80c7 100644 --- a/library/tcltest1.0/tcltest.tcl +++ b/library/tcltest1.0/tcltest.tcl @@ -1,7 +1,7 @@ # tcltest.tcl -- # # This file contains support code for the Tcl test suite. It -# defines the ::tcltest namespace and finds and defines the output +# defines the tcltest namespace and finds and defines the output # directory, constraints available, output and error channels, etc. used # by Tcl tests. See the tcltest man page for more details. # @@ -10,11 +10,10 @@ # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.27 2000/09/06 18:50:15 hobbs Exp $ - -package provide tcltest 1.0 +# RCS: @(#) $Id: tcltest.tcl,v 1.28 2000/10/24 22:30:32 jenn Exp $ # create the "tcltest" namespace for all testing variables and procedures @@ -23,19 +22,25 @@ namespace eval tcltest { # Export the public tcltest procs set procList [list test cleanupTests saveState restoreState \ normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring safeFetch threadReap getMatchingFiles \ - loadTestedCommands normalizePath] + viewFile bytestring threadReap debug testConstraint \ + limitConstraints loadTestedCommands normalizePath verbose match \ + skip matchFiles skipFiles preserveCore loadScript loadFile \ + mainThread workingDirectory singleProcess interpreter runAllTests \ + outputChannel outputFile errorChannel \ + errorFile temporaryDirectory testsDirectory matchDirectories \ + skipDirectories ] foreach proc $procList { namespace export $proc } - # ::tcltest::verbose defaults to "b" + # tcltest::verbose defaults to {body} if {![info exists verbose]} { - variable verbose "b" + variable verbose {body} } # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory + # matchFiles, which defaults to all .test files in the testsDirectory and + # matchDirectories, which defaults to all directories. if {![info exists match]} { variable match {} @@ -49,6 +54,12 @@ namespace eval tcltest { if {![info exists skipFiles]} { variable skipFiles {} } + if {![info exists matchDirectories]} { + variable matchDirectories {*} + } + if {![info exists skipDirectories]} { + variable skipDirectories {} + } # By default, don't save core files if {![info exists preserveCore]} { @@ -59,11 +70,17 @@ namespace eval tcltest { if {![info exists outputChannel]} { variable outputChannel stdout } + if {![info exists outputFile]} { + variable outputFile stdout + } # errors go to stderr by default if {![info exists errorChannel]} { variable errorChannel stderr } + if {![info exists errorFile]} { + variable errorFile stderr + } # debug output doesn't get printed by default; debug level 1 spits # up only the tests that were skipped because they didn't match or were @@ -81,9 +98,9 @@ namespace eval tcltest { variable parameters {} } - # Count the number of files tested (0 if all.tcl wasn't called). - # The all.tcl file will set testSingleFile to false, so stats will - # not be printed until all.tcl calls the cleanupTests proc. + # Count the number of files tested (0 if runAllTests wasn't called). + # runAllTests will set testSingleFile to false, so stats will + # not be printed until runAllTests calls the cleanupTests proc. # The currentFailure var stores the boolean value of whether the # current test file has had any failures. The failFiles list # stores the names of test files that had failures. @@ -103,9 +120,9 @@ namespace eval tcltest { # Tests should remove all files they create. The test suite will # check the current working dir for files created by the tests. - # ::tcltest::filesMade keeps track of such files created using the - # ::tcltest::makeFile and ::tcltest::makeDirectory procedures. - # ::tcltest::filesExisted stores the names of pre-existing files. + # tcltest::filesMade keeps track of such files created using the + # tcltest::makeFile and tcltest::makeDirectory procedures. + # tcltest::filesExisted stores the names of pre-existing files. if {![info exists filesMade]} { variable filesMade {} @@ -114,43 +131,47 @@ namespace eval tcltest { variable filesExisted {} } - # ::tcltest::numTests will store test files as indices and the list + # tcltest::numTests will store test files as indices and the list # of files (that should not have been) left behind by the test files. if {![info exists createdNewFiles]} { variable createdNewFiles - array set ::tcltest::createdNewFiles {} + array set tcltest::createdNewFiles {} } - # initialize ::tcltest::numTests array to keep track fo the number of + # initialize tcltest::numTests array to keep track fo the number of # tests that pass, fail, and are skipped. if {![info exists numTests]} { variable numTests - array set ::tcltest::numTests \ + array set tcltest::numTests \ [list Total 0 Passed 0 Skipped 0 Failed 0] } - # initialize ::tcltest::skippedBecause array to keep track of + # initialize tcltest::skippedBecause array to keep track of # constraints that kept tests from running; a constraint name of # "userSpecifiedSkip" means that the test appeared on the list of tests # that matched the -skip value given to the flag; "userSpecifiedNonMatch" # means that the test didn't match the argument given to the -match flag; - # both of these constraints are counted only if ::tcltest::debug is set to + # both of these constraints are counted only if tcltest::debug is set to # true. if {![info exists skippedBecause]} { variable skippedBecause - array set ::tcltest::skippedBecause {} + array set tcltest::skippedBecause {} } - # initialize the ::tcltest::testConstraints array to keep track of valid + # initialize the tcltest::testConstraints array to keep track of valid # predefined constraints (see the explanation for the - # ::tcltest::initConstraints proc for more details). + # tcltest::initConstraints proc for more details). if {![info exists testConstraints]} { variable testConstraints - array set ::tcltest::testConstraints {} + array set tcltest::testConstraints {} + } + + if {![info exists constraintsSpecified]} { + variable constraintsSpecified {} } # Don't run only the constrained tests by default @@ -166,6 +187,11 @@ namespace eval tcltest { variable loadScript {} } + # and the filename of the script file, if it exists + if {![info exists loadFile]} { + variable loadFile {} + } + # tests that use threads need to know which is the main thread if {![info exists mainThread]} { @@ -181,10 +207,10 @@ namespace eval tcltest { if {![info exists originalEnv]} { variable originalEnv - array set ::tcltest::originalEnv [array get ::env] + array set tcltest::originalEnv [array get ::env] } - # Set ::tcltest::workingDirectory to [pwd]. The default output directory + # Set tcltest::workingDirectory to [pwd]. The default output directory # for Tcl tests is the working directory. if {![info exists workingDirectory]} { @@ -196,7 +222,7 @@ namespace eval tcltest { # Tests should not rely on the current working directory. # Files that are part of the test suite should be accessed relative to - # ::tcltest::testsDirectory. + # tcltest::testsDirectory. if {![info exists testsDirectory]} { set oldpwd [pwd] @@ -206,30 +232,40 @@ namespace eval tcltest { unset oldpwd } - # the variables and procs that existed when ::tcltest::saveState was + # Default is to run each test file in a separate process + if {![info exists singleProcess]} { + variable singleProcess 0 + } + + # the variables and procs that existed when tcltest::saveState was # called are stored in a variable of the same name if {![info exists saveState]} { variable saveState {} } - # Internationalization support + # Internationalization support -- used in tcltest::set_iso8859_1_locale + # and tcltest::restore_locale. Those commands are used in cmdIL.test. + if {![info exists previousLocale]} { + variable previousLocale + } + if {![info exists isoLocale]} { variable isoLocale fr - switch $tcl_platform(platform) { + switch -- $tcl_platform(platform) { "unix" { # Try some 'known' values for some platforms: switch -exact -- $tcl_platform(os) { "FreeBSD" { - set ::tcltest::isoLocale fr_FR.ISO_8859-1 + set tcltest::isoLocale fr_FR.ISO_8859-1 } HP-UX { - set ::tcltest::isoLocale fr_FR.iso88591 + set tcltest::isoLocale fr_FR.iso88591 } Linux - IRIX { - set ::tcltest::isoLocale fr + set tcltest::isoLocale fr } default { @@ -237,12 +273,12 @@ namespace eval tcltest { # define it to something else on your system #if you want to test those. - set ::tcltest::isoLocale iso_8859_1 + set tcltest::isoLocale iso_8859_1 } } } "windows" { - set ::tcltest::isoLocale French + set tcltest::isoLocale French } } } @@ -250,7 +286,7 @@ namespace eval tcltest { # Set the location of the execuatble if {![info exists tcltest]} { variable tcltest [info nameofexecutable] - } + } # save the platform information so it can be restored later if {![info exists originalTclPlatform]} { @@ -259,29 +295,34 @@ namespace eval tcltest { # If a core file exists, save its modification time. if {![info exists coreModificationTime]} { - if {[file exists [file join $::tcltest::workingDirectory core]]} { + if {[file exists [file join $tcltest::workingDirectory core]]} { variable coreModificationTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + $tcltest::workingDirectory core]] } } - # Tcl version numbers - if {![info exists version]} { - variable version 8.4 + # stdout and stderr buffers for use when we want to store them + if {![info exists outData]} { + variable outData {} } - if {![info exists patchLevel]} { - variable patchLevel 8.4a2 + if {![info exists errData]} { + variable errData {} } + + # keep track of test level for nested test commands + variable testLevel 0 } -# ::tcltest::Debug* -- +##################################################################### + +# tcltest::Debug* -- # # Internal helper procedures to write out debug information # dependent on the chosen level. A test shell may overide # them, f.e. to redirect the output into a different # channel, or even into a GUI. -# ::tcltest::DebugPuts -- +# tcltest::DebugPuts -- # # Prints the specified string if the current debug level is # higher than the provided level argument. @@ -293,15 +334,19 @@ namespace eval tcltest { # Results: # Prints the string. Nothing else is allowed. # +# Side Effects: +# None. +# -proc ::tcltest::DebugPuts {level string} { +proc tcltest::DebugPuts {level string} { variable debug if {$debug >= $level} { puts $string } + return } -# ::tcltest::DebugPArray -- +# tcltest::DebugPArray -- # # Prints the contents of the specified array if the current # debug level is higher than the provided level argument @@ -313,17 +358,21 @@ proc ::tcltest::DebugPuts {level string} { # Results: # Prints the contents of the array. Nothing else is allowed. # +# Side Effects: +# None. +# -proc ::tcltest::DebugPArray {level arrayvar} { +proc tcltest::DebugPArray {level arrayvar} { variable debug if {$debug >= $level} { catch {upvar $arrayvar $arrayvar} parray $arrayvar } + return } -# ::tcltest::DebugDo -- +# tcltest::DebugDo -- # # Executes the script if the current debug level is greater than # the provided level argument @@ -335,16 +384,779 @@ proc ::tcltest::DebugPArray {level arrayvar} { # Results: # Arbitrary side effects, dependent on the executed script. # +# Side Effects: +# None. +# -proc ::tcltest::DebugDo {level script} { +proc tcltest::DebugDo {level script} { variable debug if {$debug >= $level} { uplevel $script } + return +} + +##################################################################### + +# tcltest::CheckDirectory -- +# +# This procedure checks whether the specified path is a readable +# and/or writable directory. If one of the conditions is not +# satisfied an error is printed and the application aborted. The +# procedure assumes that the caller already checked the existence +# of the path. +# +# Arguments +# rw Information what attributes to check. Allowed values: +# r, w, rw, wr. If 'r' is part of the value the directory +# must be readable. 'w' associates to 'writable'. +# dir The directory to check. +# errMsg The string to prepend to the actual error message before +# printing it. +# +# Results +# none +# +# Side Effects: +# None. +# + +proc tcltest::CheckDirectory {rw dir errMsg} { + # Allowed values for 'rw': r, w, rw, wr + + if {![file isdir $dir]} { + set msg "$errMsg \"$dir\" is not a directory" + error $msg + } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { + set msg "$errMsg \"$dir\" is not writeable" + error $msg + } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { + set msg "$errMsg \"$dir\" is not readable" + error $msg + } + return +} + +# tcltest::normalizePath -- +# +# This procedure resolves any symlinks in the path thus creating a +# path without internal redirection. It assumes that the incoming +# path is absolute. +# +# Arguments +# pathVar contains the name of the variable containing the path to modify. +# +# Results +# The path is modified in place. +# +# Side Effects: +# None. +# + +proc tcltest::normalizePath {pathVar} { + upvar $pathVar path + + set oldpwd [pwd] + catch {cd $path} + set path [pwd] + cd $oldpwd + return $path +} + + +# tcltest::MakeAbsolutePath -- +# +# This procedure checks whether the incoming path is absolute or not. +# Makes it absolute if it was not. +# +# Arguments +# pathVar contains the name of the variable containing the path to modify. +# prefix is optional, contains the path to use to make the other an +# absolute one. The current working directory is used if it was +# not specified. +# +# Results +# The path is modified in place. +# +# Side Effects: +# None. +# + +proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { + upvar $pathVar path + + if {![string equal [file pathtype $path] "absolute"]} { + if {$prefix == {}} { + set prefix [pwd] + } + + set path [file join $prefix $path] + } + return $path +} + +##################################################################### + +# tcltest::<variableName> +# +# Accessor functions for tcltest variables that can be modified externally. +# These are vars that could otherwise be modified using command line +# arguments to tcltest. + +# tcltest::verbose -- +# +# Set or return the verbosity level (tcltest::verbose) for tests. This +# determines what gets printed to the screen and when, with regard to the +# running of the tests. The proc does not check for invalid values. It +# assumes that a string that doesn't match its predefined keywords +# is a string containing letter-specified verbosity levels. +# +# Arguments: +# A string containing any combination of 'pbste' or a list of keywords +# (listed in parens) +# p = print output whenever a test passes (pass) +# b = print the body of the test when it fails (body) +# s = print when a test is skipped (skip) +# t = print when a test starts (start) +# e = print errorInfo and errorCode when a test encounters an error +# (error) +# +# Results: +# content of tcltest::verbose - this is always the character combination +# (pbste) instead of the list form. +# +# Side effects: +# None. + +proc tcltest::verbose { {level ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::verbose + } + if {[llength $level] > 1} { + set tcltest::verbose $level + } else { + if {[regexp {pass|body|skip|start|error} $level]} { + set tcltest::verbose $level + } else { + set levelList [split $level {}] + set tcltest::verbose [string map {p pass b body s skip t start e + error} $levelList] + } + } + return $tcltest::verbose +} + +# tcltest::isVerbose -- +# +# Returns true if argument is one of the verbosity levels currently being +# used; returns false otherwise. +# +# Arguments: +# level +# +# Results: +# boolean 1 (true) or 0 (false), depending on whether or not the level +# provided is one of the ones stored in tcltest::verbose. +# +# Side effects: +# None. + +proc tcltest::isVerbose {level} { + if {[lsearch -exact [tcltest::verbose] $level] == -1} { + return 0 + } + return 1 +} + + + +# tcltest::match -- +# +# Set or return the match patterns (tcltest::match) that determine which +# tests are run. +# +# Arguments: +# List containing match patterns (glob format) +# +# Results: +# content of tcltest::match +# +# Side effects: +# none + +proc tcltest::match { {matchList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::match + } + set tcltest::match $matchList +} + +# tcltest::skip -- +# +# Set or return the skip patterns (tcltest::skip) that determine which +# tests are skipped. +# +# Arguments: +# List containing skip patterns (glob format) +# +# Results: +# content of tcltest::skip +# +# Side effects: +# None. + +proc tcltest::skip { {skipList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skip + } + set tcltest::skip $skipList +} + +# tcltest::matchFiles -- +# +# set or return the match patterns for file sourcing +# +# Arguments: +# list containing match file list (glob format) +# +# Results: +# content of tcltest::matchFiles +# +# Side effects: +# None. + +proc tcltest::matchFiles { {matchFileList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::matchFiles + } + set tcltest::matchFiles $matchFileList +} + +# tcltest::skipFiles -- +# +# set or return the skip patterns for file sourcing +# +# Arguments: +# list containing the skip file list (glob format) +# +# Results: +# content of tcltest::skipFiles +# +# Side effects: +# None. + +proc tcltest::skipFiles { {skipFileList ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skipFiles + } + set tcltest::skipFiles $skipFileList +} + + +# tcltest::matchDirectories -- +# +# set or return the list of directories for matching (glob pattern list) +# +# Arguments: +# list of glob patterns matching subdirectories of +# tcltest::testsDirectory +# +# Results: +# content of tcltest::matchDirectories +# +# Side effects: +# None. + +proc tcltest::matchDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::matchDirectories + } + set tcltest::matchDirectories $dirlist +} + +# tcltest::skipDirectories -- +# +# set or return the list of directories to skip (glob pattern list) +# +# Arguments: +# list of glob patterns matching directories to skip; these directories +# are subdirectories of tcltest::testsDirectory +# +# Results: +# content of tcltest::skipDirectories +# +# Side effects: +# None. + +proc tcltest::skipDirectories { {dirlist ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::skipDirectories + } + set tcltest::skipDirectories $dirlist +} + +# tcltest::preserveCore -- +# +# set or return the core preservation level. This proc does not do any +# error checking for invalid values. +# +# Arguments: +# core level: +# '0' = don't do anything with core files (default) +# '1' = notify the user if core files are created +# '2' = save any core files produced during testing to +# tcltest::temporaryDirectory +# +# Results: +# content of tcltest::preserveCore +# +# Side effects: +# None. + +proc tcltest::preserveCore { {coreLevel ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::preserveCore + } + set tcltest::preserveCore $coreLevel +} + +# tcltest::outputChannel -- +# +# set or return the output file descriptor based on the supplied file +# name (where tcltest puts all of its output) +# +# Arguments: +# output file descriptor +# +# Results: +# file descriptor corresponding to supplied file name (or currently set +# file descriptor, if no new filename was supplied) - this is the content +# of tcltest::outputChannel +# +# Side effects: +# None. + +proc tcltest::outputChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::outputChannel + } + if {($filename == "stderr") || ($filename == "stdout")} { + set tcltest::outputChannel $filename + } else { + set tcltest::outputChannel [open $filename w] + } + return $tcltest::outputChannel +} + +# tcltest::outputFile -- +# +# set or return the output file name (where tcltest puts all of its +# output); calls tcltest::outputChannel to set the corresponding file +# descriptor +# +# Arguments: +# output file name +# +# Results: +# file name corresponding to supplied file name (or currently set +# file name, if no new filename was supplied) - this is the content +# of tcltest::outputFile +# +# Side effects: +# if the file name supplied is relative, it will be made absolute with +# respect to the predefined temporaryDirectory + +proc tcltest::outputFile { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::outputFile + } + if {($filename != "stderr") && ($filename != "stdout")} { + MakeAbsolutePath filename $tcltest::temporaryDirectory + } + tcltest::outputChannel $filename + set tcltest::outputFile $filename +} + +# tcltest::errorChannel -- +# +# set or return the error file descriptor based on the supplied file name +# (where tcltest sends all its errors) +# +# Arguments: +# error file name +# +# Results: +# file descriptor corresponding to the supplied file name (or currently +# set file descriptor, if no new filename was supplied) - this is the +# content of tcltest::errorChannel +# +# Side effects: +# opens the descriptor in w mode unless the filename is set to stderr or +# stdout + +proc tcltest::errorChannel { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::errorChannel + } + if {($filename == "stderr") || ($filename == "stdout")} { + set tcltest::errorChannel $filename + } else { + set tcltest::errorChannel [open $filename w] + } + return $tcltest::errorChannel +} + +# tcltest::errorFile -- +# +# set or return the error file name; calls tcltest::errorChannel to set +# the corresponding file descriptor +# +# Arguments: +# error file name +# +# Results: +# content of tcltest::errorFile +# +# Side effects: +# if the file name supplied is relative, it will be made absolute with +# respect to the predefined temporaryDirectory + +proc tcltest::errorFile { {filename ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::errorFile + } + if {($filename != "stderr") && ($filename != "stdout")} { + MakeAbsolutePath filename $tcltest::temporaryDirectory + } + set tcltest::errorFile $filename + errorChannel $tcltest::errorFile + return $tcltest::errorFile +} + +# tcltest::debug -- +# +# set or return the debug level for tcltest; this proc does not check for +# invalid values +# +# Arguments: +# debug level: +# '0' = no debug output (default) +# '1' = skipped tests +# '2' = tcltest variables and supplied flags +# '3' = harness operations +# +# Results: +# content of tcltest::debug +# +# Side effects: +# None. + +proc tcltest::debug { {debugLevel ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::debug + } + set tcltest::debug $debugLevel +} + +# tcltest::testConstraint -- +# +# sets a test constraint to a value; to do multiple constraints, call +# this proc multiple times. also returns the value of the named +# constraint if no value was supplied. +# +# Arguments: +# constraint - name of the constraint +# value - new value for constraint (should be boolean) - if not supplied, +# this is a query +# +# Results: +# content of tcltest::testConstraints($constraint) +# +# Side effects: +# appends the constraint name to tcltest::constraintsSpecified + +proc tcltest::testConstraint {constraint {value ""}} { + DebugPuts 3 "entering testConstraint $constraint $value" + if {[llength [info level 0]] == 2} { + return $tcltest::testConstraints($constraint) + } + lappend tcltest::constraintsSpecified $constraint + set tcltest::testConstraints($constraint) $value +} + +# tcltest::constraintsSpecified -- +# +# returns a list of all the constraint names specified using +# testConstraint +# +# Arguments: +# None. +# +# Results: +# list of the constraint names in tcltest::constraintsSpecified +# +# Side effects: +# None. + +proc tcltest::constraintsSpecified {} { + return $tcltest::constraintsSpecified +} + +# tcltest::constraintList -- +# +# returns a list of all the constraint names +# +# Arguments: +# None. +# +# Results: +# list of the constraint names in tcltest::testConstraints +# +# Side effects: +# None. + +proc tcltest::constraintList {} { + return [array names tcltest::testConstraints] +} + +# tcltest::limitConstraints -- +# +# sets the limited constraints to tcltest::limitConstraints +# +# Arguments: +# list of constraint names +# +# Results: +# content of tcltest::limitConstraints +# +# Side effects: +# None. + +proc tcltest::limitConstraints { {constraintList ""} } { + DebugPuts 3 "entering limitConstraints $constraintList" + if {[llength [info level 0]] == 1} { + return $tcltest::limitConstraints + } + set tcltest::limitConstraints $constraintList + foreach elt [tcltest::constraintList] { + if {[lsearch -exact [tcltest::constraintsSpecified] $elt] == -1} { + tcltest::testConstraint $elt 0 + } + } + return $tcltest::limitConstraints +} + +# tcltest::loadScript -- +# +# sets the load script +# +# Arguments: +# script to be set +# +# Results: +# contents of tcltest::loadScript +# +# Side effects: +# None. + +proc tcltest::loadScript { {script ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::loadScript + } + set tcltest::loadScript $script +} + +# tcltest::loadFile -- +# +# set the load file (containing the load script); +# put the content of the load file into loadScript +# +# Arguments: +# script's file name +# +# Results: +# content of tcltest::loadFile +# +# Side effects: +# None. + +proc tcltest::loadFile { {scriptFile ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::loadFile + } + MakeAbsolutePath scriptFile $tcltest::temporaryDirectory + set tmp [open $scriptFile r] + tcltest::loadScript [read $tmp] + close $tmp + set tcltest::loadFile $scriptFile +} + +# tcltest::workingDirectory -- +# +# set workingDirectory to the given path. +# If the path is relative, make it absolute. +# change directory to the stated working directory, if resetting the +# value +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::workingDirectory +# +# Side effects: +# None. + +proc tcltest::workingDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::workingDirectory + } + set tcltest::workingDirectory $dir + MakeAbsolutePath tcltest::workingDirectory + cd $tcltest::workingDirectory + return $tcltest::workingDirectory +} + +# tcltest::temporaryDirectory -- +# +# Set tcltest::temporaryDirectory to the given path. +# If the path is relative, make it absolute. If the file exists but +# is not a dir, then return an error. +# +# If tcltest::temporaryDirectory does not already exist, create it. +# If you cannot create it, then return an error (the file mkdir isn't +# caught and will propagate). +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::temporaryDirectory +# +# Side effects: +# None. + +proc tcltest::temporaryDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::temporaryDirectory + } + set tcltest::temporaryDirectory $dir + + MakeAbsolutePath tcltest::temporaryDirectory + set tmpDirError "bad argument for temporary directory: " + + if {[file exists $tcltest::temporaryDirectory]} { + tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError + } else { + file mkdir $tcltest::temporaryDirectory + } + + normalizePath tcltest::temporaryDirectory +} + +# tcltest::testsDirectory -- +# +# Set tcltest::testsDirectory to the given path. +# If the path is relative, make it absolute. If the file exists but +# is not a dir, then return an error. +# +# If tcltest::testsDirectory does not already exist, return an error. +# +# Arguments: +# directory name +# +# Results: +# content of tcltest::testsDirectory +# +# Side effects: +# None. + +proc tcltest::testsDirectory { {dir ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::testsDirectory + } + + set tcltest::testsDirectory $dir + + MakeAbsolutePath tcltest::testsDirectory + set testDirError "bad argument for tests directory: " + + if {[file exists $tcltest::testsDirectory]} { + tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError + } else { + set msg "$testDirError \"$tcltest::testsDirectory\" does not exist" + error $msg + } + + normalizePath tcltest::testsDirectory +} + +# tcltest::singleProcess -- +# +# sets tcltest::singleProcess to the value provided. +# +# Arguments: +# value for singleProcess: +# 1 = source each test file into the current process +# 0 = run each test file in its own process +# +# Results: +# content of tcltest::singleProcess +# +# Side effects: +# None. + +proc tcltest::singleProcess { {value ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::singleProcess + } + set tcltest::singleProcess $value +} + +# tcltest::interpreter -- +# +# the interpreter name stored in tcltest::tcltest +# +# Arguments: +# executable name +# +# Results: +# content of tcltest::tcltest +# +# Side effects: +# None. + +proc tcltest::interpreter { {interp ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::tcltest + } + set tcltest::tcltest $interp +} + +# tcltest::mainThread -- +# +# sets or returns the thread id stored in tcltest::mainThread +# +# Arguments: +# thread id +# +# Results: +# content of tcltest::mainThread +# +# Side effects: +# None. + +proc tcltest::mainThread { {threadid ""} } { + if {[llength [info level 0]] == 1} { + return $tcltest::mainThread + } + set tcltest::mainThread $threadid } -# ::tcltest::AddToSkippedBecause -- +##################################################################### + +# tcltest::AddToSkippedBecause -- # # Increments the variable used to track how many tests were skipped # because of a particular constraint. @@ -353,52 +1165,61 @@ proc ::tcltest::DebugDo {level script} { # constraint The name of the constraint to be modified # # Results: -# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't +# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't # previously exist - otherwise, it just increments it. +# +# Side effects: +# None. -proc ::tcltest::AddToSkippedBecause { constraint } { +proc tcltest::AddToSkippedBecause { constraint {value 1}} { # add the constraint to the list of constraints that kept tests # from running - if {[info exists ::tcltest::skippedBecause($constraint)]} { - incr ::tcltest::skippedBecause($constraint) + if {[info exists tcltest::skippedBecause($constraint)]} { + incr tcltest::skippedBecause($constraint) $value } else { - set ::tcltest::skippedBecause($constraint) 1 + set tcltest::skippedBecause($constraint) $value } return } -# ::tcltest::PrintError -- +# tcltest::PrintError -- # -# Prints errors to ::tcltest::errorChannel and then flushes that +# Prints errors to tcltest::errorChannel and then flushes that # channel, making sure that all messages are < 80 characters per line. # # Arguments: # errorMsg String containing the error to be printed # +# +# Results: +# None. +# +# Side effects: +# None. -proc ::tcltest::PrintError {errorMsg} { +proc tcltest::PrintError {errorMsg} { set InitialMessage "Error: " set InitialMsgLen [string length $InitialMessage] - puts -nonewline $::tcltest::errorChannel $InitialMessage + puts -nonewline [errorChannel] $InitialMessage # Keep track of where the end of the string is. set endingIndex [string length $errorMsg] if {$endingIndex < 80} { - puts $::tcltest::errorChannel $errorMsg + puts [errorChannel] $errorMsg } else { # Print up to 80 characters on the first line, including the # InitialMessage. set beginningIndex [string last " " [string range $errorMsg 0 \ [expr {80 - $InitialMsgLen}]]] - puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] + puts [errorChannel] [string range $errorMsg 0 $beginningIndex] while {$beginningIndex != "end"} { - puts -nonewline $::tcltest::errorChannel \ + puts -nonewline [errorChannel] \ [string repeat " " $InitialMsgLen] if {[expr {$endingIndex - $beginningIndex}] < 72} { - puts $::tcltest::errorChannel [string trim \ + puts [errorChannel] [string trim \ [string range $errorMsg $beginningIndex end]] set beginningIndex end } else { @@ -409,25 +1230,52 @@ proc ::tcltest::PrintError {errorMsg} { || ($newEndingIndex <= $beginningIndex)} { set newEndingIndex end } - puts $::tcltest::errorChannel [string trim \ + puts [errorChannel] [string trim \ [string range $errorMsg \ - $beginningIndex $newEndingIndex]] + $beginningIndex $newEndingIndex]] set beginningIndex $newEndingIndex } } } - flush $::tcltest::errorChannel + flush [errorChannel] return } -if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { - proc ::tcltest::initConstraintsHook {} {} +if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { + proc tcltest::initConstraintsHook {} {} +} + +# tcltest::safeFetch -- +# +# The following trace procedure makes it so that we can safely refer to +# non-existent members of the tcltest::testConstraints array without +# causing an error. Instead, reading a non-existent member will return +# 0. This is necessary because tests are allowed to use constraint "X" +# without ensuring that tcltest::testConstraints("X") is defined. +# +# Arguments: +# n1 - name of the array (tcltest::testConstraints) +# n2 - array key value (constraint name) +# op - operation performed on tcltest::testConstraints (generally r) +# +# Results: +# none +# +# Side effects: +# sets tcltest::testConstraints($n2) to 0 if it's referenced but never +# before used + +proc tcltest::safeFetch {n1 n2 op} { + DebugPuts 3 "entering safeFetch $n1 $n2 $op" + if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { + tcltest::testConstraint $n2 0 + } } -# ::tcltest::initConstraints -- +# tcltest::initConstraints -- # -# Check Constraintsuration information that will determine which tests -# to run. To do this, create an array ::tcltest::testConstraints. Each +# Check constraint information that will determine which tests +# to run. To do this, create an array tcltest::testConstraints. Each # element has a 0 or 1 value. If the element is "true" then tests # with that constraint will be run, otherwise tests with that constraint # will be skipped. See the tcltest man page for the list of built-in @@ -437,101 +1285,110 @@ if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} { # none # # Results: -# The ::tcltest::testConstraints array is reset to have an index for +# The tcltest::testConstraints array is reset to have an index for # each built-in test constraint. +# +# Side Effects: +# None. +# -proc ::tcltest::initConstraints {} { +proc tcltest::initConstraints {} { global tcl_platform tcl_interactive tk_version - # The following trace procedure makes it so that we can safely refer to - # non-existent members of the ::tcltest::testConstraints array without - # causing an error. Instead, reading a non-existent member will return 0. - # This is necessary because tests are allowed to use constraint "X" without - # ensuring that ::tcltest::testConstraints("X") is defined. + # Safely refer to non-existent members of the tcltest::testConstraints + # array without causing an error. + trace variable tcltest::testConstraints r tcltest::safeFetch - trace variable ::tcltest::testConstraints r ::tcltest::safeFetch + tcltest::initConstraintsHook - proc ::tcltest::safeFetch {n1 n2 op} { - if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} { - set ::tcltest::testConstraints($n2) 0 - } - } + tcltest::testConstraint singleTestInterp [singleProcess] - ::tcltest::initConstraintsHook + # All the 'pc' constraints are here for backward compatibility and are not + # documented. They have been replaced with equivalent 'win' constraints. - set ::tcltest::testConstraints(unixOnly) \ + tcltest::testConstraint unixOnly \ [string equal $tcl_platform(platform) "unix"] - set ::tcltest::testConstraints(macOnly) \ + tcltest::testConstraint macOnly \ [string equal $tcl_platform(platform) "macintosh"] - set ::tcltest::testConstraints(pcOnly) \ + tcltest::testConstraint pcOnly \ + [string equal $tcl_platform(platform) "windows"] + tcltest::testConstraint winOnly \ [string equal $tcl_platform(platform) "windows"] - set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly) - set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly) - set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly) - - set ::tcltest::testConstraints(unixOrPc) \ - [expr {$::tcltest::testConstraints(unix) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrPc) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macOrUnix) \ - [expr {$::tcltest::testConstraints(mac) \ - || $::tcltest::testConstraints(unix)}] - - set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \ - "Windows NT"] - set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \ - "Windows 95"] - set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \ - "Windows 98"] + tcltest::testConstraint unix [tcltest::testConstraint unixOnly] + tcltest::testConstraint mac [tcltest::testConstraint macOnly] + tcltest::testConstraint pc [tcltest::testConstraint pcOnly] + tcltest::testConstraint win [tcltest::testConstraint winOnly] + + tcltest::testConstraint unixOrPc \ + [expr {[tcltest::testConstraint unix] \ + || [tcltest::testConstraint pc]}] + tcltest::testConstraint macOrPc \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint pc]}] + tcltest::testConstraint unixOrWin \ + [expr {[tcltest::testConstraint unix] \ + || [tcltest::testConstraint win]}] + tcltest::testConstraint macOrWin \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint win]}] + tcltest::testConstraint macOrUnix \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint unix]}] + + tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"] + tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"] + tcltest::testConstraint 98 [string equal $tcl_platform(os) "Windows 98"] # The following Constraints switches are used to mark tests that should # work, but have been temporarily disabled on certain platforms because # they don't and we haven't gotten around to fixing the underlying # problem. - set ::tcltest::testConstraints(tempNotPc) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(tempNotMac) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(tempNotUnix) \ - [expr {!$::tcltest::testConstraints(unix)}] + tcltest::testConstraint tempNotPc \ + [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint tempNotWin \ + [expr {![tcltest::testConstraint win]}] + tcltest::testConstraint tempNotMac \ + [expr {![tcltest::testConstraint mac]}] + tcltest::testConstraint tempNotUnix \ + [expr {![tcltest::testConstraint unix]}] # The following Constraints switches are used to mark tests that crash on # certain platforms, so that they can be reactivated again when the # underlying problem is fixed. - set ::tcltest::testConstraints(pcCrash) \ - [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(macCrash) \ - [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(unixCrash) \ - [expr {!$::tcltest::testConstraints(unix)}] + tcltest::testConstraint pcCrash \ + [expr {![tcltest::testConstraint pc]}] + tcltest::testConstraint winCrash \ + [expr {![tcltest::testConstraint win]}] + tcltest::testConstraint macCrash \ + [expr {![tcltest::testConstraint mac]}] + tcltest::testConstraint unixCrash \ + [expr {![tcltest::testConstraint unix]}] # Skip empty tests - set ::tcltest::testConstraints(emptyTest) 0 + tcltest::testConstraint emptyTest 0 # By default, tests that expose known bugs are skipped. - set ::tcltest::testConstraints(knownBug) 0 + tcltest::testConstraint knownBug 0 # By default, non-portable tests are skipped. - set ::tcltest::testConstraints(nonPortable) 0 + tcltest::testConstraint nonPortable 0 # Some tests require user interaction. - set ::tcltest::testConstraints(userInteraction) 0 + tcltest::testConstraint userInteraction 0 # Some tests must be skipped if the interpreter is not in interactive mode if {[info exists tcl_interactive]} { - set ::tcltest::testConstraints(interactive) $::tcl_interactive + tcltest::testConstraint interactive $::tcl_interactive } else { - set ::tcltest::testConstraints(interactive) 0 + tcltest::testConstraint interactive 0 } # Some tests can only be run if the installation came from a CD image @@ -539,8 +1396,8 @@ proc ::tcltest::initConstraints {} { # Some tests must be skipped if you are running as root on Unix. # Other tests can only be run if you are running as root on Unix. - set ::tcltest::testConstraints(root) 0 - set ::tcltest::testConstraints(notRoot) 1 + tcltest::testConstraint root 0 + tcltest::testConstraint notRoot 1 set user {} if {[string equal $tcl_platform(platform) "unix"]} { catch {set user [exec whoami]} @@ -548,21 +1405,21 @@ proc ::tcltest::initConstraints {} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} } if {([string equal $user "root"]) || ([string equal $user ""])} { - set ::tcltest::testConstraints(root) 1 - set ::tcltest::testConstraints(notRoot) 0 + tcltest::testConstraint root 1 + tcltest::testConstraint notRoot 0 } } # Set nonBlockFiles constraint: 1 means this platform supports - # setting files into nonblocking mode. + # ting files into nonblocking mode. if {[catch {set f [open defs r]}]} { - set ::tcltest::testConstraints(nonBlockFiles) 1 + tcltest::testConstraint nonBlockFiles 1 } else { if {[catch {fconfigure $f -blocking off}] == 0} { - set ::tcltest::testConstraints(nonBlockFiles) 1 + tcltest::testConstraint nonBlockFiles 1 } else { - set ::tcltest::testConstraints(nonBlockFiles) 0 + tcltest::testConstraint nonBlockFiles 0 } close $f } @@ -576,75 +1433,75 @@ proc ::tcltest::initConstraints {} { if {[string equal $tcl_platform(platform) "unix"]} { if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - set ::tcltest::testConstraints(asyncPipeClose) 0 + tcltest::testConstraint asyncPipeClose 0 } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 + tcltest::testConstraint asyncPipeClose 1 } } else { - set ::tcltest::testConstraints(asyncPipeClose) 1 + tcltest::testConstraint asyncPipeClose 1 } # Test to see if we have a broken version of sprintf with respect # to the "e" format of floating-point numbers. - set ::tcltest::testConstraints(eformat) 1 + tcltest::testConstraint eformat 1 if {![string equal "[format %g 5e-5]" "5e-05"]} { - set ::tcltest::testConstraints(eformat) 0 + tcltest::testConstraint eformat 0 } # Test to see if execed commands such as cat, echo, rm and so forth are # present on this machine. - set ::tcltest::testConstraints(unixExecs) 1 + tcltest::testConstraint unixExecs 1 if {[string equal $tcl_platform(platform) "macintosh"]} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([string equal $tcl_platform(platform) "windows"])} { if {[catch {exec cat defs}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec sh -c echo hello}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec wc defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {$::tcltest::testConstraints(unixExecs) == 1} { + if {[tcltest::testConstraint unixExecs] == 1} { exec echo hello > removeMe if {[catch {exec rm removeMe}] == 1} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec sleep 1}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec fgrep unixExecs defs}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec ps}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec echo abc > removeMe}] == 0) && \ ([catch {exec chmod 644 removeMe}] == 1) && \ ([catch {exec rm removeMe}] == 0)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } else { catch {exec rm -f removeMe} } - if {($::tcltest::testConstraints(unixExecs) == 1) && \ + if {([tcltest::testConstraint unixExecs] == 1) && \ ([catch {exec mkdir removeMe}] == 1)} { - set ::tcltest::testConstraints(unixExecs) 0 + tcltest::testConstraint unixExecs 0 } else { catch {exec rm -r removeMe} } @@ -653,14 +1510,14 @@ proc ::tcltest::initConstraints {} { # Locate tcltest executable if {![info exists tk_version]} { - set tcltest [info nameofexecutable] + set tcltest::tcltest [info nameofexecutable] - if {$tcltest == "{}"} { - set tcltest {} + if {$tcltest::tcltest == "{}"} { + set tcltest::tcltest {} } } - set ::tcltest::testConstraints(stdio) 0 + tcltest::testConstraint stdio 0 catch { catch {file delete -force tmp} set f [open tmp w] @@ -672,7 +1529,7 @@ proc ::tcltest::initConstraints {} { set f [open "|[list $tcltest tmp]" r] close $f - set ::tcltest::testConstraints(stdio) 1 + tcltest::testConstraint stdio 1 } catch {file delete -force tmp} @@ -681,50 +1538,62 @@ proc ::tcltest::initConstraints {} { # system. catch {socket} msg - set ::tcltest::testConstraints(socket) \ + tcltest::testConstraint socket \ [expr {$msg != "sockets are not available on this system"}] # Check for internationalization if {[info commands testlocale] == ""} { # No testlocale command, no tests... - set ::tcltest::testConstraints(hasIsoLocale) 0 + tcltest::testConstraint hasIsoLocale 0 } else { - set ::tcltest::testConstraints(hasIsoLocale) \ - [string length [::tcltest::set_iso8859_1_locale]] - ::tcltest::restore_locale + tcltest::testConstraint hasIsoLocale \ + [string length [tcltest::set_iso8859_1_locale]] + tcltest::restore_locale } } -# ::tcltest::PrintUsageInfoHook +##################################################################### + +# Handle command line arguments (from argv) and default arg settings +# (in TCLTEST_OPTIONS). + +# tcltest::PrintUsageInfoHook # # Hook used for customization of display of usage information. # -if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} { - proc ::tcltest::PrintUsageInfoHook {} {} +if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} { + proc tcltest::PrintUsageInfoHook {} {} } -# ::tcltest::PrintUsageInfo +# tcltest::PrintUsageInfo # # Prints out the usage information for package tcltest. This can be -# customized with the redefinition of ::tcltest::PrintUsageInfoHook. +# customized with the redefinition of tcltest::PrintUsageInfoHook. # # Arguments: # none # +# Results: +# none +# +# Side Effects: +# none -proc ::tcltest::PrintUsageInfo {} { +proc tcltest::PrintUsageInfo {} { puts [format "Usage: [file tail [info nameofexecutable]] \ script ?-help? ?flag value? ... \n\ Available flags (and valid input values) are: \n\ -help \t Display this usage information. \n\ -verbose level \t Takes any combination of the values \n\ - \t 'p', 's' and 'b'. Test suite will \n\ + \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\ \t display all passed tests if 'p' is \n\ \t specified, all skipped tests if 's' \n\ - \t is specified, and the bodies of \n\ - \t failed tests if 'b' is specified. \n\ + \t is specified, the bodies of \n\ + \t failed tests if 'b' is specified, \n\ + \t and when tests start if 't' is specified. \n\ + \t ErrorInfo is displayed if 'e' is specified. \n\ \t The default value is 'b'. \n\ -constraints list\t Do not skip the listed constraints\n\ -limitconstraints bool\t Only run tests with the constraints\n\ @@ -740,17 +1609,21 @@ proc ::tcltest::PrintUsageInfo {} { \t match the glob pattern given. \n\ -notfile pattern\t Skip all test files that match the \n\ \t glob pattern given. \n\ + -relateddir pattern\t Run tests in directories that match \n\ + \t the glob pattern given. \n\ + -asidefromdir pattern\t Skip tests in directories that match \n\ + \t the glob pattern given.\n\ -preservecore level \t If 2, save any core files produced \n\ \t during testing in the directory \n\ \t specified by -tmpdir. If 1, notify the\n\ \t user if core files are created. The default \n\ - \t is $::tcltest::preserveCore. \n\ + \t is $tcltest::preserveCore. \n\ -tmpdir directory\t Save temporary files in the specified\n\ \t directory. The default value is \n\ - \t $::tcltest::temporaryDirectory. \n\ + \t $tcltest::temporaryDirectory. \n\ -testdir directories\t Search tests in the specified\n\ \t directories. The default value is \n\ - \t $::tcltest::testsDirectory. \n\ + \t $tcltest::testsDirectory. \n\ -outfile file \t Send output from test runs to the \n\ \t specified file. The default is \n\ \t stdout. \n\ @@ -762,207 +1635,98 @@ proc ::tcltest::PrintUsageInfo {} { -load script \t Specifies the script to load the tested \n\ \t commands. \n\ -debug level \t Internal debug flag."] - ::tcltest::PrintUsageInfoHook + tcltest::PrintUsageInfoHook return } -# ::tcltest::CheckDirectory -- -# -# This procedure checks whether the specified path is a readable -# and/or writable directory. If one of the conditions is not -# satisfied an error is printed and the application aborted. The -# procedure assumes that the caller already checked the existence -# of the path. -# -# Arguments -# rw Information what attributes to check. Allowed values: -# r, w, rw, wr. If 'r' is part of the value the directory -# must be readable. 'w' associates to 'writable'. -# dir The directory to check. -# errMsg The string to prepend to the actual error message before -# printing it. -# -# Results -# none -# - -proc ::tcltest::CheckDirectory {rw dir errMsg} { - # Allowed values for 'rw': r, w, rw, wr - - if {![file isdir $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not a directory" - exit 1 - } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not writeable" - exit 1 - } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - ::tcltest::PrintError "$errMsg \"$dir\" is not readable" - exit 1 - } -} - -# ::tcltest::normalizePath -- -# -# This procedure resolves any symlinks in the path thus creating a -# path without internal redirection. It assumes that the incoming -# path is absolute. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::normalizePath {pathVar} { - upvar $pathVar path - - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd -} - -# ::tcltest::MakeAbsolutePath -- -# -# This procedure checks whether the incoming path is absolute or not. -# Makes it absolute if it was not. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# prefix is optional, contains the path to use to make the other an -# absolute one. The current working directory is used if it was -# not specified. -# -# Results -# The path is modified in place. -# - -proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} { - upvar $pathVar path - - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { - set prefix [pwd] - } - - set path [file join $prefix $path] - } -} - -# ::tcltest::processCmdLineArgsFlagsHook -- +# tcltest::processCmdLineArgsFlagsHook -- # # This hook is used to add to the list of command line arguments that are -# processed by ::tcltest::processCmdLineArgs. +# processed by tcltest::ProcessFlags. It is called at the beginning of +# ProcessFlags. # -if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { - proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} +if {[namespace inscope tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { + proc tcltest::processCmdLineArgsAddFlagsHook {} {} } -# ::tcltest::processCmdLineArgsHook -- +# tcltest::processCmdLineArgsHook -- # # This hook is used to actually process the flags added by -# ::tcltest::processCmdLineArgsAddFlagsHook. +# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of +# ProcessFlags. # # Arguments: # flags The flags that have been pulled out of argv # -if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} { - proc ::tcltest::processCmdLineArgsHook {flag} {} +if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} { + proc tcltest::processCmdLineArgsHook {flag} {} } -# ::tcltest::processCmdLineArgs -- +# tcltest::ProcessFlags -- # -# Use command line args to set the verbose, skip, and -# match, outputChannel, errorChannel, debug, and temporaryDirectory -# variables. -# -# This procedure must be run after constraints are initialized, because -# some constraints can be overridden. +# process command line arguments supplied in the flagArray - this is +# called by processCmdLineArgs +# modifies tcltest variables according to the content of the flagArray. # # Arguments: -# none +# flagArray - array containing name/value pairs of flags # # Results: -# Sets the above-named variables in the tcltest namespace. - -proc ::tcltest::processCmdLineArgs {} { - global argv - - # The "argv" var doesn't exist in some cases, so use {}. - - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv - } - - # Allow for 1-char abbreviations, where applicable (e.g., -match == -m). - # Note that -verbose cannot be abbreviated to -v in wish because it - # conflicts with the wish option -visual. +# sets tcltest variables according to their values as defined by +# flagArray +# +# Side effects: +# None. +proc tcltest::ProcessFlags {flagArray} { # Process -help first - if {([lsearch -exact $flagArray {-help}] != -1) || \ - ([lsearch -exact $flagArray {-h}] != -1)} { - ::tcltest::PrintUsageInfo - exit 1 - } - - if {[catch {array set flag $flagArray}]} { - ::tcltest::PrintError "odd number of arguments specified on command line: \ - $argv" - ::tcltest::PrintUsageInfo + if {[lsearch -exact $flagArray {-help}] != -1} { + tcltest::PrintUsageInfo exit 1 } + + catch {array set flag $flagArray} # -help is not listed since it has already been processed lappend defaultFlags -verbose -match -skip -constraints \ -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints -args -testdir \ - -load -loadfile + -preservecore -limitconstraints -testdir \ + -load -loadfile -asidefromdir \ + -relateddir -singleproc set defaultFlags [concat $defaultFlags \ - [ ::tcltest::processCmdLineArgsAddFlagsHook ]] - - foreach arg $defaultFlags { - set abbrev [string range $arg 0 1] - if {([info exists flag($abbrev)]) && \ - ([lsearch -exact $flagArray $arg] < [lsearch -exact \ - $flagArray $abbrev])} { - set flag($arg) $flag($abbrev) - } - } - - # Set ::tcltest::parameters to the arg of the -args flag, if given - if {[info exists flag(-args)]} { - set ::tcltest::parameters $flag(-args) - } - - # Set ::tcltest::verbose to the arg of the -verbose flag, if given + [tcltest::processCmdLineArgsAddFlagsHook ]] + # Set tcltest::verbose to the arg of the -verbose flag, if given if {[info exists flag(-verbose)]} { - set ::tcltest::verbose $flag(-verbose) + tcltest::verbose $flag(-verbose) } - # Set ::tcltest::match to the arg of the -match flag, if given. - + # Set tcltest::match to the arg of the -match flag, if given. if {[info exists flag(-match)]} { - set ::tcltest::match $flag(-match) + tcltest::match $flag(-match) } - # Set ::tcltest::skip to the arg of the -skip flag, if given - + # Set tcltest::skip to the arg of the -skip flag, if given if {[info exists flag(-skip)]} { - set ::tcltest::skip $flag(-skip) + tcltest::skip $flag(-skip) } # Handle the -file and -notfile flags if {[info exists flag(-file)]} { - set ::tcltest::matchFiles $flag(-file) + tcltest::matchFiles $flag(-file) } if {[info exists flag(-notfile)]} { - set ::tcltest::skipFiles $flag(-notfile) + tcltest::skipFiles $flag(-notfile) + } + + # Handle -relateddir and -asidefromdir flags + if {[info exists flag(-relateddir)]} { + tcltest::matchDirectories $flag(-relateddir) + } + if {[info exists flag(-asidefromdir)]} { + tcltest::skipDirectories $flag(-asidefromdir) } # Use the -constraints flag, if given, to turn on constraints that are @@ -971,7 +1735,7 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-constraints)]} { foreach elt $flag(-constraints) { - set ::tcltest::testConstraints($elt) 1 + tcltest::testConstraint $elt 1 } } @@ -980,87 +1744,35 @@ proc ::tcltest::processCmdLineArgs {} { # the -constraints flag was not specified, print out an error and exit. if {[info exists flag(-limitconstraints)]} { if {![info exists flag(-constraints)]} { - puts "You can only use the -limitconstraints flag with \ - -constraints" - exit 1 - } - set ::tcltest::limitConstraints $flag(-limitconstraints) - foreach elt [array names ::tcltest::testConstraints] { - if {[lsearch -exact $flag(-constraints) $elt] == -1} { - set ::tcltest::testConstraints($elt) 0 - } + set msg "-limitconstraints flag can only be used with -constraints" + error $msg } + tcltest::limitConstraints $flag(-limitconstraints) } - # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if + # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist, create it. - # If you cannot create it, then return an error. - set tmpDirError "" if {[info exists flag(-tmpdir)]} { - set ::tcltest::temporaryDirectory $flag(-tmpdir) - - MakeAbsolutePath ::tcltest::temporaryDirectory - set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: " - } - if {[file exists $::tcltest::temporaryDirectory]} { - ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError - } else { - file mkdir $::tcltest::temporaryDirectory + tcltest::temporaryDirectory $flag(-tmpdir) } - normalizePath ::tcltest::temporaryDirectory - - # Set the ::tcltest::testsDirectory to the arg of -testdir, if + # Set the tcltest::testsDirectory to the arg of -testdir, if # given. - # - # If the path is relative, make it absolute. If the file exists but - # is not a dir, then return an error. - # - # If ::tcltest::temporaryDirectory does not already exist return an error. - set testDirError "" if {[info exists flag(-testdir)]} { - set ::tcltest::testsDirectory $flag(-testdir) - - MakeAbsolutePath ::tcltest::testsDirectory - set testDirError "bad argument \"$flag(-testdir)\" to -testdir: " - } - if {[file exists $::tcltest::testsDirectory]} { - ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError - } else { - ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \ - does not exist" - exit 1 - } - - normalizePath ::tcltest::testsDirectory - - # Save the names of files that already exist in - # the output directory. - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend ::tcltest::filesExisted [file tail $file] + tcltest::testsDirectory $flag(-testdir) } # If an alternate error or output files are specified, change the # default channels. if {[info exists flag(-outfile)]} { - set tmp $flag(-outfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::outputChannel [open $tmp w] + tcltest::outputFile $flag(-outfile) } if {[info exists flag(-errfile)]} { - set tmp $flag(-errfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set ::tcltest::errorChannel [open $tmp w] + tcltest::errorFile $flag(-errfile) } # If a load script was specified, either directly or through @@ -1068,294 +1780,647 @@ proc ::tcltest::processCmdLineArgs {} { if {[info exists flag(-load)] && \ ([lsearch -exact $flagArray -load] > \ - [lsearch -exact $flagArray -loadfile])} { - set ::tcltest::loadScript $flag(-load) + [lsearch -exact $flagArray -loadfile])} { + tcltest::loadScript $flag(-load) } if {[info exists flag(-loadfile)] && \ ([lsearch -exact $flagArray -loadfile] > \ - [lsearch -exact $flagArray -load]) } { - set tmp $flag(-loadfile) - MakeAbsolutePath tmp $::tcltest::temporaryDirectory - set tmp [open $tmp r] - set ::tcltest::loadScript [read $tmp] - close $tmp + [lsearch -exact $flagArray -load]) } { + tcltest::loadFile $flag(-loadfile) } # If the user specifies debug testing, print out extra information during # the run. if {[info exists flag(-debug)]} { - set ::tcltest::debug $flag(-debug) + tcltest::debug $flag(-debug) } # Handle -preservecore if {[info exists flag(-preservecore)]} { - set ::tcltest::preserveCore $flag(-preservecore) + tcltest::preserveCore $flag(-preservecore) + } + + # Handle -singleproc flag + if {[info exists flag(-singleproc)]} { + tcltest::singleProcess $flag(-singleproc) } # Call the hook - ::tcltest::processCmdLineArgsHook [array get flag] + tcltest::processCmdLineArgsHook [array get flag] + return +} - # Spit out everything you know if we're at a debug level 2 or greater +# tcltest::processCmdLineArgs -- +# +# Use command line args to set tcltest namespace variables. +# +# This procedure must be run after constraints are initialized, because +# some constraints can be overridden. +# +# Set variables based on the contents of the environment variable +# TCLTEST_OPTIONS first, then override with command-line options, if +# specified. +# +# Arguments: +# none +# +# Results: +# Sets the above-named variables in the tcltest namespace. +# +# Side Effects: +# None. +# + +proc tcltest::processCmdLineArgs {} { + global argv + + # If the TCLTEST_OPTIONS environment variable exists, parse it first, then + # the argv list. The command line argument parsing will be a two-pass + # affair from now on, so that TCLTEST_OPTIONS contain the default options. + # These can be overridden by the command line flags. + + if {[info exists ::env(TCLTEST_OPTIONS)]} { + tcltest::ProcessFlags $::env(TCLTEST_OPTIONS) + } + + # The "argv" var doesn't exist in some cases, so use {}. + if {(![info exists argv]) || ([llength $argv] < 1)} { + set flagArray {} + } else { + set flagArray $argv + } + + tcltest::ProcessFlags $flagArray - DebugPuts 2 "Flags passed into tcltest:" - DebugPArray 2 flag - DebugPuts 2 "::tcltest::debug = $::tcltest::debug" - DebugPuts 2 "::tcltest::testsDirectory = $::tcltest::testsDirectory" - DebugPuts 2 "::tcltest::workingDirectory = $::tcltest::workingDirectory" - DebugPuts 2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory" - DebugPuts 2 "::tcltest::outputChannel = $::tcltest::outputChannel" - DebugPuts 2 "::tcltest::errorChannel = $::tcltest::errorChannel" - DebugPuts 2 "Original environment (::tcltest::originalEnv):" - DebugPArray 2 ::tcltest::originalEnv + # Spit out everything you know if we're at a debug level 2 or greater + DebugPuts 2 "Flags passed into tcltest:" + if {[info exists ::env(TCLTEST_OPTIONS)]} { + DebugPuts 2 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" + } + if {[info exists argv]} { + DebugPuts 2 " argv: $argv" + } + DebugPuts 2 "tcltest::debug = [tcltest::debug]" + DebugPuts 2 "tcltest::testsDirectory = [tcltest::testsDirectory]" + DebugPuts 2 "tcltest::workingDirectory = [tcltest::workingDirectory]" + DebugPuts 2 "tcltest::temporaryDirectory = [tcltest::temporaryDirectory]" + DebugPuts 2 "tcltest::outputChannel = [outputChannel]" + DebugPuts 2 "tcltest::errorChannel = [errorChannel]" + DebugPuts 2 "Original environment (tcltest::originalEnv):" + DebugPArray 2 tcltest::originalEnv DebugPuts 2 "Constraints:" - DebugPArray 2 ::tcltest::testConstraints + DebugPArray 2 tcltest::testConstraints + return } -# ::tcltest::loadTestedCommands -- +##################################################################### + +# Code to run the tests goes here. + +# tcltest::testPuts -- # -# Uses the specified script to load the commands to test. Allowed to -# be empty, as the tested commands could have been compiled into the -# interpreter. +# Used to redefine puts in test environment. +# Stores whatever goes out on stdout in tcltest::outData and stderr in +# tcltest::errData before sending it on to the regular puts. # -# Arguments -# none +# Arguments: +# same as standard puts # -# Results -# none +# Results: +# none +# +# Side effects: +# Intercepts puts; data that would otherwise go to stdout, stderr, or +# file channels specified in tcltest::outputChannel and errorChannel does +# not get sent to the normal puts function. + +proc tcltest::testPuts {args} { + set len [llength $args] + if {$len == 1} { + # Only the string to be printed is specified + append tcltest::outData "[lindex $args 0]\n" + return +# return [tcltest::normalPuts [lindex $args 0]] + } elseif {$len == 2} { + # Either -nonewline or channelId has been specified + if {[regexp {^-nonewline} [lindex $args 0]]} { + append tcltest::outData "[lindex $args end]" + return +# return [tcltest::normalPuts -nonewline [lindex $args end]] + } else { + set channel [lindex $args 0] + } + } elseif {$len == 3} { + if {[lindex $args 0] == "-nonewline"} { + # Both -nonewline and channelId are specified, unless it's an + # error. -nonewline is supposed to be argv[0]. + set channel [lindex $args 1] + } + } -proc ::tcltest::loadTestedCommands {} { - if {$::tcltest::loadScript == {}} { + if {[info exists channel]} { + if {($channel == [outputChannel]) || ($channel == "stdout")} { + append tcltest::outData "[lindex $args end]\n" + } elseif {($channel == [errorChannel]) || ($channel == "stderr")} { + append tcltest::errData "[lindex $args end]\n" + } return + # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]] } - - uplevel #0 $::tcltest::loadScript + + # If we haven't returned by now, we don't know how to handle the input. + # Let puts handle it. + return [eval tcltest::normalPuts $args] } -# ::tcltest::cleanupTests -- +# tcltest::testEval -- # -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. +# Evaluate the script in the test environment. If ignoreOutput is +# false, store data sent to stderr and stdout in tcltest::outData and +# tcltest::errData. Otherwise, ignore this output altogether. # -# Print the names of the files created without the makeFile command -# since the tests were invoked. +# Arguments: +# script Script to evaluate +# ?ignoreOutput? Indicates whether or not to ignore output sent to +# stdout & stderr # -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). - -proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { - - set testFileName [file tail [info script]] +# Results: +# result from running the script +# +# Side effects: +# Empties the contents of tcltest::outData and tcltest::errData before +# running a test if ignoreOutput is set to 0. - # Call the cleanup hook - ::tcltest::cleanupTestsHook +proc tcltest::testEval {script {ignoreOutput 1}} { + DebugPuts 3 "testEval called" + if {!$ignoreOutput} { + set tcltest::outData {} + set tcltest::errData {} + uplevel rename ::puts tcltest::normalPuts + uplevel rename tcltest::testPuts ::puts + } + set result [uplevel $script] + if {!$ignoreOutput} { + uplevel rename ::puts tcltest::testPuts + uplevel rename tcltest::normalPuts ::puts + } + return $result +} - # Remove files and directories created by the :tcltest::makeFile and - # ::tcltest::makeDirectory procedures. - # Record the names of files in ::tcltest::workingDirectory that were not - # pre-existing, and associate them with the test file that created them. +# compareStrings -- +# +# compares the expected answer to the actual answer, depending on the +# mode provided. Mode determines whether a regexp, exact, or glob +# comparison is done. +# +# Arguments: +# actual - string containing the actual result +# expected - pattern to be matched against +# mode - type of comparison to be done +# +# Results: +# result of the match +# +# Side effects: +# None. - if {!$calledFromAllFile} { - foreach file $::tcltest::filesMade { - if {[file exists $file]} { - catch {file delete -force $file} - } +proc tcltest::compareStrings {actual expected mode} { + switch -- $mode { + exact { + set retval [string equal $actual $expected] } - set currentFiles {} - foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { - lappend currentFiles [file tail $file] + glob { + set retval [string match $expected $actual] } - set newFiles {} - foreach file $currentFiles { - if {[lsearch -exact $::tcltest::filesExisted $file] == -1} { - lappend newFiles $file - } - } - set ::tcltest::filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set ::tcltest::createdNewFiles($testFileName) $newFiles + regexp { + set retval [regexp -- $expected $actual] } } + return $retval +} - if {$calledFromAllFile || $::tcltest::testSingleFile} { - # print stats +# +# tcltest::substArguments list +# +# This helper function takes in a list of words, then perform a +# substitution on the list as though each word in the list is a +# separate argument to the Tcl function. For example, if this +# function is invoked as: +# +# substArguments {$a {$a}} +# +# Then it is as though the function is invoked as: +# +# substArguments $a {$a} +# +# This code is adapted from Paul Duffin's function "SplitIntoWords". +# The original function can be found on: +# +# http://purl.org/thecliff/tcl/wiki/858.html +# +# Results: +# a list containing the result of the substitution +# +# Exceptions: +# An error may occur if the list containing unbalanced quote or +# unknown variable. +# +# Side Effects: +# None. +# + +proc tcltest::substArguments {argList} { + + # We need to split the argList up into tokens but cannot use + # list operations as they throw away some significant + # quoting, and [split] ignores braces as it should. + # Therefore what we do is gradually build up a string out of + # whitespace seperated strings. We cannot use [split] to + # split the argList into whitespace seperated strings as it + # throws away the whitespace which maybe important so we + # have to do it all by hand. + + set result {} + set token "" + + while {[string length $argList]} { + # Look for the next word containing a quote: " { } + if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ + $argList all]} { + # Get the text leading up to this word, but not + # including this word, from the argList. + set text [string range $argList 0 \ + [expr {[lindex $all 0] - 1}]] + # Get the word with the quote + set word [string range $argList \ + [lindex $all 0] [lindex $all 1]] + + # Remove all text up to and including the word from the + # argList. + set argList [string range $argList \ + [expr {[lindex $all 1] + 1}] end] + } else { + # Take everything up to the end of the argList. + set text $argList + set word {} + set argList {} + } + + if {$token != {}} { + # If we saw a word with quote before, then there is a + # multi-word token starting with that word. In this case, + # add the text and the current word to this token. + append token $text $word + } else { + # Add the text to the result. There is no need to parse + # the text because it couldn't be a part of any multi-word + # token. Then start a new multi-word token with the word + # because we need to pass this token to the Tcl parser to + # check for balancing quotes + append result $text + set token $word + } + + if { [catch {llength $token} length] == 0 && $length == 1} { + # The token is a valid list so add it to the result. + # lappend result [string trim $token] + append result \{$token\} + set token {} + } + } - puts -nonewline $::tcltest::outputChannel "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline $::tcltest::outputChannel \ - "\t$index\t$::tcltest::numTests($index)" - } - puts $::tcltest::outputChannel "" + # If the last token has not been added to the list then there + # is a problem. + if { [string length $token] } { + error "incomplete token \"$token\"" + } - # print number test files sourced - # print names of files that ran tests which failed + return $result +} - if {$calledFromAllFile} { - puts $::tcltest::outputChannel \ - "Sourced $::tcltest::numTestFiles Test Files." - set ::tcltest::numTestFiles 0 - if {[llength $::tcltest::failFiles] > 0} { - puts $::tcltest::outputChannel \ - "Files with failing tests: $::tcltest::failFiles" - set ::tcltest::failFiles {} - } - } - # if any tests were skipped, print the constraints that kept them - # from running. +# tcltest::test -- +# +# This procedure runs a test and prints an error message if the test fails. +# If tcltest::verbose has been set, it also prints a message even if the +# test succeeds. The test will be skipped if it doesn't match the +# tcltest::match variable, if it matches an element in +# tcltest::skip, or if one of the elements of "constraints" turns +# out not to be true. +# +# If testLevel is 1, then this is a top level test, and we record pass/fail +# information; otherwise, this information is not logged and is not added to +# running totals. +# +# Attributes: +# Only description is a required attribute. All others are optional. +# Default values are indicated. +# +# constraints - A list of one or more keywords, each of +# which must be the name of an element in +# the array "tcltest::testConstraints". If any +# of these elements is zero, the test is +# skipped. This attribute is optional; default is {} +# body - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. This attribute is optional; +# default is {} +# result - Expected result from script. This attribute is +# optional; default is {}. +# output - Expected output sent to stdout. This attribute +# is optional; default is {}. +# errorOutput - Expected output sent to stderr. This attribute +# is optional; default is {}. +# returnCodes - Expected return codes. This attribute is +# optional; default is {0 2}. +# setup - Code to run before $script (above). This +# attribute is optional; default is {}. +# cleanup - Code to run after $script (above). This +# attribute is optional; default is {}. +# match - specifies type of matching to do on result, +# output, errorOutput; this must be one of: exact, +# glob, regexp. default is exact. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# description - Short textual description of the test, to +# help humans understand what it does. +# +# Results: +# 0 if the command ran successfully; 1 otherwise. +# +# Side effects: +# None. +# - set constraintList [array names ::tcltest::skippedBecause] - if {[llength $constraintList] > 0} { - puts $::tcltest::outputChannel \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts $::tcltest::outputChannel \ - "\t$::tcltest::skippedBecause($constraint)\t$constraint" - unset ::tcltest::skippedBecause($constraint) - } - } +proc tcltest::test {name description args} { + DebugPuts 3 "Test $name $args" - # report the names of test files in ::tcltest::createdNewFiles, and - # reset the array to be empty. + incr tcltest::testLevel - set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts $::tcltest::outputChannel "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts $::tcltest::outputChannel \ - "\t$testFile:\t$::tcltest::createdNewFiles($testFile)" - unset ::tcltest::createdNewFiles($testFile) + # Pre-define everything to null except output and errorOutput. We + # determine whether or not to trap output based on whether or not these + # variables (output & errorOutput) are defined. + foreach item {constraints setup cleanup body result returnCodes match} { + set $item {} + } + + # Set the default match mode + set match exact + + # Set the default match values for return codes (0 is the standard expected + # return value if everything went well; 2 represents 'return' being used in + # the test script). + set returnCodes [list 0 2] + + # The old test format can't have a 3rd argument (constraints or script) + # that starts with '-'. + if {[llength $args] == 0} { + puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}" + incr tcltest::testLevel -1 + return 1 + } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} { + + if {[llength $args] == 1} { + set list [substArguments [lindex $args 0]] + foreach {element value} $list { + set testAttributes($element) $value + } + foreach item {constraints match setup body cleanup \ + result returnCodes output errorOutput} { + if {[info exists testAttributes([subst -$item])]} { + set testAttributes([subst -$item]) \ + [uplevel concat $testAttributes([subst -$item])] + } } + } else { + array set testAttributes $args } - # reset filesMade, filesExisted, and numTests + set validFlags {-setup -cleanup -body -result -returnCodes -match \ + -output -errorOutput -constraints} - set ::tcltest::filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set ::tcltest::numTests($index) 0 + foreach flag [array names testAttributes] { + if {[lsearch -exact $validFlags $flag] == -1} { + puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test" + incr tcltest::testLevel -1 + return 1 + } } - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && ![info exists tcl_interactive]} { - exit + # store whatever the user gave us + foreach item [array names testAttributes] { + set [string trimleft $item "-"] $testAttributes($item) } - } else { - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed + # Check the values supplied for -match + if {[lsearch {regexp glob exact} $match] == -1} { + puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}" + incr tcltest::testLevel -1 + return 1 + } - incr ::tcltest::numTestFiles - if {($::tcltest::currentFailure) && \ - ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} { - lappend ::tcltest::failFiles $testFileName + # Replace symbolic valies supplied for -returnCodes + regsub -nocase normal $returnCodes 0 returnCodes + regsub -nocase error $returnCodes 1 returnCodes + regsub -nocase return $returnCodes 2 returnCodes + regsub -nocase break $returnCodes 3 returnCodes + regsub -nocase continue $returnCodes 4 returnCodes + } else { + # This is parsing for the old test command format; it is here for + # backward compatibility. + set result [lindex $args end] + if {[llength $args] == 2} { + set body [lindex $args 0] + } elseif {[llength $args] == 3} { + set constraints [lindex $args 0] + set body [lindex $args 1] + } else { + puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}" + incr tcltest::testLevel -1 + return 1 } - set ::tcltest::currentFailure false + } - # restore the environment to the state it was in before this package - # was loaded + set setupFailure 0 + set cleanupFailure 0 - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists ::tcltest::originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { - if {$::env($index) != $::tcltest::originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $::tcltest::originalEnv($index) - } - } + # Run the setup script + if {[catch {uplevel $setup} setupMsg]} { + set setupFailure 1 + } + + # run the test script + set command [list tcltest::runTest $name $description $body \ + $result $constraints] + if {!$setupFailure} { + if {[info exists output] || [info exists errorOutput]} { + set testResult [uplevel tcltest::testEval [list $command] 0] + } else { + set testResult [uplevel tcltest::testEval [list $command] 1] } - foreach index [array names ::tcltest::originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $::tcltest::originalEnv($index) + } else { + set testResult setupFailure + } + + # Run the cleanup code + if {[catch {uplevel $cleanup} cleanupMsg]} { + set cleanupFailure 1 + } + + # If testResult is an empty list, then the test was skipped + if {$testResult != {}} { + set coreFailure 0 + set coreMsg "" + # check for a core file first - if one was created by the test, then + # the test failed + if {$tcltest::preserveCore} { + set currentTclPlatform [array get tcl_platform] + if {[file exists [file join [tcltest::workingDirectory] core]]} { + # There's only a test failure if there is a core file and (1) + # there previously wasn't one or (2) the new one is different + # from the old one. + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [tcltest::workingDirectory] core]]} { + set coreFailure 1 + } + } else { + set coreFailure 1 + } + + if {($tcltest::preserveCore > 1) && ($coreFailure)} { + append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]" + catch {file rename -force \ + [file join [tcltest::workingDirectory] core] \ + [file join $tcltest::temporaryDirectory \ + core-$name]} msg + if {[string length $msg] > 0} { + append coreMsg "\nError: Problem renaming core file: $msg" + } + } } + array set tcl_platform $currentTclPlatform } - if {[llength $newEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements changed:\t$changedEnv" + + set actualAnswer [lindex $testResult 0] + set code [lindex $testResult end] + + # If expected output/error strings exist, we have to compare + # them. If the comparison fails, then so did the test. + set outputFailure 0 + set errorFailure 0 + if {[info exists output]} { + set outputFailure [expr ![compareStrings $tcltest::outData \ + $output $match]] + } + if {[info exists errorOutput]} { + set errorFailure [expr ![compareStrings $tcltest::errData \ + $errorOutput $match]] } - if {[llength $removedEnv] > 0} { - puts $::tcltest::outputChannel \ - "env array elements removed:\t$removedEnv" + + set testFailed 1 + set codeFailure 0 + set scriptFailure 0 + + # check if the return code matched the expected return code + if {[lsearch -exact $returnCodes $code] == -1} { + set codeFailure 1 + } + + # check if the answer matched the expected answer + if {[compareStrings $actualAnswer $result $match] == 0} { + set scriptFailure 1 } - set changedTclPlatform {} - foreach index [array names ::tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $::tcltest::originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $::tcltest::originalTclPlatform($index) + # if we didn't experience any failures, then we passed + if {!($setupFailure || $cleanupFailure || $coreFailure || \ + $outputFailure || $errorFailure || $codeFailure || \ + $scriptFailure)} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Passed) + if {[tcltest::isVerbose pass]} { + puts [outputChannel] "++++ $name PASSED" + } } + set testFailed 0 } - if {[llength $changedTclPlatform] > 0} { - puts $::tcltest::outputChannel \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "produced core file! \ - Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" - flush $::tcltest::outputChannel - catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" + if {$testFailed} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Failed) + } + set tcltest::currentFailure true + if {![tcltest::isVerbose body]} { + set body "" + } + puts [outputChannel] "\n==== $name [string trim $description] FAILED" + if {$body != ""} { + puts [outputChannel] "==== Contents of test case:" + puts [outputChannel] $body + } + if {$setupFailure} { + puts [outputChannel] "---- Test setup failed:\n$setupMsg" + } + if {$scriptFailure} { + puts [outputChannel] "---- Result was:\n$actualAnswer" + puts [outputChannel] "---- Result should have been ($match matching):\n$result" + } + if {$codeFailure} { + switch -- $code { + 0 { set msg "Test completed normally" } + 1 { set msg "Test generated error" } + 2 { set msg "Test generated return exception" } + 3 { set msg "Test generated break exception" } + 4 { set msg "Test generated continue exception" } + default { set msg "Test generated exception" } } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists ::tcltest::coreModificationTime]} { - if {$::tcltest::coreModificationTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "A core file was created!" + puts [outputChannel] "---- $msg; Return code was: $code" + puts [outputChannel] "---- Return code should have been one of: $returnCodes" + if {[tcltest::isVerbose error]} { + if {[info exists ::errorInfo]} { + puts [outputChannel] "---- errorInfo: $::errorInfo" + puts [outputChannel] "---- errorCode: $::errorCode" } - } else { - puts $::tcltest::outputChannel "A core file was created!" - } + } + } + if {$outputFailure} { + puts [outputChannel] "---- Output was:\n$tcltest::outData" + puts [outputChannel] "---- Output should have been ($match matching):\n$output" + } + if {$errorFailure} { + puts [outputChannel] "---- Error output was:\n$tcltest::errData" + puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput" + } + if {$cleanupFailure} { + puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" } + if {$coreFailure} { + puts [outputChannel] "---- Core file produced while running test! $coreMsg" + } + puts [outputChannel] "==== $name FAILED\n" + } } + + incr tcltest::testLevel -1 + return 0 } -# ::tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { - proc ::tcltest::cleanupTestsHook {} {} -} -# test -- +# runTest -- # +# This is the defnition of the version 1.0 test routine for tcltest. It is +# provided here for backward compatibility. It is also used as the 'backbone' +# of the test procedure, as in, this is where all the work really gets done. +# # This procedure runs a test and prints an error message if the test fails. -# If ::tcltest::verbose has been set, it also prints a message even if the +# If tcltest::verbose has been set, it also prints a message even if the # test succeeds. The test will be skipped if it doesn't match the -# ::tcltest::match variable, if it matches an element in -# ::tcltest::skip, or if one of the elements of "constraints" turns +# tcltest::match variable, if it matches an element in +# tcltest::skip, or if one of the elements of "constraints" turns # out not to be true. # # Arguments: @@ -1364,81 +2429,93 @@ if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} { # help humans understand what it does. # constraints - A list of one or more keywords, each of # which must be the name of an element in -# the array "::tcltest::testConstraints". If any of these +# the array "tcltest::testConstraints". If any of these # elements is zero, the test is skipped. # This argument may be omitted. # script - Script to run to carry out the test. It must # return a result that can be checked for # correctness. # expectedAnswer - Expected result from script. +# +# Behavior depends on the value of testLevel; if testLevel is 1 (top level), +# then events are logged and we track the number of tests run/skipped and why. +# Otherwise, we don't track this information. +# +# Results: +# empty list if test is skipped; otherwise returns list containing +# actual returned value from the test and the return code. +# +# Side Effects: +# none. +# -proc ::tcltest::test {name description script expectedAnswer args} { - - DebugPuts 3 "Running $name ($description)" - - incr ::tcltest::numTests(Total) +proc tcltest::runTest {name description script expectedAnswer constraints} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Total) + } + # skip the test if it's name matches an element of skip - - foreach pattern $::tcltest::skip { + foreach pattern $tcltest::skip { if {[string match $pattern $name]} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip} + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip} + } return } } # skip the test if it's name doesn't match any element of match - - if {[llength $::tcltest::match] > 0} { + if {[llength $tcltest::match] > 0} { set ok 0 - foreach pattern $::tcltest::match { + foreach pattern $tcltest::match { if {[string match $pattern $name]} { set ok 1 break } } if {!$ok} { - incr ::tcltest::numTests(Skipped) - DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch} + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch} + } return } } - set i [llength $args] - if {$i == 0} { - set constraints {} + DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints" + + if {$constraints == {}} { # If we're limited to the listed constraints and there aren't any # listed, then we shouldn't run the test. - if {$::tcltest::limitConstraints} { - ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint - incr ::tcltest::numTests(Skipped) + if {$tcltest::limitConstraints} { + tcltest::AddToSkippedBecause userSpecifiedLimitConstraint + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + } return } - } elseif {$i == 1} { - - # "constraints" argument exists; shuffle arguments down, then + } else { + # "constraints" argument exists; # make sure that the constraints are satisfied. - set constraints $script - set script $expectedAnswer - set expectedAnswer [lindex $args 0] set doTest 0 if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} catch {set doTest [uplevel #0 expr $constraints]} } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { # something like {a || b} should be turned into - # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$::tcltest::testConstraints(&)} c + # $tcltest::testConstraints(a) || $tcltest::testConstraints(b). + regsub -all {[.\w]+} $constraints \ + {$tcltest::testConstraints(&)} c catch {set doTest [eval expr $c]} } else { # just simple constraints such as {unixOnly fonts}. set doTest 1 foreach constraint $constraints { - if {(![info exists ::tcltest::testConstraints($constraint)]) \ - || (!$::tcltest::testConstraints($constraint))} { + if {(![info exists tcltest::testConstraints($constraint)]) \ + || (!$tcltest::testConstraints($constraint))} { set doTest 0 # store the constraint that kept the test from running @@ -1447,28 +2524,30 @@ proc ::tcltest::test {name description script expectedAnswer args} { } } } + if {$doTest == 0} { - if {[string first s $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints" + if {[tcltest::isVerbose skip]} { + puts [outputChannel] "++++ $name SKIPPED: $constraints" + } + + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Skipped) + tcltest::AddToSkippedBecause $constraints } - - incr ::tcltest::numTests(Skipped) - ::tcltest::AddToSkippedBecause $constraints return } - } else { - error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" - } + } # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with tcl_platform. + # tcl_platform environment because some of the tests mess with + # tcl_platform. - if {$::tcltest::preserveCore} { + if {$tcltest::preserveCore} { set currentTclPlatform [array get tcl_platform] - array set tcl_platform $::tcltest::originalTclPlatform - if {[file exists [file join $::tcltest::workingDirectory core]]} { + array set tcl_platform $tcltest::originalTclPlatform + if {[file exists [file join [tcltest::workingDirectory] core]]} { set coreModTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + [tcltest::workingDirectory] core]] } array set tcl_platform $currentTclPlatform } @@ -1480,107 +2559,288 @@ proc ::tcltest::test {name description script expectedAnswer args} { memory tag $name } + if {[tcltest::isVerbose start]} { + puts [outputChannel] "---- $name start" + flush [outputChannel] + } + set code [catch {uplevel $script} actualAnswer] - if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} { - incr ::tcltest::numTests(Passed) - if {[string first p $::tcltest::verbose] != -1} { - puts $::tcltest::outputChannel "++++ $name PASSED" + + return [list $actualAnswer $code] +} + +##################################################################### + +# tcltest::cleanupTestsHook -- +# +# This hook allows a harness that builds upon tcltest to specify +# additional things that should be done at cleanup. +# + +if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} { + proc tcltest::cleanupTestsHook {} {} +} + +# tcltest::cleanupTests -- +# +# Remove files and dirs created using the makeFile and makeDirectory +# commands since the last time this proc was invoked. +# +# Print the names of the files created without the makeFile command +# since the tests were invoked. +# +# Print the number tests (total, passed, failed, and skipped) since the +# tests were invoked. +# +# Restore original environment (as reported by special variable env). +# +# Arguments: +# calledFromAllFile - if 0, behave as if we are running a single test file +# within an entire suite of tests. if we aren't running a single test +# file, then don't report status. check for new files created during the +# test run and report on them. if 1, report collated status from all the +# test file runs. +# +# Results: +# None. +# +# Side Effects: +# None +# + +proc tcltest::cleanupTests {{calledFromAllFile 0}} { + + set testFileName [file tail [info script]] + + # Call the cleanup hook + tcltest::cleanupTestsHook + + # Remove files and directories created by the :tcltest::makeFile and + # tcltest::makeDirectory procedures. + # Record the names of files in tcltest::workingDirectory that were not + # pre-existing, and associate them with the test file that created them. + + if {!$calledFromAllFile} { + foreach file $tcltest::filesMade { + if {[file exists $file]} { + catch {file delete -force $file} + } + } + set currentFiles {} + foreach file [glob -nocomplain \ + [file join $tcltest::temporaryDirectory *]] { + lappend currentFiles [file tail $file] + } + set newFiles {} + foreach file $currentFiles { + if {[lsearch -exact $tcltest::filesExisted $file] == -1} { + lappend newFiles $file + } + } + set tcltest::filesExisted $currentFiles + if {[llength $newFiles] > 0} { + set tcltest::createdNewFiles($testFileName) $newFiles + } + } + + if {$calledFromAllFile || $tcltest::testSingleFile} { + + # print stats + + puts -nonewline [outputChannel] "$testFileName:" + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + puts -nonewline [outputChannel] \ + "\t$index\t$tcltest::numTests($index)" + } + puts [outputChannel] "" + + # print number test files sourced + # print names of files that ran tests which failed + + if {$calledFromAllFile} { + puts [outputChannel] \ + "Sourced $tcltest::numTestFiles Test Files." + set tcltest::numTestFiles 0 + if {[llength $tcltest::failFiles] > 0} { + puts [outputChannel] \ + "Files with failing tests: $tcltest::failFiles" + set tcltest::failFiles {} + } + } + + # if any tests were skipped, print the constraints that kept them + # from running. + + set constraintList [array names tcltest::skippedBecause] + if {[llength $constraintList] > 0} { + puts [outputChannel] \ + "Number of tests skipped for each constraint:" + foreach constraint [lsort $constraintList] { + puts [outputChannel] \ + "\t$tcltest::skippedBecause($constraint)\t$constraint" + unset tcltest::skippedBecause($constraint) + } + } + + # report the names of test files in tcltest::createdNewFiles, and + # reset the array to be empty. + + set testFilesThatTurded [lsort [array names tcltest::createdNewFiles]] + if {[llength $testFilesThatTurded] > 0} { + puts [outputChannel] "Warning: files left behind:" + foreach testFile $testFilesThatTurded { + puts [outputChannel] \ + "\t$testFile:\t$tcltest::createdNewFiles($testFile)" + unset tcltest::createdNewFiles($testFile) + } + } + + # reset filesMade, filesExisted, and numTests + + set tcltest::filesMade {} + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + set tcltest::numTests($index) 0 + } + + # exit only if running Tk in non-interactive mode + + global tk_version tcl_interactive + if {[info exists tk_version] && ![info exists tcl_interactive]} { + exit } } else { - incr ::tcltest::numTests(Failed) - set ::tcltest::currentFailure true - if {[string first b $::tcltest::verbose] == -1} { - set script "" - } - puts $::tcltest::outputChannel "\n==== $name $description FAILED" - if {$script != ""} { - puts $::tcltest::outputChannel "==== Contents of test case:" - puts $::tcltest::outputChannel $script - } - if {$code != 0} { - if {$code == 1} { - puts $::tcltest::outputChannel "==== Test generated error:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 2} { - puts $::tcltest::outputChannel "==== Test generated return exception; result was:" - puts $::tcltest::outputChannel $actualAnswer - } elseif {$code == 3} { - puts $::tcltest::outputChannel "==== Test generated break exception" - } elseif {$code == 4} { - puts $::tcltest::outputChannel "==== Test generated continue exception" + + # if we're deferring stat-reporting until all files are sourced, + # then add current file to failFile list if any tests in this file + # failed + + incr tcltest::numTestFiles + if {($tcltest::currentFailure) && \ + ([lsearch -exact $tcltest::failFiles $testFileName] == -1)} { + lappend tcltest::failFiles $testFileName + } + set tcltest::currentFailure false + + # restore the environment to the state it was in before this package + # was loaded + + set newEnv {} + set changedEnv {} + set removedEnv {} + foreach index [array names ::env] { + if {![info exists tcltest::originalEnv($index)]} { + lappend newEnv $index + unset ::env($index) } else { - puts $::tcltest::outputChannel "==== Test generated exception $code; message was:" - puts $::tcltest::outputChannel $actualAnswer + if {$::env($index) != $tcltest::originalEnv($index)} { + lappend changedEnv $index + set ::env($index) $tcltest::originalEnv($index) + } } - } else { - puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer" } - puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer" - puts $::tcltest::outputChannel "==== $name FAILED\n" - } - if {$::tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - if {[file exists [file join $::tcltest::workingDirectory core]]} { - if {$::tcltest::preserveCore > 1} { - puts $::tcltest::outputChannel "==== $name produced core file! \ + foreach index [array names tcltest::originalEnv] { + if {![info exists ::env($index)]} { + lappend removedEnv $index + set ::env($index) $tcltest::originalEnv($index) + } + } + if {[llength $newEnv] > 0} { + puts [outputChannel] \ + "env array elements created:\t$newEnv" + } + if {[llength $changedEnv] > 0} { + puts [outputChannel] \ + "env array elements changed:\t$changedEnv" + } + if {[llength $removedEnv] > 0} { + puts [outputChannel] \ + "env array elements removed:\t$removedEnv" + } + + set changedTclPlatform {} + foreach index [array names tcltest::originalTclPlatform] { + if {$::tcl_platform($index) != \ + $tcltest::originalTclPlatform($index)} { + lappend changedTclPlatform $index + set ::tcl_platform($index) \ + $tcltest::originalTclPlatform($index) + } + } + if {[llength $changedTclPlatform] > 0} { + puts [outputChannel] \ + "tcl_platform array elements changed:\t$changedTclPlatform" + } + + if {[file exists [file join [tcltest::workingDirectory] core]]} { + if {$tcltest::preserveCore > 1} { + puts "rename core file (> 1)" + puts [outputChannel] "produced core file! \ Moving file to: \ - [file join $::tcltest::temporaryDirectory core-$name]" + [file join $tcltest::temporaryDirectory core-$name]" catch {file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory \ - core-$name]} msg + [file join [tcltest::workingDirectory] core] \ + [file join $tcltest::temporaryDirectory \ + core-$name]} msg if {[string length $msg] > 0} { - ::tcltest::PrintError "Problem renaming file: $msg" + tcltest::PrintError "Problem renaming file: $msg" } } else { # Print a message if there is a core file and (1) there # previously wasn't one or (2) the new one is different from # the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join $::tcltest::workingDirectory core]]} { - puts $::tcltest::outputChannel "==== $name produced core file!" + if {[info exists tcltest::coreModificationTime]} { + if {$tcltest::coreModificationTime != [file mtime \ + [file join [tcltest::workingDirectory] core]]} { + puts [outputChannel] "A core file was created!" } } else { - puts $::tcltest::outputChannel "==== $name produced core file!" + puts [outputChannel] "A core file was created!" } } } - array set tcl_platform $currentTclPlatform } + flush [outputChannel] + flush [errorChannel] + return } -# ::tcltest::getMatchingFiles +##################################################################### + +# Procs that determine which tests/test files to run + +# tcltest::getMatchingFiles # # Looks at the patterns given to match and skip files # and uses them to put together a list of the tests that will be run. # # Arguments: -# none +# directory to search # # Results: # The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. +# be used in 'all.tcl' files. It is used in runAllTests. +# +# Side Effects: +# None -proc ::tcltest::getMatchingFiles {args} { - set matchingFiles {} - if {[llength $args]} { - set searchDirectory $args - } else { - set searchDirectory [list $::tcltest::testsDirectory] +proc tcltest::getMatchingFiles { {searchDirectory ""} } { + if {[llength [info level 0]] == 1} { + set searchDirectory [tcltest::testsDirectory] } + set matchingFiles {} + # Find the matching files in the list of directories and then remove the # ones that match the skip pattern foreach directory $searchDirectory { set matchFileList {} - foreach match $::tcltest::matchFiles { + foreach match $tcltest::matchFiles { set matchFileList [concat $matchFileList \ [glob -nocomplain [file join $directory $match]]] } - if {[string compare {} $::tcltest::skipFiles]} { + if {[string compare {} $tcltest::skipFiles]} { set skipFileList {} - foreach skip $::tcltest::skipFiles { + foreach skip $tcltest::skipFiles { set skipFileList [concat $skipFileList \ [glob -nocomplain [file join $directory $skip]]] } @@ -1597,35 +2857,213 @@ proc ::tcltest::getMatchingFiles {args} { } } if {[string equal $matchingFiles {}]} { - ::tcltest::PrintError "No test files remain after applying \ + tcltest::PrintError "No test files remain after applying \ your match and skip patterns!" } return $matchingFiles } -# The following two procs are used in the io tests. - -proc ::tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} +# tcltest::getMatchingDirectories -- +# +# Looks at the patterns given to match and skip directories and uses them +# to put together a list of the test directories that we should attempt +# to run. (Only subdirectories containing an "all.tcl" file are put into +# the list.) +# +# Arguments: +# root directory from which to search +# +# Results: +# The constructed list is returned to the user. This is used in the +# primary all.tcl file. Lower-level all.tcl files should use the +# tcltest::testAllFiles proc instead. +# +# Side Effects: +# None. + +proc tcltest::getMatchingDirectories {rootdir} { + set matchingDirs {} + set matchDirList {} + # Find the matching directories in tcltest::testsDirectory and then + # remove the ones that match the skip pattern + foreach match $tcltest::matchDirectories { + foreach file [glob -nocomplain [file join $rootdir $match]] { + if {([file isdirectory $file]) && ($file != $rootdir)} { + set matchDirList [concat $matchDirList \ + [tcltest::getMatchingDirectories $file]] + if {[file exists [file join $file all.tcl]]} { + set matchDirList [concat $matchDirList $file] + } + } + } } - return $result + if {$tcltest::skipDirectories != {}} { + set skipDirs {} + foreach skip $tcltest::skipDirectories { + set skipDirs [concat $skipDirs \ + [glob -nocomplain [file join $tcltest::testsDirectory \ + $skip]]] + } + foreach dir $matchDirList { + # Only include directories that don't match the skip pattern + if {[lsearch -exact $skipDirs $dir] == -1} { + lappend matchingDirs $dir + } + } + } else { + set matchingDirs [concat $matchingDirs $matchDirList] + } + if {$matchingDirs == {}} { + DebugPuts 1 "No test directories remain after applying match and skip patterns!" + } + return $matchingDirs } -proc ::tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} +# tcltest::runAllTests -- +# +# prints output and sources test files according to the match and skip +# patterns provided. after sourcing test files, it goes on to source +# all.tcl files in matching test subdirectories. +# +# Arguments: +# shell being tested +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::runAllTests { {shell ""} } { + global argv + + if {[llength [info level 0]] == 1} { + set shell [tcltest::interpreter] } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p + + set tcltest::testSingleFile false + + puts [outputChannel] "Tests running in interp: $shell" + puts [outputChannel] "Tests located in: $tcltest::testsDirectory" + puts [outputChannel] "Tests running in: [tcltest::workingDirectory]" + puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory" + if {[tcltest::singleProcess]} { + puts [outputChannel] "Test files sourced into current interpreter" + } else { + puts [outputChannel] "Test files run in separate interpreters" + } + if {[llength $tcltest::skip] > 0} { + puts [outputChannel] "Skipping tests that match: $tcltest::skip" + } + if {[llength $tcltest::match] > 0} { + puts [outputChannel] "Only running tests that match: $tcltest::match" + } + + if {[llength $tcltest::skipFiles] > 0} { + puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles" + } + if {[llength $tcltest::matchFiles] > 0} { + puts [outputChannel] "Only running test files that match: $tcltest::matchFiles" + } + + set timeCmd {clock format [clock seconds]} + puts [outputChannel] "Tests began at [eval $timeCmd]" + + # Run each of the specified tests + foreach file [lsort [tcltest::getMatchingFiles]] { + set tail [file tail $file] + puts [outputChannel] $tail + + if {$tcltest::singleProcess} { + incr tcltest::numTestFiles + uplevel [list source $file] + } else { + # Change to the tests directory so the value of the following + # variable is set correctly when we spawn the child test processes + cd $tcltest::testsDirectory + set cmd [concat [list | $shell $file] [split $argv]] + if {[catch { + incr tcltest::numTestFiles + set pipeFd [open $cmd "r"] + while {[gets $pipeFd line] >= 0} { + if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + incr tcltest::numTests($index) [set $index] + } + if {$Failed > 0} { + lappend tcltest::failFiles $testFile + } + } elseif {[regexp {^Number of tests skipped for each constraint:|^\t(\d+)\t(.+)$} $line match skipped constraint]} { + if {$match != "Number of tests skipped for each constraint:"} { + tcltest::AddToSkippedBecause $constraint $skipped + } + } else { + puts [outputChannel] $line + } + } + close $pipeFd + } msg]} { + # Print results to tcltest::outputChannel. + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported later + lappend testFileFailures $file + } } } - return $leak + + # cleanup + puts [outputChannel] "\nTests ended at [eval $timeCmd]" + tcltest::cleanupTests 1 + if {[info exists testFileFailures]} { + puts [outputChannel] "\nTest files exiting with errors: \n" + foreach file $testFileFailures { + puts " [file tail $file]\n" + } + } + + # Checking for subdirectories in which to run tests + foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] { + set dir [file tail $directory] + puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + puts [outputChannel] "$dir test began at [eval $timeCmd]\n" + + uplevel "source [file join $directory all.tcl]" + + set endTime [eval $timeCmd] + puts [outputChannel] "\n$dir test ended at $endTime" + puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + } + return +} + +##################################################################### + +# Test utility procs - not used in tcltest, but may be useful for testing. + +# tcltest::loadTestedCommands -- +# +# Uses the specified script to load the commands to test. Allowed to +# be empty, as the tested commands could have been compiled into the +# interpreter. +# +# Arguments +# none +# +# Results +# none +# +# Side Effects: +# none. + +proc tcltest::loadTestedCommands {} { + if {$tcltest::loadScript == {}} { + return + } + + return [uplevel $tcltest::loadScript] } -# ::tcltest::saveState -- +# tcltest::saveState -- # # Save information regarding what procs and variables exist. # @@ -1633,58 +3071,71 @@ proc ::tcltest::leakfiles {old} { # none # # Results: -# Modifies the variable ::tcltest::saveState +# Modifies the variable tcltest::saveState +# +# Side effects: +# None. -proc ::tcltest::saveState {} { - uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState" +proc tcltest::saveState {} { + uplevel {set tcltest::saveState [list [info procs] [info vars]]} + DebugPuts 2 "tcltest::saveState: $tcltest::saveState" + return } -# ::tcltest::restoreState -- +# tcltest::restoreState -- # # Remove procs and variables that didn't exist before the call to -# ::tcltest::saveState. +# tcltest::saveState. # # Arguments: # none # # Results: # Removes procs and variables from your environment if they don't exist -# in the ::tcltest::saveState variable. +# in the tcltest::saveState variable. +# +# Side effects: +# None. -proc ::tcltest::restoreState {} { +proc tcltest::restoreState {} { foreach p [info procs] { - if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \ - (![string equal ::tcltest::$p [namespace origin $p]])} { + if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \ + (![string match "*tcltest::$p" [namespace origin $p]])} { - DebugPuts 2 "::tcltest::restoreState: Removing proc $p" + DebugPuts 2 "tcltest::restoreState: Removing proc $p" rename $p {} } } - foreach p [uplevel #0 {info vars}] { - if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { - DebugPuts 2 "::tcltest::restoreState: Removing variable $p" - uplevel #0 "catch {unset $p}" + foreach p [uplevel {info vars}] { + if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} { + DebugPuts 2 "tcltest::restoreState: Removing variable $p" + uplevel "catch {unset $p}" } } + return } -# ::tcltest::normalizeMsg -- +# tcltest::normalizeMsg -- # # Removes "extra" newlines from a string. # # Arguments: # msg String to be modified # +# Results: +# string with extra newlines removed +# +# Side effects: +# None. -proc ::tcltest::normalizeMsg {msg} { +proc tcltest::normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg regsub -all "\n\n" $msg "\n" msg regsub -all "\n\}" $msg "\}" msg return $msg } -# makeFile -- +# tcltest::makeFile -- # # Create a new file with the name <name>, and write <contents> to it. # @@ -1692,12 +3143,28 @@ proc ::tcltest::normalizeMsg {msg} { # cleanupTests was called, add it to the $filesMade list, so it will # be removed by the next call to cleanupTests. # -proc ::tcltest::makeFile {contents name} { +# Arguments: +# contents content of the new file +# name name of the new file +# directory directory name for new file +# +# Results: +# absolute path to the file created +# +# Side effects: +# None. + +proc tcltest::makeFile {contents name {directory ""}} { global tcl_platform + + if {[llength [info level 0]] == 3} { + set directory [tcltest::temporaryDirectory] + } - DebugPuts 3 "::tcltest::makeFile: putting $contents into $name" + set fullName [file join $directory $name] + + DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" - set fullName [file join $::tcltest::temporaryDirectory $name] set fd [open $fullName w] fconfigure $fd -translation lf @@ -1709,26 +3176,36 @@ proc ::tcltest::makeFile {contents name} { } close $fd - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName + if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { + lappend tcltest::filesMade $fullName } return $fullName } -# ::tcltest::removeFile -- +# tcltest::removeFile -- # # Removes the named file from the filesystem # # Arguments: -# name file to be removed +# name file to be removed +# directory directory from which to remove file # +# Results: +# return value from [file delete] +# +# Side effects: +# None. -proc ::tcltest::removeFile {name} { - DebugPuts 3 "::tcltest::removeFile: removing $name" - file delete [file join $::tcltest::temporaryDirectory $name] +proc tcltest::removeFile {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeFile: removing $fullName" + return [file delete $fullName] } -# makeDirectory -- +# tcltest::makeDirectory -- # # Create a new dir with the name <name>. # @@ -1736,75 +3213,85 @@ proc ::tcltest::removeFile {name} { # cleanupTests was called, add it to the $directoriesMade list, so it will # be removed by the next call to cleanupTests. # -proc ::tcltest::makeDirectory {name} { - file mkdir $name +# Arguments: +# name name of the new directory +# directory directory in which to create new dir +# +# Results: +# absolute path to the directory created +# +# Side effects: +# None. - set fullName [file join [pwd] $name] - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName +proc tcltest::makeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::makeDirectory: creating $fullName" + file mkdir $fullName + if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { + lappend tcltest::filesMade $fullName + } + return $fullName } -# ::tcltest::removeDirectory -- +# tcltest::removeDirectory -- # # Removes a named directory from the file system. # # Arguments: -# name Name of the directory to remove +# name Name of the directory to remove +# directory Directory from which to remove # +# Results: +# return value from [file delete] +# +# Side effects: +# None -proc ::tcltest::removeDirectory {name} { - file delete -force $name -} - -proc ::tcltest::viewFile {name} { - global tcl_platform - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ($::tcltest::testConstraints(unixExecs) == 0)} { - set f [open [file join $::tcltest::temporaryDirectory $name]] - set data [read -nonewline $f] - close $f - return $data - } else { - exec cat [file join $::tcltest::temporaryDirectory $name] +proc tcltest::removeDirectory {name {directory ""}} { + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } + set fullName [file join $directory $name] + DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" + return [file delete -force $fullName] } -# grep -- +# tcltest::viewFile -- # -# Evaluate a given expression against each element of a list and return all -# elements for which the expression evaluates to true. For the purposes of -# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the -# value of the current element within the expression. This is equivalent to -# the perl grep command where CURRENT_ELEMENT would be the name for the special -# variable $_. +# reads the content of a file and returns it # -# Examples of usage would be: -# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] -# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] +# Arguments: +# name of the file to read +# directory in which file is located # -# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is -# assumed to be the final argument to the expression provided. -# -# Example: -# grep {regexp a} $someList +# Results: +# content of the named file # -proc ::tcltest::grep { expression searchList } { - foreach element $searchList { - if {[regsub -all CURRENT_ELEMENT $expression $element \ - newExpression] == 0} { - set newExpression "$expression {$element}" - } - if {[eval $newExpression] == 1} { - lappend returnList $element - } +# Side effects: +# None. + +proc tcltest::viewFile {name {directory ""}} { + global tcl_platform + if {[llength [info level 0]] == 2} { + set directory [tcltest::temporaryDirectory] } - if {[info exists returnList]} { - return $returnList + set fullName [file join $directory $name] + if {([string equal $tcl_platform(platform) "macintosh"]) || \ + ([tcltest::testConstraint unixExecs] == 0)} { + set f [open $fullName] + set data [read -nonewline $f] + close $f + return $data + } else { + return [exec cat $fullName] } return } +# tcltest::bytestring -- # # Construct a string that consists of the requested sequence of bytes, # as opposed to a string of properly formed UTF-8 characters. @@ -1818,30 +3305,112 @@ proc ::tcltest::grep { expression searchList } { # Generally, it's a bad idea to examine the bytes in a Tcl string or to # construct improperly formed strings in this manner, because it involves # exposing that Tcl uses UTF-8 internally. +# +# Arguments: +# string being converted +# +# Results: +# result fom encoding +# +# Side effects: +# None + +proc tcltest::bytestring {string} { + return [encoding convertfrom identity $string] +} + +# tcltest::openfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. -proc ::tcltest::bytestring {string} { - encoding convertfrom identity $string +proc tcltest::openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +# tcltest::leakfiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak } # # Internationalization / ISO support procs -- dl # -proc ::tcltest::set_iso8859_1_locale {} { + +# tcltest::set_iso8859_1_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::set_iso8859_1_locale {} { if {[info commands testlocale] != ""} { - set ::tcltest::previousLocale [testlocale ctype] - testlocale ctype $::tcltest::isoLocale + set tcltest::previousLocale [testlocale ctype] + testlocale ctype $tcltest::isoLocale } return } -proc ::tcltest::restore_locale {} { +# tcltest::restore_locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::restore_locale {} { if {[info commands testlocale] != ""} { - testlocale ctype $::tcltest::previousLocale + testlocale ctype $tcltest::previousLocale } return } -# threadReap -- +# tcltest::threadReap -- # # Kill all threads except for the main thread. # Do nothing if testthread is not defined. @@ -1851,7 +3420,12 @@ proc ::tcltest::restore_locale {} { # # Results: # Returns the number of existing threads. -proc ::tcltest::threadReap {} { +# +# Side Effects: +# none. +# + +proc tcltest::threadReap {} { if {[info commands testthread] != {}} { # testthread built into tcltest @@ -1859,7 +3433,7 @@ proc ::tcltest::threadReap {} { testthread errorproc ThreadNullError while {[llength [testthread names]] > 1} { foreach tid [testthread names] { - if {$tid != $::tcltest::mainThread} { + if {$tid != $tcltest::mainThread} { catch {testthread send -async $tid {testthread exit}} } } @@ -1877,7 +3451,7 @@ proc ::tcltest::threadReap {} { thread::errorproc ThreadNullError while {[llength [thread::names]] > 1} { foreach tid [thread::names] { - if {$tid != $::tcltest::mainThread} { + if {$tid != $tcltest::mainThread} { catch {thread::send -async $tid {thread::exit}} } } @@ -1891,6 +3465,7 @@ proc ::tcltest::threadReap {} { } else { return 1 } + return 0 } # Initialize the constraints and set up command line arguments @@ -1898,8 +3473,18 @@ namespace eval tcltest { # Ensure that we have a minimal auto_path so we don't pick up extra junk. set ::auto_path [list [info library]] - ::tcltest::initConstraints - if {[namespace children ::tcltest] == {}} { - ::tcltest::processCmdLineArgs + tcltest::initConstraints + if {[namespace children [namespace current]] == {}} { + tcltest::processCmdLineArgs + } + + # Save the names of files that already exist in + # the output directory. + foreach file [glob -nocomplain \ + [file join $tcltest::temporaryDirectory *]] { + lappend tcltest::filesExisted [file tail $file] } } + +package provide tcltest 2.0 + diff --git a/library/tcltest1.0/tcltest2.tcl b/library/tcltest1.0/tcltest2.tcl deleted file mode 100755 index c05732d..0000000 --- a/library/tcltest1.0/tcltest2.tcl +++ /dev/null @@ -1,3490 +0,0 @@ -# tcltest.tcl -- -# -# This file contains support code for the Tcl test suite. It -# defines the tcltest namespace and finds and defines the output -# directory, constraints available, output and error channels, etc. used -# by Tcl tests. See the tcltest man page for more details. -# -# This design was based on the Tcl testing approach designed and -# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. -# -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions -# All rights reserved. -# -# RCS: @(#) $Id: tcltest2.tcl,v 1.4 2000/10/19 18:00:58 jenn Exp $ - -# create the "tcltest" namespace for all testing variables and procedures - -namespace eval tcltest { - - # Export the public tcltest procs - set procList [list test cleanupTests saveState restoreState \ - normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring threadReap debug testConstraint \ - limitConstraints loadTestedCommands normalizePath verbose match \ - skip matchFiles skipFiles preserveCore loadScript loadFile \ - mainThread workingDirectory singleProcess interpreter runAllTests \ - outputChannel outputFile errorChannel \ - errorFile temporaryDirectory testsDirectory matchDirectories \ - skipDirectories ] - foreach proc $procList { - namespace export $proc - } - - # tcltest::verbose defaults to {body} - if {![info exists verbose]} { - variable verbose {body} - } - - # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory and - # matchDirectories, which defaults to all directories. - - if {![info exists match]} { - variable match {} - } - if {![info exists skip]} { - variable skip {} - } - if {![info exists matchFiles]} { - variable matchFiles {*.test} - } - if {![info exists skipFiles]} { - variable skipFiles {} - } - if {![info exists matchDirectories]} { - variable matchDirectories {*} - } - if {![info exists skipDirectories]} { - variable skipDirectories {} - } - - # By default, don't save core files - if {![info exists preserveCore]} { - variable preserveCore 0 - } - - # output goes to stdout by default - if {![info exists outputChannel]} { - variable outputChannel stdout - } - if {![info exists outputFile]} { - variable outputFile stdout - } - - # errors go to stderr by default - if {![info exists errorChannel]} { - variable errorChannel stderr - } - if {![info exists errorFile]} { - variable errorFile stderr - } - - # debug output doesn't get printed by default; debug level 1 spits - # up only the tests that were skipped because they didn't match or were - # specifically skipped. A debug level of 2 would spit up the tcltest - # variables and flags provided; a debug level of 3 causes some additional - # output regarding operations of the test harness. The tcltest package - # currently implements only up to debug level 3. - if {![info exists debug]} { - variable debug 0 - } - - # Save any arguments that we might want to pass through to other programs. - # This is used by the -args flag. - if {![info exists parameters]} { - variable parameters {} - } - - # Count the number of files tested (0 if runAllTests wasn't called). - # runAllTests will set testSingleFile to false, so stats will - # not be printed until runAllTests calls the cleanupTests proc. - # The currentFailure var stores the boolean value of whether the - # current test file has had any failures. The failFiles list - # stores the names of test files that had failures. - - if {![info exists numTestFiles]} { - variable numTestFiles 0 - } - if {![info exists testSingleFile]} { - variable testSingleFile true - } - if {![info exists currentFailure]} { - variable currentFailure false - } - if {![info exists failFiles]} { - variable failFiles {} - } - - # Tests should remove all files they create. The test suite will - # check the current working dir for files created by the tests. - # tcltest::filesMade keeps track of such files created using the - # tcltest::makeFile and tcltest::makeDirectory procedures. - # tcltest::filesExisted stores the names of pre-existing files. - - if {![info exists filesMade]} { - variable filesMade {} - } - if {![info exists filesExisted]} { - variable filesExisted {} - } - - # tcltest::numTests will store test files as indices and the list - # of files (that should not have been) left behind by the test files. - - if {![info exists createdNewFiles]} { - variable createdNewFiles - array set tcltest::createdNewFiles {} - } - - # initialize tcltest::numTests array to keep track fo the number of - # tests that pass, fail, and are skipped. - - if {![info exists numTests]} { - variable numTests - array set tcltest::numTests \ - [list Total 0 Passed 0 Skipped 0 Failed 0] - } - - # initialize tcltest::skippedBecause array to keep track of - # constraints that kept tests from running; a constraint name of - # "userSpecifiedSkip" means that the test appeared on the list of tests - # that matched the -skip value given to the flag; "userSpecifiedNonMatch" - # means that the test didn't match the argument given to the -match flag; - # both of these constraints are counted only if tcltest::debug is set to - # true. - - if {![info exists skippedBecause]} { - variable skippedBecause - array set tcltest::skippedBecause {} - } - - # initialize the tcltest::testConstraints array to keep track of valid - # predefined constraints (see the explanation for the - # tcltest::initConstraints proc for more details). - - if {![info exists testConstraints]} { - variable testConstraints - array set tcltest::testConstraints {} - } - - if {![info exists constraintsSpecified]} { - variable constraintsSpecified {} - } - - # Don't run only the constrained tests by default - - if {![info exists limitConstraints]} { - variable limitConstraints false - } - - # A test application has to know how to load the tested commands into - # the interpreter. - - if {![info exists loadScript]} { - variable loadScript {} - } - - # and the filename of the script file, if it exists - if {![info exists loadFile]} { - variable loadFile {} - } - - # tests that use threads need to know which is the main thread - - if {![info exists mainThread]} { - variable mainThread 1 - if {[info commands thread::id] != {}} { - set mainThread [thread::id] - } elseif {[info commands testthread] != {}} { - set mainThread [testthread id] - } - } - - # save the original environment so that it can be restored later - - if {![info exists originalEnv]} { - variable originalEnv - array set tcltest::originalEnv [array get ::env] - } - - # Set tcltest::workingDirectory to [pwd]. The default output directory - # for Tcl tests is the working directory. - - if {![info exists workingDirectory]} { - variable workingDirectory [pwd] - } - if {![info exists temporaryDirectory]} { - variable temporaryDirectory $workingDirectory - } - - # Tests should not rely on the current working directory. - # Files that are part of the test suite should be accessed relative to - # tcltest::testsDirectory. - - if {![info exists testsDirectory]} { - set oldpwd [pwd] - catch {cd [file join [file dirname [info script]] .. .. tests]} - variable testsDirectory [pwd] - cd $oldpwd - unset oldpwd - } - - # Default is to run each test file in a separate process - if {![info exists singleProcess]} { - variable singleProcess 0 - } - - # the variables and procs that existed when tcltest::saveState was - # called are stored in a variable of the same name - if {![info exists saveState]} { - variable saveState {} - } - - # Internationalization support -- used in tcltest::set_iso8859_1_locale - # and tcltest::restore_locale. Those commands are used in cmdIL.test. - if {![info exists previousLocale]} { - variable previousLocale - } - - if {![info exists isoLocale]} { - variable isoLocale fr - switch -- $tcl_platform(platform) { - "unix" { - - # Try some 'known' values for some platforms: - - switch -exact -- $tcl_platform(os) { - "FreeBSD" { - set tcltest::isoLocale fr_FR.ISO_8859-1 - } - HP-UX { - set tcltest::isoLocale fr_FR.iso88591 - } - Linux - - IRIX { - set tcltest::isoLocale fr - } - default { - - # Works on SunOS 4 and Solaris, and maybe others... - # define it to something else on your system - #if you want to test those. - - set tcltest::isoLocale iso_8859_1 - } - } - } - "windows" { - set tcltest::isoLocale French - } - } - } - - # Set the location of the execuatble - if {![info exists tcltest]} { - variable tcltest [info nameofexecutable] - } - - # save the platform information so it can be restored later - if {![info exists originalTclPlatform]} { - variable originalTclPlatform [array get tcl_platform] - } - - # If a core file exists, save its modification time. - if {![info exists coreModificationTime]} { - if {[file exists [file join $tcltest::workingDirectory core]]} { - variable coreModificationTime [file mtime [file join \ - $tcltest::workingDirectory core]] - } - } - - # stdout and stderr buffers for use when we want to store them - if {![info exists outData]} { - variable outData {} - } - if {![info exists errData]} { - variable errData {} - } - - # keep track of test level for nested test commands - variable testLevel 0 -} - -##################################################################### - -# tcltest::Debug* -- -# -# Internal helper procedures to write out debug information -# dependent on the chosen level. A test shell may overide -# them, f.e. to redirect the output into a different -# channel, or even into a GUI. - -# tcltest::DebugPuts -- -# -# Prints the specified string if the current debug level is -# higher than the provided level argument. -# -# Arguments: -# level The lowest debug level triggering the output -# string The string to print out. -# -# Results: -# Prints the string. Nothing else is allowed. -# -# Side Effects: -# None. -# - -proc tcltest::DebugPuts {level string} { - variable debug - if {$debug >= $level} { - puts $string - } - return -} - -# tcltest::DebugPArray -- -# -# Prints the contents of the specified array if the current -# debug level is higher than the provided level argument -# -# Arguments: -# level The lowest debug level triggering the output -# arrayvar The name of the array to print out. -# -# Results: -# Prints the contents of the array. Nothing else is allowed. -# -# Side Effects: -# None. -# - -proc tcltest::DebugPArray {level arrayvar} { - variable debug - - if {$debug >= $level} { - catch {upvar $arrayvar $arrayvar} - parray $arrayvar - } - return -} - -# tcltest::DebugDo -- -# -# Executes the script if the current debug level is greater than -# the provided level argument -# -# Arguments: -# level The lowest debug level triggering the execution. -# script The tcl script executed upon a debug level high enough. -# -# Results: -# Arbitrary side effects, dependent on the executed script. -# -# Side Effects: -# None. -# - -proc tcltest::DebugDo {level script} { - variable debug - - if {$debug >= $level} { - uplevel $script - } - return -} - -##################################################################### - -# tcltest::CheckDirectory -- -# -# This procedure checks whether the specified path is a readable -# and/or writable directory. If one of the conditions is not -# satisfied an error is printed and the application aborted. The -# procedure assumes that the caller already checked the existence -# of the path. -# -# Arguments -# rw Information what attributes to check. Allowed values: -# r, w, rw, wr. If 'r' is part of the value the directory -# must be readable. 'w' associates to 'writable'. -# dir The directory to check. -# errMsg The string to prepend to the actual error message before -# printing it. -# -# Results -# none -# -# Side Effects: -# None. -# - -proc tcltest::CheckDirectory {rw dir errMsg} { - # Allowed values for 'rw': r, w, rw, wr - - if {![file isdir $dir]} { - set msg "$errMsg \"$dir\" is not a directory" - error $msg - } elseif {([string first w $rw] >= 0) && ![file writable $dir]} { - set msg "$errMsg \"$dir\" is not writeable" - error $msg - } elseif {([string first r $rw] >= 0) && ![file readable $dir]} { - set msg "$errMsg \"$dir\" is not readable" - error $msg - } - return -} - -# tcltest::normalizePath -- -# -# This procedure resolves any symlinks in the path thus creating a -# path without internal redirection. It assumes that the incoming -# path is absolute. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# -# Results -# The path is modified in place. -# -# Side Effects: -# None. -# - -proc tcltest::normalizePath {pathVar} { - upvar $pathVar path - - set oldpwd [pwd] - catch {cd $path} - set path [pwd] - cd $oldpwd - return $path -} - - -# tcltest::MakeAbsolutePath -- -# -# This procedure checks whether the incoming path is absolute or not. -# Makes it absolute if it was not. -# -# Arguments -# pathVar contains the name of the variable containing the path to modify. -# prefix is optional, contains the path to use to make the other an -# absolute one. The current working directory is used if it was -# not specified. -# -# Results -# The path is modified in place. -# -# Side Effects: -# None. -# - -proc tcltest::MakeAbsolutePath {pathVar {prefix {}}} { - upvar $pathVar path - - if {![string equal [file pathtype $path] "absolute"]} { - if {$prefix == {}} { - set prefix [pwd] - } - - set path [file join $prefix $path] - } - return $path -} - -##################################################################### - -# tcltest::<variableName> -# -# Accessor functions for tcltest variables that can be modified externally. -# These are vars that could otherwise be modified using command line -# arguments to tcltest. - -# tcltest::verbose -- -# -# Set or return the verbosity level (tcltest::verbose) for tests. This -# determines what gets printed to the screen and when, with regard to the -# running of the tests. The proc does not check for invalid values. It -# assumes that a string that doesn't match its predefined keywords -# is a string containing letter-specified verbosity levels. -# -# Arguments: -# A string containing any combination of 'pbste' or a list of keywords -# (listed in parens) -# p = print output whenever a test passes (pass) -# b = print the body of the test when it fails (body) -# s = print when a test is skipped (skip) -# t = print when a test starts (start) -# e = print errorInfo and errorCode when a test encounters an error -# (error) -# -# Results: -# content of tcltest::verbose - this is always the character combination -# (pbste) instead of the list form. -# -# Side effects: -# None. - -proc tcltest::verbose { {level ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::verbose - } - if {[llength $level] > 1} { - set tcltest::verbose $level - } else { - if {[regexp {pass|body|skip|start|error} $level]} { - set tcltest::verbose $level - } else { - set levelList [split $level {}] - set tcltest::verbose [string map {p pass b body s skip t start e - error} $levelList] - } - } - return $tcltest::verbose -} - -# tcltest::isVerbose -- -# -# Returns true if argument is one of the verbosity levels currently being -# used; returns false otherwise. -# -# Arguments: -# level -# -# Results: -# boolean 1 (true) or 0 (false), depending on whether or not the level -# provided is one of the ones stored in tcltest::verbose. -# -# Side effects: -# None. - -proc tcltest::isVerbose {level} { - if {[lsearch -exact [tcltest::verbose] $level] == -1} { - return 0 - } - return 1 -} - - - -# tcltest::match -- -# -# Set or return the match patterns (tcltest::match) that determine which -# tests are run. -# -# Arguments: -# List containing match patterns (glob format) -# -# Results: -# content of tcltest::match -# -# Side effects: -# none - -proc tcltest::match { {matchList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::match - } - set tcltest::match $matchList -} - -# tcltest::skip -- -# -# Set or return the skip patterns (tcltest::skip) that determine which -# tests are skipped. -# -# Arguments: -# List containing skip patterns (glob format) -# -# Results: -# content of tcltest::skip -# -# Side effects: -# None. - -proc tcltest::skip { {skipList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skip - } - set tcltest::skip $skipList -} - -# tcltest::matchFiles -- -# -# set or return the match patterns for file sourcing -# -# Arguments: -# list containing match file list (glob format) -# -# Results: -# content of tcltest::matchFiles -# -# Side effects: -# None. - -proc tcltest::matchFiles { {matchFileList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::matchFiles - } - set tcltest::matchFiles $matchFileList -} - -# tcltest::skipFiles -- -# -# set or return the skip patterns for file sourcing -# -# Arguments: -# list containing the skip file list (glob format) -# -# Results: -# content of tcltest::skipFiles -# -# Side effects: -# None. - -proc tcltest::skipFiles { {skipFileList ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skipFiles - } - set tcltest::skipFiles $skipFileList -} - - -# tcltest::matchDirectories -- -# -# set or return the list of directories for matching (glob pattern list) -# -# Arguments: -# list of glob patterns matching subdirectories of -# tcltest::testsDirectory -# -# Results: -# content of tcltest::matchDirectories -# -# Side effects: -# None. - -proc tcltest::matchDirectories { {dirlist ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::matchDirectories - } - set tcltest::matchDirectories $dirlist -} - -# tcltest::skipDirectories -- -# -# set or return the list of directories to skip (glob pattern list) -# -# Arguments: -# list of glob patterns matching directories to skip; these directories -# are subdirectories of tcltest::testsDirectory -# -# Results: -# content of tcltest::skipDirectories -# -# Side effects: -# None. - -proc tcltest::skipDirectories { {dirlist ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::skipDirectories - } - set tcltest::skipDirectories $dirlist -} - -# tcltest::preserveCore -- -# -# set or return the core preservation level. This proc does not do any -# error checking for invalid values. -# -# Arguments: -# core level: -# '0' = don't do anything with core files (default) -# '1' = notify the user if core files are created -# '2' = save any core files produced during testing to -# tcltest::temporaryDirectory -# -# Results: -# content of tcltest::preserveCore -# -# Side effects: -# None. - -proc tcltest::preserveCore { {coreLevel ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::preserveCore - } - set tcltest::preserveCore $coreLevel -} - -# tcltest::outputChannel -- -# -# set or return the output file descriptor based on the supplied file -# name (where tcltest puts all of its output) -# -# Arguments: -# output file descriptor -# -# Results: -# file descriptor corresponding to supplied file name (or currently set -# file descriptor, if no new filename was supplied) - this is the content -# of tcltest::outputChannel -# -# Side effects: -# None. - -proc tcltest::outputChannel { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::outputChannel - } - if {($filename == "stderr") || ($filename == "stdout")} { - set tcltest::outputChannel $filename - } else { - set tcltest::outputChannel [open $filename w] - } - return $tcltest::outputChannel -} - -# tcltest::outputFile -- -# -# set or return the output file name (where tcltest puts all of its -# output); calls tcltest::outputChannel to set the corresponding file -# descriptor -# -# Arguments: -# output file name -# -# Results: -# file name corresponding to supplied file name (or currently set -# file name, if no new filename was supplied) - this is the content -# of tcltest::outputFile -# -# Side effects: -# if the file name supplied is relative, it will be made absolute with -# respect to the predefined temporaryDirectory - -proc tcltest::outputFile { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::outputFile - } - if {($filename != "stderr") && ($filename != "stdout")} { - MakeAbsolutePath filename $tcltest::temporaryDirectory - } - tcltest::outputChannel $filename - set tcltest::outputFile $filename -} - -# tcltest::errorChannel -- -# -# set or return the error file descriptor based on the supplied file name -# (where tcltest sends all its errors) -# -# Arguments: -# error file name -# -# Results: -# file descriptor corresponding to the supplied file name (or currently -# set file descriptor, if no new filename was supplied) - this is the -# content of tcltest::errorChannel -# -# Side effects: -# opens the descriptor in w mode unless the filename is set to stderr or -# stdout - -proc tcltest::errorChannel { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::errorChannel - } - if {($filename == "stderr") || ($filename == "stdout")} { - set tcltest::errorChannel $filename - } else { - set tcltest::errorChannel [open $filename w] - } - return $tcltest::errorChannel -} - -# tcltest::errorFile -- -# -# set or return the error file name; calls tcltest::errorChannel to set -# the corresponding file descriptor -# -# Arguments: -# error file name -# -# Results: -# content of tcltest::errorFile -# -# Side effects: -# if the file name supplied is relative, it will be made absolute with -# respect to the predefined temporaryDirectory - -proc tcltest::errorFile { {filename ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::errorFile - } - if {($filename != "stderr") && ($filename != "stdout")} { - MakeAbsolutePath filename $tcltest::temporaryDirectory - } - set tcltest::errorFile $filename - errorChannel $tcltest::errorFile - return $tcltest::errorFile -} - -# tcltest::debug -- -# -# set or return the debug level for tcltest; this proc does not check for -# invalid values -# -# Arguments: -# debug level: -# '0' = no debug output (default) -# '1' = skipped tests -# '2' = tcltest variables and supplied flags -# '3' = harness operations -# -# Results: -# content of tcltest::debug -# -# Side effects: -# None. - -proc tcltest::debug { {debugLevel ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::debug - } - set tcltest::debug $debugLevel -} - -# tcltest::testConstraint -- -# -# sets a test constraint to a value; to do multiple constraints, call -# this proc multiple times. also returns the value of the named -# constraint if no value was supplied. -# -# Arguments: -# constraint - name of the constraint -# value - new value for constraint (should be boolean) - if not supplied, -# this is a query -# -# Results: -# content of tcltest::testConstraints($constraint) -# -# Side effects: -# appends the constraint name to tcltest::constraintsSpecified - -proc tcltest::testConstraint {constraint {value ""}} { - DebugPuts 3 "entering testConstraint $constraint $value" - if {[llength [info level 0]] == 2} { - return $tcltest::testConstraints($constraint) - } - lappend tcltest::constraintsSpecified $constraint - set tcltest::testConstraints($constraint) $value -} - -# tcltest::constraintsSpecified -- -# -# returns a list of all the constraint names specified using -# testConstraint -# -# Arguments: -# None. -# -# Results: -# list of the constraint names in tcltest::constraintsSpecified -# -# Side effects: -# None. - -proc tcltest::constraintsSpecified {} { - return $tcltest::constraintsSpecified -} - -# tcltest::constraintList -- -# -# returns a list of all the constraint names -# -# Arguments: -# None. -# -# Results: -# list of the constraint names in tcltest::testConstraints -# -# Side effects: -# None. - -proc tcltest::constraintList {} { - return [array names tcltest::testConstraints] -} - -# tcltest::limitConstraints -- -# -# sets the limited constraints to tcltest::limitConstraints -# -# Arguments: -# list of constraint names -# -# Results: -# content of tcltest::limitConstraints -# -# Side effects: -# None. - -proc tcltest::limitConstraints { {constraintList ""} } { - DebugPuts 3 "entering limitConstraints $constraintList" - if {[llength [info level 0]] == 1} { - return $tcltest::limitConstraints - } - set tcltest::limitConstraints $constraintList - foreach elt [tcltest::constraintList] { - if {[lsearch -exact [tcltest::constraintsSpecified] $elt] == -1} { - tcltest::testConstraint $elt 0 - } - } - return $tcltest::limitConstraints -} - -# tcltest::loadScript -- -# -# sets the load script -# -# Arguments: -# script to be set -# -# Results: -# contents of tcltest::loadScript -# -# Side effects: -# None. - -proc tcltest::loadScript { {script ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::loadScript - } - set tcltest::loadScript $script -} - -# tcltest::loadFile -- -# -# set the load file (containing the load script); -# put the content of the load file into loadScript -# -# Arguments: -# script's file name -# -# Results: -# content of tcltest::loadFile -# -# Side effects: -# None. - -proc tcltest::loadFile { {scriptFile ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::loadFile - } - MakeAbsolutePath scriptFile $tcltest::temporaryDirectory - set tmp [open $scriptFile r] - tcltest::loadScript [read $tmp] - close $tmp - set tcltest::loadFile $scriptFile -} - -# tcltest::workingDirectory -- -# -# set workingDirectory to the given path. -# If the path is relative, make it absolute. -# change directory to the stated working directory, if resetting the -# value -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::workingDirectory -# -# Side effects: -# None. - -proc tcltest::workingDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::workingDirectory - } - set tcltest::workingDirectory $dir - MakeAbsolutePath tcltest::workingDirectory - cd $tcltest::workingDirectory - return $tcltest::workingDirectory -} - -# tcltest::temporaryDirectory -- -# -# Set tcltest::temporaryDirectory to the given path. -# If the path is relative, make it absolute. If the file exists but -# is not a dir, then return an error. -# -# If tcltest::temporaryDirectory does not already exist, create it. -# If you cannot create it, then return an error (the file mkdir isn't -# caught and will propagate). -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::temporaryDirectory -# -# Side effects: -# None. - -proc tcltest::temporaryDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::temporaryDirectory - } - set tcltest::temporaryDirectory $dir - - MakeAbsolutePath tcltest::temporaryDirectory - set tmpDirError "bad argument for temporary directory: " - - if {[file exists $tcltest::temporaryDirectory]} { - tcltest::CheckDirectory rw $tcltest::temporaryDirectory $tmpDirError - } else { - file mkdir $tcltest::temporaryDirectory - } - - normalizePath tcltest::temporaryDirectory -} - -# tcltest::testsDirectory -- -# -# Set tcltest::testsDirectory to the given path. -# If the path is relative, make it absolute. If the file exists but -# is not a dir, then return an error. -# -# If tcltest::testsDirectory does not already exist, return an error. -# -# Arguments: -# directory name -# -# Results: -# content of tcltest::testsDirectory -# -# Side effects: -# None. - -proc tcltest::testsDirectory { {dir ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::testsDirectory - } - - set tcltest::testsDirectory $dir - - MakeAbsolutePath tcltest::testsDirectory - set testDirError "bad argument for tests directory: " - - if {[file exists $tcltest::testsDirectory]} { - tcltest::CheckDirectory r $tcltest::testsDirectory $testDirError - } else { - set msg "$testDirError \"$tcltest::testsDirectory\" does not exist" - error $msg - } - - normalizePath tcltest::testsDirectory -} - -# tcltest::singleProcess -- -# -# sets tcltest::singleProcess to the value provided. -# -# Arguments: -# value for singleProcess: -# 1 = source each test file into the current process -# 0 = run each test file in its own process -# -# Results: -# content of tcltest::singleProcess -# -# Side effects: -# None. - -proc tcltest::singleProcess { {value ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::singleProcess - } - set tcltest::singleProcess $value -} - -# tcltest::interpreter -- -# -# the interpreter name stored in tcltest::tcltest -# -# Arguments: -# executable name -# -# Results: -# content of tcltest::tcltest -# -# Side effects: -# None. - -proc tcltest::interpreter { {interp ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::tcltest - } - set tcltest::tcltest $interp -} - -# tcltest::mainThread -- -# -# sets or returns the thread id stored in tcltest::mainThread -# -# Arguments: -# thread id -# -# Results: -# content of tcltest::mainThread -# -# Side effects: -# None. - -proc tcltest::mainThread { {threadid ""} } { - if {[llength [info level 0]] == 1} { - return $tcltest::mainThread - } - set tcltest::mainThread $threadid -} - -##################################################################### - -# tcltest::AddToSkippedBecause -- -# -# Increments the variable used to track how many tests were skipped -# because of a particular constraint. -# -# Arguments: -# constraint The name of the constraint to be modified -# -# Results: -# Modifies tcltest::skippedBecause; sets the variable to 1 if didn't -# previously exist - otherwise, it just increments it. -# -# Side effects: -# None. - -proc tcltest::AddToSkippedBecause { constraint {value 1}} { - # add the constraint to the list of constraints that kept tests - # from running - - if {[info exists tcltest::skippedBecause($constraint)]} { - incr tcltest::skippedBecause($constraint) $value - } else { - set tcltest::skippedBecause($constraint) $value - } - return -} - -# tcltest::PrintError -- -# -# Prints errors to tcltest::errorChannel and then flushes that -# channel, making sure that all messages are < 80 characters per line. -# -# Arguments: -# errorMsg String containing the error to be printed -# -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::PrintError {errorMsg} { - set InitialMessage "Error: " - set InitialMsgLen [string length $InitialMessage] - puts -nonewline [errorChannel] $InitialMessage - - # Keep track of where the end of the string is. - set endingIndex [string length $errorMsg] - - if {$endingIndex < 80} { - puts [errorChannel] $errorMsg - } else { - # Print up to 80 characters on the first line, including the - # InitialMessage. - set beginningIndex [string last " " [string range $errorMsg 0 \ - [expr {80 - $InitialMsgLen}]]] - puts [errorChannel] [string range $errorMsg 0 $beginningIndex] - - while {$beginningIndex != "end"} { - puts -nonewline [errorChannel] \ - [string repeat " " $InitialMsgLen] - if {[expr {$endingIndex - $beginningIndex}] < 72} { - puts [errorChannel] [string trim \ - [string range $errorMsg $beginningIndex end]] - set beginningIndex end - } else { - set newEndingIndex [expr [string last " " [string range \ - $errorMsg $beginningIndex \ - [expr {$beginningIndex + 72}]]] + $beginningIndex] - if {($newEndingIndex <= 0) \ - || ($newEndingIndex <= $beginningIndex)} { - set newEndingIndex end - } - puts [errorChannel] [string trim \ - [string range $errorMsg \ - $beginningIndex $newEndingIndex]] - set beginningIndex $newEndingIndex - } - } - } - flush [errorChannel] - return -} - -if {[namespace inscope tcltest info procs initConstraintsHook] == {}} { - proc tcltest::initConstraintsHook {} {} -} - -# tcltest::safeFetch -- -# -# The following trace procedure makes it so that we can safely refer to -# non-existent members of the tcltest::testConstraints array without -# causing an error. Instead, reading a non-existent member will return -# 0. This is necessary because tests are allowed to use constraint "X" -# without ensuring that tcltest::testConstraints("X") is defined. -# -# Arguments: -# n1 - name of the array (tcltest::testConstraints) -# n2 - array key value (constraint name) -# op - operation performed on tcltest::testConstraints (generally r) -# -# Results: -# none -# -# Side effects: -# sets tcltest::testConstraints($n2) to 0 if it's referenced but never -# before used - -proc tcltest::safeFetch {n1 n2 op} { - DebugPuts 3 "entering safeFetch $n1 $n2 $op" - if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { - tcltest::testConstraint $n2 0 - } -} - -# tcltest::initConstraints -- -# -# Check constraint information that will determine which tests -# to run. To do this, create an array tcltest::testConstraints. Each -# element has a 0 or 1 value. If the element is "true" then tests -# with that constraint will be run, otherwise tests with that constraint -# will be skipped. See the tcltest man page for the list of built-in -# constraints defined in this procedure. -# -# Arguments: -# none -# -# Results: -# The tcltest::testConstraints array is reset to have an index for -# each built-in test constraint. -# -# Side Effects: -# None. -# - -proc tcltest::initConstraints {} { - global tcl_platform tcl_interactive tk_version - - # Safely refer to non-existent members of the tcltest::testConstraints - # array without causing an error. - trace variable tcltest::testConstraints r tcltest::safeFetch - - tcltest::initConstraintsHook - - tcltest::testConstraint singleTestInterp [singleProcess] - - # All the 'pc' constraints are here for backward compatibility and are not - # documented. They have been replaced with equivalent 'win' constraints. - - tcltest::testConstraint unixOnly \ - [string equal $tcl_platform(platform) "unix"] - tcltest::testConstraint macOnly \ - [string equal $tcl_platform(platform) "macintosh"] - tcltest::testConstraint pcOnly \ - [string equal $tcl_platform(platform) "windows"] - tcltest::testConstraint winOnly \ - [string equal $tcl_platform(platform) "windows"] - - tcltest::testConstraint unix [tcltest::testConstraint unixOnly] - tcltest::testConstraint mac [tcltest::testConstraint macOnly] - tcltest::testConstraint pc [tcltest::testConstraint pcOnly] - tcltest::testConstraint win [tcltest::testConstraint winOnly] - - tcltest::testConstraint unixOrPc \ - [expr {[tcltest::testConstraint unix] \ - || [tcltest::testConstraint pc]}] - tcltest::testConstraint macOrPc \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint pc]}] - tcltest::testConstraint unixOrWin \ - [expr {[tcltest::testConstraint unix] \ - || [tcltest::testConstraint win]}] - tcltest::testConstraint macOrWin \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint win]}] - tcltest::testConstraint macOrUnix \ - [expr {[tcltest::testConstraint mac] \ - || [tcltest::testConstraint unix]}] - - tcltest::testConstraint nt [string equal $tcl_platform(os) "Windows NT"] - tcltest::testConstraint 95 [string equal $tcl_platform(os) "Windows 95"] - tcltest::testConstraint 98 [string equal $tcl_platform(os) "Windows 98"] - - # The following Constraints switches are used to mark tests that should - # work, but have been temporarily disabled on certain platforms because - # they don't and we haven't gotten around to fixing the underlying - # problem. - - tcltest::testConstraint tempNotPc \ - [expr {![tcltest::testConstraint pc]}] - tcltest::testConstraint tempNotWin \ - [expr {![tcltest::testConstraint win]}] - tcltest::testConstraint tempNotMac \ - [expr {![tcltest::testConstraint mac]}] - tcltest::testConstraint tempNotUnix \ - [expr {![tcltest::testConstraint unix]}] - - # The following Constraints switches are used to mark tests that crash on - # certain platforms, so that they can be reactivated again when the - # underlying problem is fixed. - - tcltest::testConstraint pcCrash \ - [expr {![tcltest::testConstraint pc]}] - tcltest::testConstraint winCrash \ - [expr {![tcltest::testConstraint win]}] - tcltest::testConstraint macCrash \ - [expr {![tcltest::testConstraint mac]}] - tcltest::testConstraint unixCrash \ - [expr {![tcltest::testConstraint unix]}] - - # Skip empty tests - - tcltest::testConstraint emptyTest 0 - - # By default, tests that expose known bugs are skipped. - - tcltest::testConstraint knownBug 0 - - # By default, non-portable tests are skipped. - - tcltest::testConstraint nonPortable 0 - - # Some tests require user interaction. - - tcltest::testConstraint userInteraction 0 - - # Some tests must be skipped if the interpreter is not in interactive mode - - if {[info exists tcl_interactive]} { - tcltest::testConstraint interactive $::tcl_interactive - } else { - tcltest::testConstraint interactive 0 - } - - # Some tests can only be run if the installation came from a CD image - # instead of a web image - # Some tests must be skipped if you are running as root on Unix. - # Other tests can only be run if you are running as root on Unix. - - tcltest::testConstraint root 0 - tcltest::testConstraint notRoot 1 - set user {} - if {[string equal $tcl_platform(platform) "unix"]} { - catch {set user [exec whoami]} - if {[string equal $user ""]} { - catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} - } - if {([string equal $user "root"]) || ([string equal $user ""])} { - tcltest::testConstraint root 1 - tcltest::testConstraint notRoot 0 - } - } - - # Set nonBlockFiles constraint: 1 means this platform supports - # ting files into nonblocking mode. - - if {[catch {set f [open defs r]}]} { - tcltest::testConstraint nonBlockFiles 1 - } else { - if {[catch {fconfigure $f -blocking off}] == 0} { - tcltest::testConstraint nonBlockFiles 1 - } else { - tcltest::testConstraint nonBlockFiles 0 - } - close $f - } - - # Set asyncPipeClose constraint: 1 means this platform supports - # async flush and async close on a pipe. - # - # Test for SCO Unix - cannot run async flushing tests because a - # potential problem with select is apparently interfering. - # (Mark Diekhans). - - if {[string equal $tcl_platform(platform) "unix"]} { - if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { - tcltest::testConstraint asyncPipeClose 0 - } else { - tcltest::testConstraint asyncPipeClose 1 - } - } else { - tcltest::testConstraint asyncPipeClose 1 - } - - # Test to see if we have a broken version of sprintf with respect - # to the "e" format of floating-point numbers. - - tcltest::testConstraint eformat 1 - if {![string equal "[format %g 5e-5]" "5e-05"]} { - tcltest::testConstraint eformat 0 - } - - # Test to see if execed commands such as cat, echo, rm and so forth are - # present on this machine. - - tcltest::testConstraint unixExecs 1 - if {[string equal $tcl_platform(platform) "macintosh"]} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([string equal $tcl_platform(platform) "windows"])} { - if {[catch {exec cat defs}] == 1} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec echo hello}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec sh -c echo hello}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec wc defs}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {[tcltest::testConstraint unixExecs] == 1} { - exec echo hello > removeMe - if {[catch {exec rm removeMe}] == 1} { - tcltest::testConstraint unixExecs 0 - } - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec sleep 1}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec fgrep unixExecs defs}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec ps}] == 1)} { - tcltest::testConstraint unixExecs 0 - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec echo abc > removeMe}] == 0) && \ - ([catch {exec chmod 644 removeMe}] == 1) && \ - ([catch {exec rm removeMe}] == 0)} { - tcltest::testConstraint unixExecs 0 - } else { - catch {exec rm -f removeMe} - } - if {([tcltest::testConstraint unixExecs] == 1) && \ - ([catch {exec mkdir removeMe}] == 1)} { - tcltest::testConstraint unixExecs 0 - } else { - catch {exec rm -r removeMe} - } - } - - # Locate tcltest executable - - if {![info exists tk_version]} { - set tcltest::tcltest [info nameofexecutable] - - if {$tcltest::tcltest == "{}"} { - set tcltest::tcltest {} - } - } - - tcltest::testConstraint stdio 0 - catch { - catch {file delete -force tmp} - set f [open tmp w] - puts $f { - exit - } - close $f - - set f [open "|[list $tcltest tmp]" r] - close $f - - tcltest::testConstraint stdio 1 - } - catch {file delete -force tmp} - - # Deliberately call socket with the wrong number of arguments. The error - # message you get will indicate whether sockets are available on this - # system. - - catch {socket} msg - tcltest::testConstraint socket \ - [expr {$msg != "sockets are not available on this system"}] - - # Check for internationalization - - if {[info commands testlocale] == ""} { - # No testlocale command, no tests... - tcltest::testConstraint hasIsoLocale 0 - } else { - tcltest::testConstraint hasIsoLocale \ - [string length [tcltest::set_iso8859_1_locale]] - tcltest::restore_locale - } -} - -##################################################################### - -# Handle command line arguments (from argv) and default arg settings -# (in TCLTEST_OPTIONS). - -# tcltest::PrintUsageInfoHook -# -# Hook used for customization of display of usage information. -# - -if {[namespace inscope tcltest info procs PrintUsageInfoHook] == {}} { - proc tcltest::PrintUsageInfoHook {} {} -} - -# tcltest::PrintUsageInfo -# -# Prints out the usage information for package tcltest. This can be -# customized with the redefinition of tcltest::PrintUsageInfoHook. -# -# Arguments: -# none -# -# Results: -# none -# -# Side Effects: -# none - -proc tcltest::PrintUsageInfo {} { - puts [format "Usage: [file tail [info nameofexecutable]] \ - script ?-help? ?flag value? ... \n\ - Available flags (and valid input values) are: \n\ - -help \t Display this usage information. \n\ - -verbose level \t Takes any combination of the values \n\ - \t 'p', 's', 'b', 't' and 'e'. Test suite will \n\ - \t display all passed tests if 'p' is \n\ - \t specified, all skipped tests if 's' \n\ - \t is specified, the bodies of \n\ - \t failed tests if 'b' is specified, \n\ - \t and when tests start if 't' is specified. \n\ - \t ErrorInfo is displayed if 'e' is specified. \n\ - \t The default value is 'b'. \n\ - -constraints list\t Do not skip the listed constraints\n\ - -limitconstraints bool\t Only run tests with the constraints\n\ - \t listed in -constraints.\n\ - -match pattern \t Run all tests within the specified \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -skip pattern \t Skip all tests within the set of \n\ - \t specified tests (via -match) and \n\ - \t files that match the glob pattern \n\ - \t given. \n\ - -file pattern \t Run tests in all test files that \n\ - \t match the glob pattern given. \n\ - -notfile pattern\t Skip all test files that match the \n\ - \t glob pattern given. \n\ - -relateddir pattern\t Run tests in directories that match \n\ - \t the glob pattern given. \n\ - -asidefromdir pattern\t Skip tests in directories that match \n\ - \t the glob pattern given.\n\ - -preservecore level \t If 2, save any core files produced \n\ - \t during testing in the directory \n\ - \t specified by -tmpdir. If 1, notify the\n\ - \t user if core files are created. The default \n\ - \t is $tcltest::preserveCore. \n\ - -tmpdir directory\t Save temporary files in the specified\n\ - \t directory. The default value is \n\ - \t $tcltest::temporaryDirectory. \n\ - -testdir directories\t Search tests in the specified\n\ - \t directories. The default value is \n\ - \t $tcltest::testsDirectory. \n\ - -outfile file \t Send output from test runs to the \n\ - \t specified file. The default is \n\ - \t stdout. \n\ - -errfile file \t Send errors from test runs to the \n\ - \t specified file. The default is \n\ - \t stderr. \n\ - -loadfile file \t Read the script to load the tested \n\ - \t commands from the specified file. \n\ - -load script \t Specifies the script to load the tested \n\ - \t commands. \n\ - -debug level \t Internal debug flag."] - tcltest::PrintUsageInfoHook - return -} - -# tcltest::processCmdLineArgsFlagsHook -- -# -# This hook is used to add to the list of command line arguments that are -# processed by tcltest::ProcessFlags. It is called at the beginning of -# ProcessFlags. -# - -if {[namespace inscope tcltest info procs processCmdLineArgsAddFlagsHook] == {}} { - proc tcltest::processCmdLineArgsAddFlagsHook {} {} -} - -# tcltest::processCmdLineArgsHook -- -# -# This hook is used to actually process the flags added by -# tcltest::processCmdLineArgsAddFlagsHook. It is called at the end of -# ProcessFlags. -# -# Arguments: -# flags The flags that have been pulled out of argv -# - -if {[namespace inscope tcltest info procs processCmdLineArgsHook] == {}} { - proc tcltest::processCmdLineArgsHook {flag} {} -} - -# tcltest::ProcessFlags -- -# -# process command line arguments supplied in the flagArray - this is -# called by processCmdLineArgs -# modifies tcltest variables according to the content of the flagArray. -# -# Arguments: -# flagArray - array containing name/value pairs of flags -# -# Results: -# sets tcltest variables according to their values as defined by -# flagArray -# -# Side effects: -# None. - -proc tcltest::ProcessFlags {flagArray} { - # Process -help first - if {[lsearch -exact $flagArray {-help}] != -1} { - tcltest::PrintUsageInfo - exit 1 - } - - catch {array set flag $flagArray} - - # -help is not listed since it has already been processed - lappend defaultFlags -verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints -testdir \ - -load -loadfile -asidefromdir \ - -relateddir -singleproc - set defaultFlags [concat $defaultFlags \ - [tcltest::processCmdLineArgsAddFlagsHook ]] - - # Set tcltest::verbose to the arg of the -verbose flag, if given - if {[info exists flag(-verbose)]} { - tcltest::verbose $flag(-verbose) - } - - # Set tcltest::match to the arg of the -match flag, if given. - if {[info exists flag(-match)]} { - tcltest::match $flag(-match) - } - - # Set tcltest::skip to the arg of the -skip flag, if given - if {[info exists flag(-skip)]} { - tcltest::skip $flag(-skip) - } - - # Handle the -file and -notfile flags - if {[info exists flag(-file)]} { - tcltest::matchFiles $flag(-file) - } - if {[info exists flag(-notfile)]} { - tcltest::skipFiles $flag(-notfile) - } - - # Handle -relateddir and -asidefromdir flags - if {[info exists flag(-relateddir)]} { - tcltest::matchDirectories $flag(-relateddir) - } - if {[info exists flag(-asidefromdir)]} { - tcltest::skipDirectories $flag(-asidefromdir) - } - - # Use the -constraints flag, if given, to turn on constraints that are - # turned off by default: userInteractive knownBug nonPortable. This - # code fragment must be run after constraints are initialized. - - if {[info exists flag(-constraints)]} { - foreach elt $flag(-constraints) { - tcltest::testConstraint $elt 1 - } - } - - # Use the -limitconstraints flag, if given, to tell the harness to limit - # tests run to those that were specified using the -constraints flag. If - # the -constraints flag was not specified, print out an error and exit. - if {[info exists flag(-limitconstraints)]} { - if {![info exists flag(-constraints)]} { - set msg "-limitconstraints flag can only be used with -constraints" - error $msg - } - tcltest::limitConstraints $flag(-limitconstraints) - } - - # Set the tcltest::temporaryDirectory to the arg of -tmpdir, if - # given. - - if {[info exists flag(-tmpdir)]} { - tcltest::temporaryDirectory $flag(-tmpdir) - } - - # Set the tcltest::testsDirectory to the arg of -testdir, if - # given. - - if {[info exists flag(-testdir)]} { - tcltest::testsDirectory $flag(-testdir) - } - - # If an alternate error or output files are specified, change the - # default channels. - - if {[info exists flag(-outfile)]} { - tcltest::outputFile $flag(-outfile) - } - - if {[info exists flag(-errfile)]} { - tcltest::errorFile $flag(-errfile) - } - - # If a load script was specified, either directly or through - # a file, remember it for later usage. - - if {[info exists flag(-load)] && \ - ([lsearch -exact $flagArray -load] > \ - [lsearch -exact $flagArray -loadfile])} { - tcltest::loadScript $flag(-load) - } - - if {[info exists flag(-loadfile)] && \ - ([lsearch -exact $flagArray -loadfile] > \ - [lsearch -exact $flagArray -load]) } { - tcltest::loadFile $flag(-loadfile) - } - - # If the user specifies debug testing, print out extra information during - # the run. - if {[info exists flag(-debug)]} { - tcltest::debug $flag(-debug) - } - - # Handle -preservecore - if {[info exists flag(-preservecore)]} { - tcltest::preserveCore $flag(-preservecore) - } - - # Handle -singleproc flag - if {[info exists flag(-singleproc)]} { - tcltest::singleProcess $flag(-singleproc) - } - - # Call the hook - tcltest::processCmdLineArgsHook [array get flag] - return -} - -# tcltest::processCmdLineArgs -- -# -# Use command line args to set tcltest namespace variables. -# -# This procedure must be run after constraints are initialized, because -# some constraints can be overridden. -# -# Set variables based on the contents of the environment variable -# TCLTEST_OPTIONS first, then override with command-line options, if -# specified. -# -# Arguments: -# none -# -# Results: -# Sets the above-named variables in the tcltest namespace. -# -# Side Effects: -# None. -# - -proc tcltest::processCmdLineArgs {} { - global argv - - # If the TCLTEST_OPTIONS environment variable exists, parse it first, then - # the argv list. The command line argument parsing will be a two-pass - # affair from now on, so that TCLTEST_OPTIONS contain the default options. - # These can be overridden by the command line flags. - - if {[info exists ::env(TCLTEST_OPTIONS)]} { - tcltest::ProcessFlags $::env(TCLTEST_OPTIONS) - } - - # The "argv" var doesn't exist in some cases, so use {}. - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv - } - - tcltest::ProcessFlags $flagArray - - # Spit out everything you know if we're at a debug level 2 or greater - DebugPuts 2 "Flags passed into tcltest:" - if {[info exists ::env(TCLTEST_OPTIONS)]} { - DebugPuts 2 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" - } - if {[info exists argv]} { - DebugPuts 2 " argv: $argv" - } - DebugPuts 2 "tcltest::debug = [tcltest::debug]" - DebugPuts 2 "tcltest::testsDirectory = [tcltest::testsDirectory]" - DebugPuts 2 "tcltest::workingDirectory = [tcltest::workingDirectory]" - DebugPuts 2 "tcltest::temporaryDirectory = [tcltest::temporaryDirectory]" - DebugPuts 2 "tcltest::outputChannel = [outputChannel]" - DebugPuts 2 "tcltest::errorChannel = [errorChannel]" - DebugPuts 2 "Original environment (tcltest::originalEnv):" - DebugPArray 2 tcltest::originalEnv - DebugPuts 2 "Constraints:" - DebugPArray 2 tcltest::testConstraints - return -} - -##################################################################### - -# Code to run the tests goes here. - -# tcltest::testPuts -- -# -# Used to redefine puts in test environment. -# Stores whatever goes out on stdout in tcltest::outData and stderr in -# tcltest::errData before sending it on to the regular puts. -# -# Arguments: -# same as standard puts -# -# Results: -# none -# -# Side effects: -# Intercepts puts; data that would otherwise go to stdout, stderr, or -# file channels specified in tcltest::outputChannel and errorChannel does -# not get sent to the normal puts function. - -proc tcltest::testPuts {args} { - set len [llength $args] - if {$len == 1} { - # Only the string to be printed is specified - append tcltest::outData "[lindex $args 0]\n" - return -# return [tcltest::normalPuts [lindex $args 0]] - } elseif {$len == 2} { - # Either -nonewline or channelId has been specified - if {[regexp {^-nonewline} [lindex $args 0]]} { - append tcltest::outData "[lindex $args end]" - return -# return [tcltest::normalPuts -nonewline [lindex $args end]] - } else { - set channel [lindex $args 0] - } - } elseif {$len == 3} { - if {[lindex $args 0] == "-nonewline"} { - # Both -nonewline and channelId are specified, unless it's an - # error. -nonewline is supposed to be argv[0]. - set channel [lindex $args 1] - } - } - - if {[info exists channel]} { - if {($channel == [outputChannel]) || ($channel == "stdout")} { - append tcltest::outData "[lindex $args end]\n" - } elseif {($channel == [errorChannel]) || ($channel == "stderr")} { - append tcltest::errData "[lindex $args end]\n" - } - return - # return [tcltest::normalPuts [lindex $args 0] [lindex $args end]] - } - - # If we haven't returned by now, we don't know how to handle the input. - # Let puts handle it. - return [eval tcltest::normalPuts $args] -} - -# tcltest::testEval -- -# -# Evaluate the script in the test environment. If ignoreOutput is -# false, store data sent to stderr and stdout in tcltest::outData and -# tcltest::errData. Otherwise, ignore this output altogether. -# -# Arguments: -# script Script to evaluate -# ?ignoreOutput? Indicates whether or not to ignore output sent to -# stdout & stderr -# -# Results: -# result from running the script -# -# Side effects: -# Empties the contents of tcltest::outData and tcltest::errData before -# running a test if ignoreOutput is set to 0. - -proc tcltest::testEval {script {ignoreOutput 1}} { - DebugPuts 3 "testEval called" - if {!$ignoreOutput} { - set tcltest::outData {} - set tcltest::errData {} - uplevel rename ::puts tcltest::normalPuts - uplevel rename tcltest::testPuts ::puts - } - set result [uplevel $script] - if {!$ignoreOutput} { - uplevel rename ::puts tcltest::testPuts - uplevel rename tcltest::normalPuts ::puts - } - return $result -} - -# compareStrings -- -# -# compares the expected answer to the actual answer, depending on the -# mode provided. Mode determines whether a regexp, exact, or glob -# comparison is done. -# -# Arguments: -# actual - string containing the actual result -# expected - pattern to be matched against -# mode - type of comparison to be done -# -# Results: -# result of the match -# -# Side effects: -# None. - -proc tcltest::compareStrings {actual expected mode} { - switch -- $mode { - exact { - set retval [string equal $actual $expected] - } - glob { - set retval [string match $expected $actual] - } - regexp { - set retval [regexp -- $expected $actual] - } - } - return $retval -} - - -# -# tcltest::substArguments list -# -# This helper function takes in a list of words, then perform a -# substitution on the list as though each word in the list is a -# separate argument to the Tcl function. For example, if this -# function is invoked as: -# -# substArguments {$a {$a}} -# -# Then it is as though the function is invoked as: -# -# substArguments $a {$a} -# -# This code is adapted from Paul Duffin's function "SplitIntoWords". -# The original function can be found on: -# -# http://purl.org/thecliff/tcl/wiki/858.html -# -# Results: -# a list containing the result of the substitution -# -# Exceptions: -# An error may occur if the list containing unbalanced quote or -# unknown variable. -# -# Side Effects: -# None. -# - -proc tcltest::substArguments {argList} { - - # We need to split the argList up into tokens but cannot use - # list operations as they throw away some significant - # quoting, and [split] ignores braces as it should. - # Therefore what we do is gradually build up a string out of - # whitespace seperated strings. We cannot use [split] to - # split the argList into whitespace seperated strings as it - # throws away the whitespace which maybe important so we - # have to do it all by hand. - - set result {} - set token "" - - while {[string length $argList]} { - # Look for the next word containing a quote: " { } - if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ - $argList all]} { - # Get the text leading up to this word, but not - # including this word, from the argList. - set text [string range $argList 0 \ - [expr {[lindex $all 0] - 1}]] - # Get the word with the quote - set word [string range $argList \ - [lindex $all 0] [lindex $all 1]] - - # Remove all text up to and including the word from the - # argList. - set argList [string range $argList \ - [expr {[lindex $all 1] + 1}] end] - } else { - # Take everything up to the end of the argList. - set text $argList - set word {} - set argList {} - } - - if {$token != {}} { - # If we saw a word with quote before, then there is a - # multi-word token starting with that word. In this case, - # add the text and the current word to this token. - append token $text $word - } else { - # Add the text to the result. There is no need to parse - # the text because it couldn't be a part of any multi-word - # token. Then start a new multi-word token with the word - # because we need to pass this token to the Tcl parser to - # check for balancing quotes - append result $text - set token $word - } - - if { [catch {llength $token} length] == 0 && $length == 1} { - # The token is a valid list so add it to the result. - # lappend result [string trim $token] - append result \{$token\} - set token {} - } - } - - # If the last token has not been added to the list then there - # is a problem. - if { [string length $token] } { - error "incomplete token \"$token\"" - } - - return $result -} - - -# tcltest::test -- -# -# This procedure runs a test and prints an error message if the test fails. -# If tcltest::verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# tcltest::match variable, if it matches an element in -# tcltest::skip, or if one of the elements of "constraints" turns -# out not to be true. -# -# If testLevel is 1, then this is a top level test, and we record pass/fail -# information; otherwise, this information is not logged and is not added to -# running totals. -# -# Attributes: -# Only description is a required attribute. All others are optional. -# Default values are indicated. -# -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "tcltest::testConstraints". If any -# of these elements is zero, the test is -# skipped. This attribute is optional; default is {} -# body - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. This attribute is optional; -# default is {} -# result - Expected result from script. This attribute is -# optional; default is {}. -# output - Expected output sent to stdout. This attribute -# is optional; default is {}. -# errorOutput - Expected output sent to stderr. This attribute -# is optional; default is {}. -# returnCodes - Expected return codes. This attribute is -# optional; default is {0 2}. -# setup - Code to run before $script (above). This -# attribute is optional; default is {}. -# cleanup - Code to run after $script (above). This -# attribute is optional; default is {}. -# match - specifies type of matching to do on result, -# output, errorOutput; this must be one of: exact, -# glob, regexp. default is exact. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# -# Results: -# 0 if the command ran successfully; 1 otherwise. -# -# Side effects: -# None. -# - -proc tcltest::test {name description args} { - DebugPuts 3 "Test $name $args" - - incr tcltest::testLevel - - # Pre-define everything to null except output and errorOutput. We - # determine whether or not to trap output based on whether or not these - # variables (output & errorOutput) are defined. - foreach item {constraints setup cleanup body result returnCodes match} { - set $item {} - } - - # Set the default match mode - set match exact - - # Set the default match values for return codes (0 is the standard expected - # return value if everything went well; 2 represents 'return' being used in - # the test script). - set returnCodes [list 0 2] - - # The old test format can't have a 3rd argument (constraints or script) - # that starts with '-'. - if {[llength $args] == 0} { - puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}" - incr tcltest::testLevel -1 - return 1 - } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} { - - if {[llength $args] == 1} { - set list [substArguments [lindex $args 0]] - foreach {element value} $list { - set testAttributes($element) $value - } - foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { - if {[info exists testAttributes([subst -$item])]} { - set testAttributes([subst -$item]) \ - [uplevel concat $testAttributes([subst -$item])] - } - } - } else { - array set testAttributes $args - } - - set validFlags {-setup -cleanup -body -result -returnCodes -match \ - -output -errorOutput -constraints} - - foreach flag [array names testAttributes] { - if {[lsearch -exact $validFlags $flag] == -1} { - puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test" - incr tcltest::testLevel -1 - return 1 - } - } - - # store whatever the user gave us - foreach item [array names testAttributes] { - set [string trimleft $item "-"] $testAttributes($item) - } - - # Check the values supplied for -match - if {[lsearch {regexp glob exact} $match] == -1} { - puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}" - incr tcltest::testLevel -1 - return 1 - } - - # Replace symbolic valies supplied for -returnCodes - regsub -nocase normal $returnCodes 0 returnCodes - regsub -nocase error $returnCodes 1 returnCodes - regsub -nocase return $returnCodes 2 returnCodes - regsub -nocase break $returnCodes 3 returnCodes - regsub -nocase continue $returnCodes 4 returnCodes - } else { - # This is parsing for the old test command format; it is here for - # backward compatibility. - set result [lindex $args end] - if {[llength $args] == 2} { - set body [lindex $args 0] - } elseif {[llength $args] == 3} { - set constraints [lindex $args 0] - set body [lindex $args 1] - } else { - puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}" - incr tcltest::testLevel -1 - return 1 - } - } - - set setupFailure 0 - set cleanupFailure 0 - - # Run the setup script - if {[catch {uplevel $setup} setupMsg]} { - set setupFailure 1 - } - - # run the test script - set command [list tcltest::runTest $name $description $body \ - $result $constraints] - if {!$setupFailure} { - if {[info exists output] || [info exists errorOutput]} { - set testResult [uplevel tcltest::testEval [list $command] 0] - } else { - set testResult [uplevel tcltest::testEval [list $command] 1] - } - } else { - set testResult setupFailure - } - - # Run the cleanup code - if {[catch {uplevel $cleanup} cleanupMsg]} { - set cleanupFailure 1 - } - - # If testResult is an empty list, then the test was skipped - if {$testResult != {}} { - set coreFailure 0 - set coreMsg "" - # check for a core file first - if one was created by the test, then - # the test failed - if {$tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - if {[file exists [file join [tcltest::workingDirectory] core]]} { - # There's only a test failure if there is a core file and (1) - # there previously wasn't one or (2) the new one is different - # from the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join [tcltest::workingDirectory] core]]} { - set coreFailure 1 - } - } else { - set coreFailure 1 - } - - if {($tcltest::preserveCore > 1) && ($coreFailure)} { - append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]" - catch {file rename -force \ - [file join [tcltest::workingDirectory] core] \ - [file join $tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - append coreMsg "\nError: Problem renaming core file: $msg" - } - } - } - array set tcl_platform $currentTclPlatform - } - - set actualAnswer [lindex $testResult 0] - set code [lindex $testResult end] - - # If expected output/error strings exist, we have to compare - # them. If the comparison fails, then so did the test. - set outputFailure 0 - set errorFailure 0 - if {[info exists output]} { - set outputFailure [expr ![compareStrings $tcltest::outData \ - $output $match]] - } - if {[info exists errorOutput]} { - set errorFailure [expr ![compareStrings $tcltest::errData \ - $errorOutput $match]] - } - - set testFailed 1 - set codeFailure 0 - set scriptFailure 0 - - # check if the return code matched the expected return code - if {[lsearch -exact $returnCodes $code] == -1} { - set codeFailure 1 - } - - # check if the answer matched the expected answer - if {[compareStrings $actualAnswer $result $match] == 0} { - set scriptFailure 1 - } - - # if we didn't experience any failures, then we passed - if {!($setupFailure || $cleanupFailure || $coreFailure || \ - $outputFailure || $errorFailure || $codeFailure || \ - $scriptFailure)} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Passed) - if {[tcltest::isVerbose pass]} { - puts [outputChannel] "++++ $name PASSED" - } - } - set testFailed 0 - } - - if {$testFailed} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Failed) - } - set tcltest::currentFailure true - if {![tcltest::isVerbose body]} { - set body "" - } - puts [outputChannel] "\n==== $name [string trim $description] FAILED" - if {$body != ""} { - puts [outputChannel] "==== Contents of test case:" - puts [outputChannel] $body - } - if {$setupFailure} { - puts [outputChannel] "---- Test setup failed:\n$setupMsg" - } - if {$scriptFailure} { - puts [outputChannel] "---- Result was:\n$actualAnswer" - puts [outputChannel] "---- Result should have been ($match matching):\n$result" - } - if {$codeFailure} { - switch -- $code { - 0 { set msg "Test completed normally" } - 1 { set msg "Test generated error" } - 2 { set msg "Test generated return exception" } - 3 { set msg "Test generated break exception" } - 4 { set msg "Test generated continue exception" } - default { set msg "Test generated exception" } - } - puts [outputChannel] "---- $msg; Return code was: $code" - puts [outputChannel] "---- Return code should have been one of: $returnCodes" - if {[tcltest::isVerbose error]} { - if {[info exists ::errorInfo]} { - puts [outputChannel] "---- errorInfo: $::errorInfo" - puts [outputChannel] "---- errorCode: $::errorCode" - } - } - } - if {$outputFailure} { - puts [outputChannel] "---- Output was:\n$tcltest::outData" - puts [outputChannel] "---- Output should have been ($match matching):\n$output" - } - if {$errorFailure} { - puts [outputChannel] "---- Error output was:\n$tcltest::errData" - puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput" - } - if {$cleanupFailure} { - puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" - } - if {$coreFailure} { - puts [outputChannel] "---- Core file produced while running test! $coreMsg" - } - puts [outputChannel] "==== $name FAILED\n" - - } - } - - incr tcltest::testLevel -1 - return 0 -} - - -# runTest -- -# -# This is the defnition of the version 1.0 test routine for tcltest. It is -# provided here for backward compatibility. It is also used as the 'backbone' -# of the test procedure, as in, this is where all the work really gets done. -# -# This procedure runs a test and prints an error message if the test fails. -# If tcltest::verbose has been set, it also prints a message even if the -# test succeeds. The test will be skipped if it doesn't match the -# tcltest::match variable, if it matches an element in -# tcltest::skip, or if one of the elements of "constraints" turns -# out not to be true. -# -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to -# help humans understand what it does. -# constraints - A list of one or more keywords, each of -# which must be the name of an element in -# the array "tcltest::testConstraints". If any of these -# elements is zero, the test is skipped. -# This argument may be omitted. -# script - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. -# expectedAnswer - Expected result from script. -# -# Behavior depends on the value of testLevel; if testLevel is 1 (top level), -# then events are logged and we track the number of tests run/skipped and why. -# Otherwise, we don't track this information. -# -# Results: -# empty list if test is skipped; otherwise returns list containing -# actual returned value from the test and the return code. -# -# Side Effects: -# none. -# - -proc tcltest::runTest {name description script expectedAnswer constraints} { - - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Total) - } - - # skip the test if it's name matches an element of skip - foreach pattern $tcltest::skip { - if {[string match $pattern $name]} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedSkip} - } - return - } - } - - # skip the test if it's name doesn't match any element of match - if {[llength $tcltest::match] > 0} { - set ok 0 - foreach pattern $tcltest::match { - if {[string match $pattern $name]} { - set ok 1 - break - } - } - if {!$ok} { - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - DebugDo 1 {tcltest::AddToSkippedBecause userSpecifiedNonMatch} - } - return - } - } - - DebugPuts 3 "Running $name ($description) {$script} {$expectedAnswer} $constraints" - - if {$constraints == {}} { - # If we're limited to the listed constraints and there aren't any - # listed, then we shouldn't run the test. - if {$tcltest::limitConstraints} { - tcltest::AddToSkippedBecause userSpecifiedLimitConstraint - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - } - return - } - } else { - # "constraints" argument exists; - # make sure that the constraints are satisfied. - - set doTest 0 - if {[string match {*[$\[]*} $constraints] != 0} { - # full expression, e.g. {$foo > [info tclversion]} - catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} { - # something like {a || b} should be turned into - # $tcltest::testConstraints(a) || $tcltest::testConstraints(b). - regsub -all {[.\w]+} $constraints \ - {$tcltest::testConstraints(&)} c - catch {set doTest [eval expr $c]} - } else { - # just simple constraints such as {unixOnly fonts}. - set doTest 1 - foreach constraint $constraints { - if {(![info exists tcltest::testConstraints($constraint)]) \ - || (!$tcltest::testConstraints($constraint))} { - set doTest 0 - - # store the constraint that kept the test from running - set constraints $constraint - break - } - } - } - - if {$doTest == 0} { - if {[tcltest::isVerbose skip]} { - puts [outputChannel] "++++ $name SKIPPED: $constraints" - } - - if {$tcltest::testLevel == 1} { - incr tcltest::numTests(Skipped) - tcltest::AddToSkippedBecause $constraints - } - return - } - } - - # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with - # tcl_platform. - - if {$tcltest::preserveCore} { - set currentTclPlatform [array get tcl_platform] - array set tcl_platform $tcltest::originalTclPlatform - if {[file exists [file join [tcltest::workingDirectory] core]]} { - set coreModTime [file mtime [file join \ - [tcltest::workingDirectory] core]] - } - array set tcl_platform $currentTclPlatform - } - - # If there is no "memory" command (because memory debugging isn't - # enabled), then don't attempt to use the command. - - if {[info commands memory] != {}} { - memory tag $name - } - - if {[tcltest::isVerbose start]} { - puts [outputChannel] "---- $name start" - flush [outputChannel] - } - - set code [catch {uplevel $script} actualAnswer] - - return [list $actualAnswer $code] -} - -##################################################################### - -# tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# - -if {[namespace inscope tcltest info procs cleanupTestsHook] == {}} { - proc tcltest::cleanupTestsHook {} {} -} - -# tcltest::cleanupTests -- -# -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. -# -# Print the names of the files created without the makeFile command -# since the tests were invoked. -# -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). -# -# Arguments: -# calledFromAllFile - if 0, behave as if we are running a single test file -# within an entire suite of tests. if we aren't running a single test -# file, then don't report status. check for new files created during the -# test run and report on them. if 1, report collated status from all the -# test file runs. -# -# Results: -# None. -# -# Side Effects: -# None -# - -proc tcltest::cleanupTests {{calledFromAllFile 0}} { - - set testFileName [file tail [info script]] - - # Call the cleanup hook - tcltest::cleanupTestsHook - - # Remove files and directories created by the :tcltest::makeFile and - # tcltest::makeDirectory procedures. - # Record the names of files in tcltest::workingDirectory that were not - # pre-existing, and associate them with the test file that created them. - - if {!$calledFromAllFile} { - foreach file $tcltest::filesMade { - if {[file exists $file]} { - catch {file delete -force $file} - } - } - set currentFiles {} - foreach file [glob -nocomplain \ - [file join $tcltest::temporaryDirectory *]] { - lappend currentFiles [file tail $file] - } - set newFiles {} - foreach file $currentFiles { - if {[lsearch -exact $tcltest::filesExisted $file] == -1} { - lappend newFiles $file - } - } - set tcltest::filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set tcltest::createdNewFiles($testFileName) $newFiles - } - } - - if {$calledFromAllFile || $tcltest::testSingleFile} { - - # print stats - - puts -nonewline [outputChannel] "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline [outputChannel] \ - "\t$index\t$tcltest::numTests($index)" - } - puts [outputChannel] "" - - # print number test files sourced - # print names of files that ran tests which failed - - if {$calledFromAllFile} { - puts [outputChannel] \ - "Sourced $tcltest::numTestFiles Test Files." - set tcltest::numTestFiles 0 - if {[llength $tcltest::failFiles] > 0} { - puts [outputChannel] \ - "Files with failing tests: $tcltest::failFiles" - set tcltest::failFiles {} - } - } - - # if any tests were skipped, print the constraints that kept them - # from running. - - set constraintList [array names tcltest::skippedBecause] - if {[llength $constraintList] > 0} { - puts [outputChannel] \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts [outputChannel] \ - "\t$tcltest::skippedBecause($constraint)\t$constraint" - unset tcltest::skippedBecause($constraint) - } - } - - # report the names of test files in tcltest::createdNewFiles, and - # reset the array to be empty. - - set testFilesThatTurded [lsort [array names tcltest::createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts [outputChannel] "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts [outputChannel] \ - "\t$testFile:\t$tcltest::createdNewFiles($testFile)" - unset tcltest::createdNewFiles($testFile) - } - } - - # reset filesMade, filesExisted, and numTests - - set tcltest::filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set tcltest::numTests($index) 0 - } - - # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && ![info exists tcl_interactive]} { - exit - } - } else { - - # if we're deferring stat-reporting until all files are sourced, - # then add current file to failFile list if any tests in this file - # failed - - incr tcltest::numTestFiles - if {($tcltest::currentFailure) && \ - ([lsearch -exact $tcltest::failFiles $testFileName] == -1)} { - lappend tcltest::failFiles $testFileName - } - set tcltest::currentFailure false - - # restore the environment to the state it was in before this package - # was loaded - - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists tcltest::originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } else { - if {$::env($index) != $tcltest::originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $tcltest::originalEnv($index) - } - } - } - foreach index [array names tcltest::originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $index - set ::env($index) $tcltest::originalEnv($index) - } - } - if {[llength $newEnv] > 0} { - puts [outputChannel] \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts [outputChannel] \ - "env array elements changed:\t$changedEnv" - } - if {[llength $removedEnv] > 0} { - puts [outputChannel] \ - "env array elements removed:\t$removedEnv" - } - - set changedTclPlatform {} - foreach index [array names tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $tcltest::originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $tcltest::originalTclPlatform($index) - } - } - if {[llength $changedTclPlatform] > 0} { - puts [outputChannel] \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } - - if {[file exists [file join [tcltest::workingDirectory] core]]} { - if {$tcltest::preserveCore > 1} { - puts "rename core file (> 1)" - puts [outputChannel] "produced core file! \ - Moving file to: \ - [file join $tcltest::temporaryDirectory core-$name]" - catch {file rename -force \ - [file join [tcltest::workingDirectory] core] \ - [file join $tcltest::temporaryDirectory \ - core-$name]} msg - if {[string length $msg] > 0} { - tcltest::PrintError "Problem renaming file: $msg" - } - } else { - # Print a message if there is a core file and (1) there - # previously wasn't one or (2) the new one is different from - # the old one. - - if {[info exists tcltest::coreModificationTime]} { - if {$tcltest::coreModificationTime != [file mtime \ - [file join [tcltest::workingDirectory] core]]} { - puts [outputChannel] "A core file was created!" - } - } else { - puts [outputChannel] "A core file was created!" - } - } - } - } - flush [outputChannel] - flush [errorChannel] - return -} - -##################################################################### - -# Procs that determine which tests/test files to run - -# tcltest::getMatchingFiles -# -# Looks at the patterns given to match and skip files -# and uses them to put together a list of the tests that will be run. -# -# Arguments: -# directory to search -# -# Results: -# The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. It is used in runAllTests. -# -# Side Effects: -# None - -proc tcltest::getMatchingFiles { {searchDirectory ""} } { - if {[llength [info level 0]] == 1} { - set searchDirectory [tcltest::testsDirectory] - } - set matchingFiles {} - - # Find the matching files in the list of directories and then remove the - # ones that match the skip pattern - foreach directory $searchDirectory { - set matchFileList {} - foreach match $tcltest::matchFiles { - set matchFileList [concat $matchFileList \ - [glob -nocomplain [file join $directory $match]]] - } - if {[string compare {} $tcltest::skipFiles]} { - set skipFileList {} - foreach skip $tcltest::skipFiles { - set skipFileList [concat $skipFileList \ - [glob -nocomplain [file join $directory $skip]]] - } - foreach file $matchFileList { - # Only include files that don't match the skip pattern and - # aren't SCCS lock files. - if {([lsearch -exact $skipFileList $file] == -1) && \ - (![string match l.*.test [file tail $file]])} { - lappend matchingFiles $file - } - } - } else { - set matchingFiles [concat $matchingFiles $matchFileList] - } - } - if {[string equal $matchingFiles {}]} { - tcltest::PrintError "No test files remain after applying \ - your match and skip patterns!" - } - return $matchingFiles -} - -# tcltest::getMatchingDirectories -- -# -# Looks at the patterns given to match and skip directories and uses them -# to put together a list of the test directories that we should attempt -# to run. (Only subdirectories containing an "all.tcl" file are put into -# the list.) -# -# Arguments: -# root directory from which to search -# -# Results: -# The constructed list is returned to the user. This is used in the -# primary all.tcl file. Lower-level all.tcl files should use the -# tcltest::testAllFiles proc instead. -# -# Side Effects: -# None. - -proc tcltest::getMatchingDirectories {rootdir} { - set matchingDirs {} - set matchDirList {} - # Find the matching directories in tcltest::testsDirectory and then - # remove the ones that match the skip pattern - foreach match $tcltest::matchDirectories { - foreach file [glob -nocomplain [file join $rootdir $match]] { - if {([file isdirectory $file]) && ($file != $rootdir)} { - set matchDirList [concat $matchDirList \ - [tcltest::getMatchingDirectories $file]] - if {[file exists [file join $file all.tcl]]} { - set matchDirList [concat $matchDirList $file] - } - } - } - } - if {$tcltest::skipDirectories != {}} { - set skipDirs {} - foreach skip $tcltest::skipDirectories { - set skipDirs [concat $skipDirs \ - [glob -nocomplain [file join $tcltest::testsDirectory \ - $skip]]] - } - foreach dir $matchDirList { - # Only include directories that don't match the skip pattern - if {[lsearch -exact $skipDirs $dir] == -1} { - lappend matchingDirs $dir - } - } - } else { - set matchingDirs [concat $matchingDirs $matchDirList] - } - if {$matchingDirs == {}} { - DebugPuts 1 "No test directories remain after applying match and skip patterns!" - } - return $matchingDirs -} - -# tcltest::runAllTests -- -# -# prints output and sources test files according to the match and skip -# patterns provided. after sourcing test files, it goes on to source -# all.tcl files in matching test subdirectories. -# -# Arguments: -# shell being tested -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::runAllTests { {shell ""} } { - global argv - - if {[llength [info level 0]] == 1} { - set shell [tcltest::interpreter] - } - - set tcltest::testSingleFile false - - puts [outputChannel] "Tests running in interp: $shell" - puts [outputChannel] "Tests located in: $tcltest::testsDirectory" - puts [outputChannel] "Tests running in: [tcltest::workingDirectory]" - puts [outputChannel] "Temporary files stored in $tcltest::temporaryDirectory" - if {[tcltest::singleProcess]} { - puts [outputChannel] "Test files sourced into current interpreter" - } else { - puts [outputChannel] "Test files run in separate interpreters" - } - if {[llength $tcltest::skip] > 0} { - puts [outputChannel] "Skipping tests that match: $tcltest::skip" - } - if {[llength $tcltest::match] > 0} { - puts [outputChannel] "Only running tests that match: $tcltest::match" - } - - if {[llength $tcltest::skipFiles] > 0} { - puts [outputChannel] "Skipping test files that match: $tcltest::skipFiles" - } - if {[llength $tcltest::matchFiles] > 0} { - puts [outputChannel] "Only running test files that match: $tcltest::matchFiles" - } - - set timeCmd {clock format [clock seconds]} - puts [outputChannel] "Tests began at [eval $timeCmd]" - - # Run each of the specified tests - foreach file [lsort [tcltest::getMatchingFiles]] { - set tail [file tail $file] - puts [outputChannel] $tail - - if {$tcltest::singleProcess} { - incr tcltest::numTestFiles - uplevel [list source $file] - } else { - # Change to the tests directory so the value of the following - # variable is set correctly when we spawn the child test processes - cd $tcltest::testsDirectory - set cmd [concat [list | $shell $file] [split $argv]] - if {[catch { - incr tcltest::numTestFiles - set pipeFd [open $cmd "r"] - while {[gets $pipeFd line] >= 0} { - if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - incr tcltest::numTests($index) [set $index] - } - if {$Failed > 0} { - lappend tcltest::failFiles $testFile - } - } elseif {[regexp {^Number of tests skipped for each constraint:|^\t(\d+)\t(.+)$} $line match skipped constraint]} { - if {$match != "Number of tests skipped for each constraint:"} { - tcltest::AddToSkippedBecause $constraint $skipped - } - } else { - puts [outputChannel] $line - } - } - close $pipeFd - } msg]} { - # Print results to tcltest::outputChannel. - puts [outputChannel] "Test file error: $msg" - # append the name of the test to a list to be reported later - lappend testFileFailures $file - } - } - } - - # cleanup - puts [outputChannel] "\nTests ended at [eval $timeCmd]" - tcltest::cleanupTests 1 - if {[info exists testFileFailures]} { - puts [outputChannel] "\nTest files exiting with errors: \n" - foreach file $testFileFailures { - puts " [file tail $file]\n" - } - } - - # Checking for subdirectories in which to run tests - foreach directory [tcltest::getMatchingDirectories $tcltest::testsDirectory] { - set dir [file tail $directory] - puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - puts [outputChannel] "$dir test began at [eval $timeCmd]\n" - - uplevel "source [file join $directory all.tcl]" - - set endTime [eval $timeCmd] - puts [outputChannel] "\n$dir test ended at $endTime" - puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" - } - return -} - -##################################################################### - -# Test utility procs - not used in tcltest, but may be useful for testing. - -# tcltest::loadTestedCommands -- -# -# Uses the specified script to load the commands to test. Allowed to -# be empty, as the tested commands could have been compiled into the -# interpreter. -# -# Arguments -# none -# -# Results -# none -# -# Side Effects: -# none. - -proc tcltest::loadTestedCommands {} { - if {$tcltest::loadScript == {}} { - return - } - - return [uplevel $tcltest::loadScript] -} - -# tcltest::saveState -- -# -# Save information regarding what procs and variables exist. -# -# Arguments: -# none -# -# Results: -# Modifies the variable tcltest::saveState -# -# Side effects: -# None. - -proc tcltest::saveState {} { - uplevel {set tcltest::saveState [list [info procs] [info vars]]} - DebugPuts 2 "tcltest::saveState: $tcltest::saveState" - return -} - -# tcltest::restoreState -- -# -# Remove procs and variables that didn't exist before the call to -# tcltest::saveState. -# -# Arguments: -# none -# -# Results: -# Removes procs and variables from your environment if they don't exist -# in the tcltest::saveState variable. -# -# Side effects: -# None. - -proc tcltest::restoreState {} { - foreach p [info procs] { - if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \ - (![string match "*tcltest::$p" [namespace origin $p]])} { - - DebugPuts 2 "tcltest::restoreState: Removing proc $p" - rename $p {} - } - } - foreach p [uplevel {info vars}] { - if {[lsearch [lindex $tcltest::saveState 1] $p] < 0} { - DebugPuts 2 "tcltest::restoreState: Removing variable $p" - uplevel "catch {unset $p}" - } - } - return -} - -# tcltest::normalizeMsg -- -# -# Removes "extra" newlines from a string. -# -# Arguments: -# msg String to be modified -# -# Results: -# string with extra newlines removed -# -# Side effects: -# None. - -proc tcltest::normalizeMsg {msg} { - regsub "\n$" [string tolower $msg] "" msg - regsub -all "\n\n" $msg "\n" msg - regsub -all "\n\}" $msg "\}" msg - return $msg -} - -# tcltest::makeFile -- -# -# Create a new file with the name <name>, and write <contents> to it. -# -# If this file hasn't been created via makeFile since the last time -# cleanupTests was called, add it to the $filesMade list, so it will -# be removed by the next call to cleanupTests. -# -# Arguments: -# contents content of the new file -# name name of the new file -# directory directory name for new file -# -# Results: -# absolute path to the file created -# -# Side effects: -# None. - -proc tcltest::makeFile {contents name {directory ""}} { - global tcl_platform - - if {[llength [info level 0]] == 3} { - set directory [tcltest::temporaryDirectory] - } - - set fullName [file join $directory $name] - - DebugPuts 3 "tcltest::makeFile: putting $contents into $fullName" - - set fd [open $fullName w] - - fconfigure $fd -translation lf - - if {[string equal [string index $contents end] "\n"]} { - puts -nonewline $fd $contents - } else { - puts $fd $contents - } - close $fd - - if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { - lappend tcltest::filesMade $fullName - } - return $fullName -} - -# tcltest::removeFile -- -# -# Removes the named file from the filesystem -# -# Arguments: -# name file to be removed -# directory directory from which to remove file -# -# Results: -# return value from [file delete] -# -# Side effects: -# None. - -proc tcltest::removeFile {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::removeFile: removing $fullName" - return [file delete $fullName] -} - -# tcltest::makeDirectory -- -# -# Create a new dir with the name <name>. -# -# If this dir hasn't been created via makeDirectory since the last time -# cleanupTests was called, add it to the $directoriesMade list, so it will -# be removed by the next call to cleanupTests. -# -# Arguments: -# name name of the new directory -# directory directory in which to create new dir -# -# Results: -# absolute path to the directory created -# -# Side effects: -# None. - -proc tcltest::makeDirectory {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::makeDirectory: creating $fullName" - file mkdir $fullName - if {[lsearch -exact $tcltest::filesMade $fullName] == -1} { - lappend tcltest::filesMade $fullName - } - return $fullName -} - -# tcltest::removeDirectory -- -# -# Removes a named directory from the file system. -# -# Arguments: -# name Name of the directory to remove -# directory Directory from which to remove -# -# Results: -# return value from [file delete] -# -# Side effects: -# None - -proc tcltest::removeDirectory {name {directory ""}} { - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - DebugPuts 3 "tcltest::removeDirectory: deleting $fullName" - return [file delete -force $fullName] -} - -# tcltest::viewFile -- -# -# reads the content of a file and returns it -# -# Arguments: -# name of the file to read -# directory in which file is located -# -# Results: -# content of the named file -# -# Side effects: -# None. - -proc tcltest::viewFile {name {directory ""}} { - global tcl_platform - if {[llength [info level 0]] == 2} { - set directory [tcltest::temporaryDirectory] - } - set fullName [file join $directory $name] - if {([string equal $tcl_platform(platform) "macintosh"]) || \ - ([tcltest::testConstraint unixExecs] == 0)} { - set f [open $fullName] - set data [read -nonewline $f] - close $f - return $data - } else { - return [exec cat $fullName] - } - return -} - -# tcltest::bytestring -- -# -# Construct a string that consists of the requested sequence of bytes, -# as opposed to a string of properly formed UTF-8 characters. -# This allows the tester to -# 1. Create denormalized or improperly formed strings to pass to C procedures -# that are supposed to accept strings with embedded NULL bytes. -# 2. Confirm that a string result has a certain pattern of bytes, for instance -# to confirm that "\xe0\0" in a Tcl script is stored internally in -# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80". -# -# Generally, it's a bad idea to examine the bytes in a Tcl string or to -# construct improperly formed strings in this manner, because it involves -# exposing that Tcl uses UTF-8 internally. -# -# Arguments: -# string being converted -# -# Results: -# result fom encoding -# -# Side effects: -# None - -proc tcltest::bytestring {string} { - return [encoding convertfrom identity $string] -} - -# tcltest::openfiles -- -# -# used in io tests, uses testchannel -# -# Arguments: -# None. -# -# Results: -# ??? -# -# Side effects: -# None. - -proc tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} - } - return $result -} - -# tcltest::leakfiles -- -# -# used in io tests, uses testchannel -# -# Arguments: -# None. -# -# Results: -# ??? -# -# Side effects: -# None. - -proc tcltest::leakfiles {old} { - if {[catch {testchannel open} new]} { - return {} - } - set leak {} - foreach p $new { - if {[lsearch $old $p] < 0} { - lappend leak $p - } - } - return $leak -} - -# -# Internationalization / ISO support procs -- dl -# - -# tcltest::set_iso8859_1_locale -- -# -# used in cmdIL.test, uses testlocale -# -# Arguments: -# None. -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::set_iso8859_1_locale {} { - if {[info commands testlocale] != ""} { - set tcltest::previousLocale [testlocale ctype] - testlocale ctype $tcltest::isoLocale - } - return -} - -# tcltest::restore_locale -- -# -# used in cmdIL.test, uses testlocale -# -# Arguments: -# None. -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::restore_locale {} { - if {[info commands testlocale] != ""} { - testlocale ctype $tcltest::previousLocale - } - return -} - -# tcltest::threadReap -- -# -# Kill all threads except for the main thread. -# Do nothing if testthread is not defined. -# -# Arguments: -# none. -# -# Results: -# Returns the number of existing threads. -# -# Side Effects: -# none. -# - -proc tcltest::threadReap {} { - if {[info commands testthread] != {}} { - - # testthread built into tcltest - - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != $tcltest::mainThread} { - catch {testthread send -async $tid {testthread exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - testthread errorproc ThreadError - return [llength [testthread names]] - } elseif {[info commands thread::id] != {}} { - - # Thread extension - - thread::errorproc ThreadNullError - while {[llength [thread::names]] > 1} { - foreach tid [thread::names] { - if {$tid != $tcltest::mainThread} { - catch {thread::send -async $tid {thread::exit}} - } - } - ## Enter a bit a sleep to give the threads enough breathing - ## room to kill themselves off, otherwise the end up with a - ## massive queue of repeated events - after 1 - } - thread::errorproc ThreadError - return [llength [thread::names]] - } else { - return 1 - } - return 0 -} - -# Initialize the constraints and set up command line arguments -namespace eval tcltest { - # Ensure that we have a minimal auto_path so we don't pick up extra junk. - set ::auto_path [list [info library]] - - tcltest::initConstraints - if {[namespace children [namespace current]] == {}} { - tcltest::processCmdLineArgs - } - - # Save the names of files that already exist in - # the output directory. - foreach file [glob -nocomplain \ - [file join $tcltest::temporaryDirectory *]] { - lappend tcltest::filesExisted [file tail $file] - } -} - -package provide tcltest 2.0 - diff --git a/tests/all.tcl b/tests/all.tcl index 7c7ea53..7918117 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -8,53 +8,12 @@ # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: all.tcl,v 1.11 2000/09/20 23:09:54 jenn Exp $ +# RCS: @(#) $Id: all.tcl,v 1.12 2000/10/24 22:30:35 jenn Exp $ set tcltestVersion [package require tcltest] namespace import -force tcltest::* -if {[package vcompare $tcltestVersion 1.0]} { - tcltest::testsDirectory [file dir [info script]] - tcltest::runAllTests -} else { - set ::tcltest::testSingleFile false - set ::tcltest::testsDirectory [file dir [info script]] - - # We need to ensure that the testsDirectory is absolute - ::tcltest::normalizePath ::tcltest::testsDirectory - - puts stdout "Tcl $tcl_patchLevel tests running in interp: [info nameofexecutabl - e]" - puts stdout "Tests running in working dir: $::tcltest::testsDirectory" - if {[llength $::tcltest::skip] > 0} { - puts stdout "Skipping tests that match: $::tcltest::skip" - } - if {[llength $::tcltest::match] > 0} { - puts stdout "Only running tests that match: $::tcltest::match" - } - - if {[llength $::tcltest::skipFiles] > 0} { - puts stdout "Skipping test files that match: $::tcltest::skipFiles" - } - 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 [::tcltest::getMatchingFiles]] { - set tail [file tail $file] - puts stdout $tail - if {[catch {source $file} msg]} { - puts stdout $msg - } - } - - # cleanup - puts stdout "\nTests ended at [eval $timeCmd]" - ::tcltest::cleanupTests 1 -} +tcltest::testsDirectory [file dir [info script]] +tcltest::runAllTests return diff --git a/tests/tcltest.test b/tests/tcltest.test index 4e735be..b94f5e8 100755 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -1,24 +1,25 @@ -# Command line options covered: -# -help, -verbose, -match, -skip, -file, -notfile, -constraints, -# -limitconstraints, -preservecore, -tmpdir, -debug, -outfile, -# -errfile, -args -# # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest.test,v 1.11 2000/09/20 23:09:55 jenn Exp $ +# RCS: @(#) $Id: tcltest.test,v 1.12 2000/10/24 22:30:35 jenn Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 1.0 - namespace import -force ::tcltest::* +set tcltestVersion [package require tcltest] +namespace import -force ::tcltest::* + +if {[package vcompare $tcltestVersion 1.0] < 1} { + puts "Tests require that version 2.0 of tcltest be loaded." + puts "$tcltestVersion was loaded instead - tests will be skipped." + tcltest::cleanupTests + return } makeFile { - package require tcltest 1.0 + package require tcltest namespace import -force ::tcltest::* test a-1.0 {test a} { list 0 @@ -28,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 @@ -45,109 +49,246 @@ test tcltest-1.2 {tcltest -help -something} {unixOrPc} { test tcltest-1.3 {tcltest -h} {unixOrPc} { set result [catch {exec $::tcltest::tcltest test.tcl -h} msg] list $result [regexp Usage $msg] -} {1 1} +} {0 0} -# -verbose +# -verbose, implicit & explicit testing of tcltest::verbose 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 -v 'b'} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest test.tcl -v 'b'} msg] +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 -v 'p'} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest test.tcl -v 'p'} msg] +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 -v 's'} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest test.tcl -v 's'} msg] +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 -v 'ps'} {unixOrPc} { +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 -v 'psb'} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest test.tcl -v 'psb'} msg] +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} -# -match +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'} { + -constraints {unixOrPc} + -body { + set result [catch {exec $::tcltest::tcltest test.tcl -verbose 't'} msg] + list $result $msg + } + -result {^0 .*a-1.0 start.*b-1.0 start} + -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] + tcltest::verbose bar + set currentVerbosity [tcltest::verbose] + tcltest::verbose foo + set newVerbosity [tcltest::verbose] + tcltest::verbose $oldVerbosity + list $currentVerbosity $newVerbosity + } + -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* -v 'ps'} msg] + 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 -m b* -v 'ps'} msg] + 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* -v 'ps'} msg] + 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*} -v 'ps'} msg] + 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} -# -skip +test tcltest-3.5 {tcltest::match} { + -body { + set oldMatch [tcltest::match] + tcltest::match foo + set currentMatch [tcltest::match] + tcltest::match bar + set newMatch [tcltest::match] + tcltest::match $oldMatch + list $currentMatch $newMatch + } + -result {foo bar} +} + +# -skip, tcltest::skip test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest test.tcl -skip a* -v 'ps'} msg] + 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 -s b* -v 'ps'} msg] + 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* -v 'ps'} msg] + 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*} -v 'ps'} msg] + 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* -v 'ps'} msg] + 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} -# -constraints, -limitconstraints +test tcltest-4.6 {tcltest::skip} { + -body { + set oldSkip [tcltest::skip] + tcltest::skip foo + set currentSkip [tcltest::skip] + tcltest::skip bar + set newSkip [tcltest::skip] + tcltest::skip $oldSkip + list $currentSkip $newSkip + } + -result {foo bar} +} + +# -constraints, -limitconstraints, tcltest::testConstraint, +# tcltest::constraintsSpecified, tcltest::constraintList, +# tcltest::limitConstraints test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest test.tcl -constraints knownBug -v 'ps'} msg] + 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.1 {tcltest -constraints 'knownBug'} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest test.tcl -constraints knownBug -v 'p' -limitconstraints 1} msg] +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} -makeFile { - package require tcltest 1.0 +test tcltest-5.3 {tcltest::testConstraint - constraint empty (tcltest::safeFetch)} { + -body { + set r1 [tcltest::testConstraint tcltestFakeConstraint] + set r2 [tcltest::testConstraint tcltestFakeConstraint 4] + set r3 [tcltest::testConstraint tcltestFakeConstraint] + list $r1 $r2 $r3 + } + -result {0 4 4} + -cleanup {unset tcltest::testConstraints(tcltestFakeConstraint)} +} + +test tcltest-5.4 {tcltest::constraintsSpecified} { + -setup { + set constraintlist $tcltest::constraintsSpecified + set tcltest::constraintsSpecified {} + } + -body { + set r1 [tcltest::constraintsSpecified] + tcltest::testConstraint tcltestFakeConstraint1 1 + set r2 [tcltest::constraintsSpecified] + tcltest::testConstraint tcltestFakeConstraint2 1 + set r3 [tcltest::constraintsSpecified] + list $r1 $r2 $r3 + } + -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} + -cleanup { + set tcltest::constraintsSpecified $constraintlist + unset tcltest::testConstraints(tcltestFakeConstraint1) + unset tcltest::testConstraints(tcltestFakeConstraint2) + } +} + +test tcltest-5.5 {tcltest::constraintList} { + -constraints {!$tcltest::singleTestInterp} + -body { + 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} +} + +test tcltest-5.6 {tcltest::limitConstraints} { + -setup { + set keeplc $tcltest::limitConstraints + set keepkb [tcltest::testConstraint knownBug] + } + -body { + set r1 [tcltest::limitConstraints] + set r2 [tcltest::limitConstraints knownBug] + set r3 [tcltest::limitConstraints] + list $r1 $r2 $r3 + } + -cleanup { + tcltest::limitConstraints $keeplc + tcltest::testConstraint knownBug $keepkb + } + -result {false knownBug knownBug} +} + +# -outfile, -errfile, tcltest::outputChannel, tcltest::outputFile, +# tcltest::errorChannel, tcltest::errorFile +set printerror [makeFile { + package require tcltest namespace import -force ::tcltest::* puts $::tcltest::outputChannel "a test" ::tcltest::PrintError "a really short string" @@ -159,13 +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] -# -outfile, -errfile -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}] @@ -181,7 +326,7 @@ test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc} { $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {1 0 1 0 1 {}} test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc} { - catch {exec $::tcltest::tcltest printerror.tcl -o a.tmp -e b.tmp} msg + catch {exec $::tcltest::tcltest printerror.tcl -outfile a.tmp -errfile b.tmp} msg set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" b.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ @@ -190,53 +335,154 @@ test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc} { [file exists b.tmp] [file delete b.tmp] } {0 0 0 0 1 {} 1 {}} -# -debug -test tcltest-7.1 {tcltest test.tcl -d 0} {unixOrPc} { - catch {exec $::tcltest::tcltest test.tcl -d 0} msg +test tcltest-6.5 {tcltest::errorChannel - retrieval} { + -setup { + set of [tcltest::errorChannel] + set tcltest::errorChannel stderr + } + -body { + tcltest::errorChannel + } + -result {stderr} + -cleanup { + set tcltest::errorChannel $of + } +} + +test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { + -setup { + set ef [tcltest::makeFile {} efile] + set of [tcltest::errorFile] + set tcltest::errorChannel stderr + set tcltest::errorFile stderr + } + -body { + set f0 [tcltest::errorChannel] + set f1 [tcltest::errorFile] + set f2 [tcltest::errorFile $ef] + set f3 [tcltest::errorChannel] + set f4 [tcltest::errorFile] + list $f0 $f1 $f2 $f3 $f4 + } + -result {stderr stderr .*efile file[0-9a-f]+ .*efile} + -match regexp + -cleanup { + tcltest::errorFile $of + } +} +test tcltest-6.7 {tcltest::outputChannel - retrieval} { + -setup { + set of [tcltest::outputChannel] + set tcltest::outputChannel stdout + } + -body { + tcltest::outputChannel + } + -result {stdout} + -cleanup { + set tcltest::outputChannel $of + } +} + +test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { + -setup { + set ef [tcltest::makeFile {} efile] + set of [tcltest::outputFile] + set tcltest::outputChannel stdout + set tcltest::outputFile stdout + } + -body { + set f0 [tcltest::outputChannel] + set f1 [tcltest::outputFile] + set f2 [tcltest::outputFile $ef] + set f3 [tcltest::outputChannel] + set f4 [tcltest::outputFile] + list $f0 $f1 $f2 $f3 $f4 + } + -result {stdout stdout .*efile file[0-9a-f]+ .*efile} + -match regexp + -cleanup { + tcltest::outputFile $of + } +} + +# -debug, tcltest::debug +test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} { + catch {exec $::tcltest::tcltest test.tcl -debug 0} msg regexp "Flags passed into tcltest" $msg } {0} -test tcltest-7.2 {tcltest test.tcl -d 1} {unixOrPc} { - catch {exec $::tcltest::tcltest test.tcl -d 1 -s b*} msg +test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} { + catch {exec $::tcltest::tcltest test.tcl -debug 1 -skip b*} msg list [regexp userSpecifiedSkip $msg] \ [regexp "Flags passed into tcltest" $msg] } {1 0} -test tcltest-7.3 {tcltest test.tcl -d 1} {unixOrPc} { - catch {exec $::tcltest::tcltest test.tcl -d 1 -m b*} msg +test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} { + catch {exec $::tcltest::tcltest test.tcl -debug 1 -match b*} msg list [regexp userSpecifiedNonMatch $msg] \ [regexp "Flags passed into tcltest" $msg] } {1 0} -test tcltest-7.4 {tcltest test.tcl -d 2} {unixOrPc} { - catch {exec $::tcltest::tcltest test.tcl -d 2} msg +test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} { + catch {exec $::tcltest::tcltest test.tcl -debug 2} msg list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] } {1 0} -test tcltest-7.5 {tcltest test.tcl -d 3} {unixOrPc} { - catch {exec $::tcltest::tcltest test.tcl -d 3} msg +test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} { + catch {exec $::tcltest::tcltest test.tcl -debug 3} msg list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] } {1 1} +test tcltest-7.6 {tcltest::debug} { + -setup { + set old $tcltest::debug + set tcltest::debug 0 + } + -body { + set f1 [tcltest::debug] + set f2 [tcltest::debug 1] + set f3 [tcltest::debug] + set f4 [tcltest::debug 2] + set f5 [tcltest::debug] + list $f1 $f2 $f3 $f4 $f5 + } + -result {0 1 1 2 2} + -cleanup { + set tcltest::debug $old + } +} + +# directory tests + makeFile { - package require tcltest 1.0 + package require tcltest namespace import -force ::tcltest::* makeFile {} a.tmp + puts "testdir: [tcltest::testsDirectory]" exit } a.tcl -makeFile {} thisdirectoryisafile +makeFile {} thisdirectoryisafile -# -tmpdir +set normaldirectory [tcltest::makeDirectory normaldirectory] + +# -tmpdir, tcltest::temporaryDirectory test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} { file delete -force thisdirectorydoesnotexist exec $::tcltest::tcltest a.tcl -tmpdir thisdirectorydoesnotexist 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 tmpdir +# Test non-writeable directories, non-readable directories with directory flags set notReadableDir [file join $::tcltest::temporaryDirectory notreadable] set notWriteableDir [file join $::tcltest::temporaryDirectory notwriteable] @@ -265,26 +511,111 @@ test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc} { list [regexp {not writeable} [join $msg]] } {1} -# -testdir -test tcltest-8.5 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { +test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { + catch {exec $::tcltest::tcltest a.tcl -tmpdir $normaldirectory} msg + # The join is necessary because the message can be split on multiple lines + file exists [file join $normaldirectory a.tmp] +} {1} + +set current [pwd] +test tcltest-8.6 {tcltest::temporaryDirectory} { + -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 + } + -result "$normaldirectory $current $current" + -cleanup { + set tcltest::temporaryDirectory $old + } +} + +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 catch {exec $::tcltest::tcltest a.tcl -testdir thisdirectorydoesnotexist} msg list [regexp "does not exist" [join $msg]] } {1} -test tcltest-8.6 {tcltest a.tcl -testdir thisdirectoryisafile} { +test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { catch {exec $::tcltest::tcltest a.tcl -testdir 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.7 {tcltest a.tcl -testdir notReadableDir} {unixOnly} { +test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unixOnly} { catch {exec $::tcltest::tcltest a.tcl -testdir $notReadableDir} msg # The join is necessary because the message can be split on multiple lines list [regexp {not readable} [join $msg]] } {1} +test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} { + catch {exec $::tcltest::tcltest a.tcl -testdir normaldirectory} msg + # The join is necessary because the message can be split on multiple lines + regexp "testdir: $normaldirectory" [join $msg] +} {1} + +test tcltest-8.14 {tcltest::testsDirectory} { + -setup { + set old $tcltest::testsDirectory + set current [pwd] + set tcltest::testsDirectory $normaldirectory + } + -body { + set f1 [tcltest::testsDirectory] + set f2 [tcltest::testsDirectory $current] + set f3 [tcltest::testsDirectory] + list $f1 $f2 $f3 + } + -result "$normaldirectory $current $current" + -cleanup { + set tcltest::testsDirectory $old + } +} + +# tcltest::workingDirectory +test tcltest-8.60 {tcltest::workingDirectory} { + -setup { + set old $tcltest::workingDirectory + set current [pwd] + set tcltest::workingDirectory $normaldirectory + cd $normaldirectory + } + -body { + set f1 [tcltest::workingDirectory] + set f2 [pwd] + set f3 [tcltest::workingDirectory $current] + set f4 [pwd] + set f5 [tcltest::workingDirectory] + list $f1 $f2 $f3 $f4 $f5 + } + -result "$normaldirectory $normaldirectory $current $current $current" + -cleanup { + set tcltest::workingDirectory $old + cd $current + } +} + +# clean up from directory testing + switch $tcl_platform(platform) { "unix" { file attributes $notReadableDir -permissions 777 @@ -297,7 +628,7 @@ switch $tcl_platform(platform) { file delete -force $notReadableDir $notWriteableDir -# -file -notfile +# -file, -notfile, tcltest::matchFiles, tcltest::skipFiles test tcltest-9.1 {-file a*.tcl} {unixOrPc} { catch {exec $::tcltest::tcltest \ [file join $::tcltest::testsDirectory all.tcl] -file a*.test} msg @@ -310,10 +641,35 @@ test tcltest-9.2 {-file a*.tcl} {unixOrPc} { list [regexp assocd\.test $msg] } {0} +test tcltest-9.3 {tcltest::matchFiles} { + -body { + set old [tcltest::matchFiles] + tcltest::matchFiles foo + set current [tcltest::matchFiles] + tcltest::matchFiles bar + set new [tcltest::matchFiles] + tcltest::matchFiles $old + list $current $new + } + -result {foo bar} +} +test tcltest-9.4 {tcltest::skipFiles} { + -body { + set old [tcltest::skipFiles] + tcltest::skipFiles foo + set current [tcltest::skipFiles] + tcltest::skipFiles bar + set new [tcltest::skipFiles] + tcltest::skipFiles $old + list $current $new + } + -result {foo bar} +} +# -preservecore, tcltest::preserveCore makeFile { - package require tcltest 1.0 + package require tcltest namespace import -force ::tcltest::* test makecore {make a core file} { @@ -324,73 +680,333 @@ makeFile { return } makecore.tcl -# -preservecore test tcltest-10.1 {-preservecore 0} {unixOrPc} { catch {exec $::tcltest::tcltest makecore.tcl -preservecore 0} msg file delete core - regexp "produced core file" $msg + regexp "Core file produced" $msg } {0} test tcltest-10.2 {-preservecore 1} {unixOrPc} { catch {exec $::tcltest::tcltest makecore.tcl -preservecore 1} msg file delete core - regexp "produced core file" $msg + regexp "Core file produced" $msg } {1} test tcltest-10.3 {-preservecore 2} {unixOrPc} { catch {exec $::tcltest::tcltest makecore.tcl -preservecore 2} msg file delete core - list [regexp "==== makecore produced core file" $msg] [regexp "Moving file to" $msg] \ + list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] } {1 1 1 {}} test tcltest-10.4 {-preservecore 3} {unixOrPc} { catch {exec $::tcltest::tcltest makecore.tcl -preservecore 3} msg file delete core - list [regexp "produced core file" $msg] [regexp "Moving file to" $msg] \ + list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] } {1 1 1 {}} -makeFile { - package require tcltest 1.0 - namespace import -force ::tcltest::* - puts "=$::tcltest::parameters=" - exit -} args.tcl - -# -args -test tcltest-11.1 {-args foo} {unixOrPc} { - catch {exec $::tcltest::tcltest args.tcl -args foo} msg - list $msg -} {=foo=} - -test tcltest-11.2 {-args {}} {unixOrPc} { - catch {exec $::tcltest::tcltest args.tcl -args {}} msg - list $msg -} {==} - -test tcltest-11.3 {-args {-foo bar -baz}} {unixOrPc} { - catch {exec $::tcltest::tcltest args.tcl -args {-foo bar -baz}} msg - list $msg -} {{=-foo bar -baz=}} +test tcltest-10.5 {tcltest::preserveCore} { + -body { + set old [tcltest::preserveCore] + set result [tcltest::preserveCore foo] + set result2 [tcltest::preserveCore] + tcltest::preserveCore $old + list $result $result2 + } + -result {foo foo} +} -# -load -loadfile -makeFile { - package require tcltest 1.0 +# -load, -loadfile, tcltest::loadScript, tcltest::loadFile +set loadfile [makeFile { + package require tcltest namespace import -force ::tcltest::* puts $::tcltest::loadScript exit -} load.tcl +} load.tcl] -test tcltest-12.1 {-load xxx} { +test tcltest-12.1 {-load xxx} {unixOrPc} { catch {exec $::tcltest::tcltest load.tcl -load xxx} msg set msg } {xxx} -test tcltest-12.1 {-loadfile load.tcl} { - catch {exec $::tcltest::tcltest load.tcl -d 2 -loadfile load.tcl} msg +test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} { + catch {exec $::tcltest::tcltest load.tcl -debug 2 -loadfile load.tcl} msg list \ [regexp {tcltest} [join $msg [split $msg \n]]] \ [regexp {loadScript} [join $msg [split $msg \n]]] } {1 1} +test tcltest-12.3 {tcltest::loadScript} { + -setup { + set old $tcltest::loadScript + set tcltest::load-body {} + } + -body { + set f1 [tcltest::loadScript] + set f2 [tcltest::loadScript xxx] + set f3 [tcltest::loadScript] + list $f1 $f2 $f3 + } + -result {{} xxx xxx} + -cleanup { + set tcltest::loadScript $old + } +} + +test tcltest-12.4 {tcltest::loadFile} { + -setup { + set olds $tcltest::loadScript + set tcltest::load-body {} + set oldf $tcltest::loadFile + set tcltest::loadFile {} + } + -body { + set f1 [tcltest::loadScript] + set f2 [tcltest::loadFile] + set f3 [tcltest::loadFile load.tcl] + set f4 [tcltest::loadScript] + set f5 [tcltest::loadFile] + list $f1 $f2 $f3 $f4 $f5 + } + -result "{} {} $loadfile { + package require tcltest + namespace import -force ::tcltest::* + puts \$::tcltest::loadScript + exit +} $loadfile +" + -cleanup { + set tcltest::loadScript $olds + set tcltest::loadFile $oldf + } +} + +# tcltest::interpreter +test tcltest-13.1 {tcltest::interpreter} { + -setup { + set old $tcltest::tcltest + set tcltest::tcltest tcltest + } + -body { + set f1 [tcltest::interpreter] + set f2 [tcltest::interpreter tclsh] + set f3 [tcltest::interpreter] + list $f1 $f2 $f3 + } + -result {tcltest tclsh tclsh} + -cleanup { + set tcltest::tcltest $old + } +} + +# -singleproc, tcltest::singleProcess +makeDirectory singleprocdir +makeFile { + set foo 1 +} [file join singleprocdir single1.test] + +makeFile { + unset foo +} [file join singleprocdir single2.test] + +set allfile [makeFile { + package require tcltest + namespace import -force tcltest::* + tcltest::testsDirectory [file join [tcltest::temporaryDirectory] singleprocdir] + tcltest::runAllTests +} [file join singleprocdir all-single.tcl]] + +test tcltest-14.1 {-singleproc - single process} { + -constraints {unixOrPc} + -body { + exec [tcltest::interpreter] $allfile -singleproc 0 + } + -result {Test file error: can't unset .foo.: no such variable} + -match regexp +} + +test tcltest-14.2 {-singleproc - multiple process} { + -constraints {unixOrPc} + -body { + exec [tcltest::interpreter] $allfile -singleproc 1 + } + -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0} + -match regexp +} + +test tcltest-14.3 {tcltest::singleProcess} { + -setup { + set old $tcltest::singleProcess + set tcltest::singleProcess 0 + } + -body { + set f1 [tcltest::singleProcess] + set f2 [tcltest::singleProcess 1] + set f3 [tcltest::singleProcess] + list $f1 $f2 $f3 + } + -result {0 1 1} + -cleanup { + set tcltest::singleProcess $old + } +} + +# -asidefromdir, -relateddir, tcltest::matchDirectories, +# tcltest::skipDirectories + +# Before running these tests, need to set up test subdirectories with their own +# all.tcl files. + +makeDirectory dirtestdir +makeDirectory [file join dirtestdir dirtestdir2.1] +makeDirectory [file join dirtestdir dirtestdir2.2] +makeDirectory [file join dirtestdir dirtestdir2.3] +makeFile { + package require tcltest + namespace import -force tcltest::* + tcltest::testsDirectory [file join [tcltest::temporaryDirectory] \ + dirtestdir] + tcltest::runAllTests +} [file join dirtestdir all.tcl] +makeFile { + package require tcltest + namespace import -force tcltest::* + tcltest::testsDirectory [file join [tcltest::temporaryDirectory] \ + dirtestdir dirtestdir2.1] + tcltest::runAllTests +} [file join dirtestdir dirtestdir2.1 all.tcl] +makeFile { + package require tcltest + namespace import -force tcltest::* + tcltest::testsDirectory [file join [tcltest::temporaryDirectory] \ + dirtestdir dirtestdir2.2] + tcltest::runAllTests +} [file join dirtestdir dirtestdir2.2 all.tcl] +makeFile { + package require tcltest + namespace import -force tcltest::* + tcltest::testsDirectory [file join [tcltest::temporaryDirectory] \ + dirtestdir dirtestdir2.3] + tcltest::runAllTests +} [file join dirtestdir dirtestdir2.3 all.tcl] + +test tcltest-15.1 {basic directory walking} { + -constraints {unixOrPc} + -body { + exec [tcltest::interpreter] [file join \ + [tcltest::temporaryDirectory] dirtestdir all.tcl] + } + -match regexp + -returnCodes 1 + -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*Tests located in:.*dirtestdir2.3} +} + +test tcltest-15.2 {-asidefromdir} { + -constraints {unixOrPc} + -body { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -asidefromdir dirtestdir2.3 + } + -match regexp + -returnCodes 1 + -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*dirtestdir2.2 test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Error: No test files remain after applying your match and skip patterns! +Error: No test files remain after applying your match and skip patterns! +Error: No test files remain after applying your match and skip patterns!$} +} + +test tcltest-15.3 {-relateddir, non-existent dir} { + -constraints {unixOrPc} + -body { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -relateddir [file join [tcltest::temporaryDirectory] dirtestdir0] + } + -returnCodes 1 + -match regexp + -result {[^~]|dirtestdir[^2]} +} + +test tcltest-15.4 {-relateddir, subdir} { + -constraints {unixOrPc} + -body { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -relateddir dirtestdir2.1 + } + -returnCodes 1 + -match regexp + -result {Tests located in:.*dirtestdir2.[^23]} +} +test tcltest-15.5 {-relateddir, -asidefromdir} { + -constraints {unixOrPc} + -body { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -relateddir "dirtestdir2.1 dirtestdir2.2" -asidefromdir dirtestdir2.2 + } + -match regexp + -returnCodes 1 + -result {Tests located in:.*dirtestdir2.[^23]} +} + +test tcltest-15.6 {tcltest::matchDirectories} { + -setup { + set old [tcltest::matchDirectories] + set tcltest::matchDirectories {} + } + -body { + set r1 [tcltest::matchDirectories] + set r2 [tcltest::matchDirectories foo] + set r3 [tcltest::matchDirectories] + list $r1 $r2 $r3 + } + -cleanup { + set tcltest::matchDirectories $old + } + -result {{} foo foo} +} + +test tcltest-15.7 {tcltest::skipDirectories} { + -setup { + set old [tcltest::skipDirectories] + set tcltest::skipDirectories {} + } + -body { + set r1 [tcltest::skipDirectories] + set r2 [tcltest::skipDirectories foo] + set r3 [tcltest::skipDirectories] + list $r1 $r2 $r3 + } + -cleanup { + set tcltest::skipDirectories $old + } + -result {{} foo foo} +} + +# TCLTEST_OPTIONS +test tcltest-19.1 {TCLTEST_OPTIONS default} { + -constraints {unixOrPc} + -setup { + if {[info exists ::env(TCLTEST_OPTIONS)]} { + set oldoptions $::env(TCLTEST_OPTIONS) + unset ::env(TCLTEST_OPTIONS) +c } else { + set oldoptions none + } + set ::env(TCLTEST_OPTIONS) {} + set olddebug [tcltest::debug] + tcltest::debug 2 + } + -cleanup { + if {$oldoptions == "none"} { + unset ::env(TCLTEST_OPTIONS) + } else { + set ::env(TCLTEST_OPTIONS) $oldoptions + } + tcltest::debug $olddebug + } + -body { + tcltest::processCmdLineArgs + set ::env(TCLTEST_OPTIONS) "-debug 3" + tcltest::processCmdLineArgs + } + -result {^$} + -match regexp + -output {tcltest::debug\s+= 2.*tcltest::debug\s+= 3} +} + # Begin testing of tcltest procs ... # PrintError @@ -401,6 +1017,292 @@ test tcltest-20.1 {PrintError} {unixOrPc} { [regexp " \"Really" $msg] [regexp Problem $msg] } {1 1 1 1 1 1} +# test::test +test tcltest-21.1 {expect with glob} { + -body { + list a b c d e + } + -match glob + -result {[ab] b c d e} +} + +test tcltest-21.2 {force a test command failure} { + -body { + test foo { + return 2 + } {1} + } + -errorOutput {^test foo: bad flag 1 supplied to tcltest::test\n$} + -result {1} + -match regexp +} + +test tcltest-21.3 {test command with setup} { + -setup { + set foo 1 + } + -body { + set foo + } + -cleanup {unset foo} + -result {1} +} + +test tcltest-21.4 {test command with cleanup failure} { + -setup { + if {[info exists foo]} { + unset foo + } + } + -body { + test foo-1 {foo-1} { + -cleanup {unset foo} + } + } + -result {^0$} + -match regexp + -output "Test cleanup failed:.*can't unset \"foo\": no such variable" +} + +test tcltest-21.5 {test command with setup failure} { + -setup { + if {[info exists foo]} { + unset foo + } + } + -body { + test foo-2 {foo-2} { + -setup {unset foo} + } + } + -result {^0$} + -match regexp + -output "Test setup failed:.*can't unset \"foo\": no such variable" +} + +test tcltest-21.6 {test command - setup occurs before cleanup & before script} { + -body { + test foo-3 {foo-3} { + -setup { + if {[info exists foo]} { + unset foo + } + set foo 1 + set expected 2 + } + -body { + incr foo + set foo + } + -cleanup { + if {$foo != 2} { + puts [tcltest::outputChannel] "foo is wrong" + } else { + puts [tcltest::outputChannel] "foo is 2" + } + } + -result {$expected} + } + } + -result {^0$} + -match regexp + -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) + +test tcltest-21.7 {expect with glob} \ + -body {list a b c d e} \ + -result {[ab] b c d e} \ + -match glob + +test tcltest-21.8 {force a test command failure} -body { + test foo { + return 2 + } {1} +} -errorOutput {test foo: bad flag 1 supplied to tcltest::test +} -result {1} + +test tcltest-21.9 {test command with setup} \ + -setup {set foo 1} \ + -body {set foo} \ + -cleanup {unset foo} \ + -result {1} + +test tcltest-21.10 {test command with cleanup failure} -setup { + if {[info exists foo]} { + unset foo + } +} -body { + test foo-1 {foo-1} -cleanup {unset foo} +} -result {^0$} -match regexp \ + -output {Test cleanup failed:.*can't unset \"foo\": no such variable} + +test tcltest-21.11 {test command with setup failure} -setup { + if {[info exists foo]} { + unset foo + } +} -body { + test foo-2 {foo-2} -setup {unset foo} +} -result {^0$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp + +test tcltest-21.12 {test command - setup occurs before cleanup & before script} -body { + test foo-3 {foo-3} -setup { + if {[info exists foo]} { + unset foo + } + set foo 1 + set expected 2 + } -body { + incr foo + set foo + } -cleanup { + if {$foo != 2} { + puts [tcltest::outputChannel] "foo is wrong" + } else { + puts [tcltest::outputChannel] "foo is 2" + } + } -result {$expected} +} -result {^0$} -output {foo is 2} -match regexp + +# test all.tcl usage (runAllTests); simulate .test file failure, as well as +# crashes to determine whether or not these errors are logged. + +makeDirectory alltestdir +makeFile { + package require tcltest + namespace import -force tcltest::* + tcltest::testsDirectory [file join [tcltest::temporaryDirectory] \ + alltestdir] + tcltest::runAllTests +} [file join alltestdir all.tcl] +makeFile { + exit 1 +} [file join alltestdir exit.test] +makeFile { + error "throw an error" +} [file join alltestdir error.test] +makeFile { + package require tcltest + namespace import -force tcltest::* + test foo-1.1 {foo} { + -body { return 1 } + -result {1} + } + tcltest::cleanupTests +} [file join alltestdir test.test] + +test tcltest-22.1 {runAllTests} { + -constraints {unixOrPc} + -body { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] alltestdir all.tcl] -verbose t + } + -match regexp + -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 +} + ::tcltest::cleanupTests return diff --git a/tests/tcltest2.test b/tests/tcltest2.test deleted file mode 100755 index 6c7c3d1..0000000 --- a/tests/tcltest2.test +++ /dev/null @@ -1,1308 +0,0 @@ -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions -# All rights reserved. -# -# RCS: @(#) $Id: tcltest2.test,v 1.3 2000/10/19 18:01:00 jenn Exp $ - -set tcltestVersion [package require tcltest] -namespace import -force ::tcltest::* - -if {[package vcompare $tcltestVersion 1.0] < 1} { - puts "Tests require that version 2.0 of tcltest be loaded." - puts "$tcltestVersion was loaded instead - tests will be skipped." - tcltest::cleanupTests - return -} - -makeFile { - package require tcltest - namespace import -force ::tcltest::* - test a-1.0 {test a} { - list 0 - } {0} - test b-1.0 {test b} { - list 1 - } {0} - test c-1.0 {test c} {knownBug} { - } {} - test d-1.0 {test d} { - error "foo" foo 9 - } {} - ::tcltest::cleanupTests - exit -} test.tcl - -# test -help -test tcltest-1.1 {tcltest -help} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest test.tcl -help} msg] - set result [catch {runCmd $cmd}] - list $result [regexp Usage $msg] -} {1 1} -test tcltest-1.2 {tcltest -help -something} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest test.tcl -help -something} msg] - list $result [regexp Usage $msg] -} {1 1} -test tcltest-1.3 {tcltest -h} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest test.tcl -h} msg] - list $result [regexp Usage $msg] -} {0 0} - -# -verbose, implicit & explicit testing of tcltest::verbose -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.+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.+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.+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.+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.+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.+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'} { - -constraints {unixOrPc} - -body { - set result [catch {exec $::tcltest::tcltest test.tcl -verbose 't'} msg] - list $result $msg - } - -result {^0 .*a-1.0 start.*b-1.0 start} - -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] - tcltest::verbose bar - set currentVerbosity [tcltest::verbose] - tcltest::verbose foo - set newVerbosity [tcltest::verbose] - tcltest::verbose $oldVerbosity - list $currentVerbosity $newVerbosity - } - -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.+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.+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.+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.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] -} {0 1 1 0 1} - -test tcltest-3.5 {tcltest::match} { - -body { - set oldMatch [tcltest::match] - tcltest::match foo - set currentMatch [tcltest::match] - tcltest::match bar - set newMatch [tcltest::match] - tcltest::match $oldMatch - list $currentMatch $newMatch - } - -result {foo bar} -} - -# -skip, tcltest::skip -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.+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.+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.+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.+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.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] -} {0 1 0 0 1} - -test tcltest-4.6 {tcltest::skip} { - -body { - set oldSkip [tcltest::skip] - tcltest::skip foo - set currentSkip [tcltest::skip] - tcltest::skip bar - set newSkip [tcltest::skip] - tcltest::skip $oldSkip - list $currentSkip $newSkip - } - -result {foo bar} -} - -# -constraints, -limitconstraints, tcltest::testConstraint, -# tcltest::constraintsSpecified, tcltest::constraintList, -# tcltest::limitConstraints -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.+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.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] -} {0 0 0 1 1} - -test tcltest-5.3 {tcltest::testConstraint - constraint empty (tcltest::safeFetch)} { - -body { - set r1 [tcltest::testConstraint tcltestFakeConstraint] - set r2 [tcltest::testConstraint tcltestFakeConstraint 4] - set r3 [tcltest::testConstraint tcltestFakeConstraint] - list $r1 $r2 $r3 - } - -result {0 4 4} - -cleanup {unset tcltest::testConstraints(tcltestFakeConstraint)} -} - -test tcltest-5.4 {tcltest::constraintsSpecified} { - -setup { - set constraintlist $tcltest::constraintsSpecified - set tcltest::constraintsSpecified {} - } - -body { - set r1 [tcltest::constraintsSpecified] - tcltest::testConstraint tcltestFakeConstraint1 1 - set r2 [tcltest::constraintsSpecified] - tcltest::testConstraint tcltestFakeConstraint2 1 - set r3 [tcltest::constraintsSpecified] - list $r1 $r2 $r3 - } - -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} - -cleanup { - set tcltest::constraintsSpecified $constraintlist - unset tcltest::testConstraints(tcltestFakeConstraint1) - unset tcltest::testConstraints(tcltestFakeConstraint2) - } -} - -test tcltest-5.5 {tcltest::constraintList} { - -constraints {!$tcltest::singleTestInterp} - -body { - 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} -} - -test tcltest-5.6 {tcltest::limitConstraints} { - -setup { - set keeplc $tcltest::limitConstraints - set keepkb [tcltest::testConstraint knownBug] - } - -body { - set r1 [tcltest::limitConstraints] - set r2 [tcltest::limitConstraints knownBug] - set r3 [tcltest::limitConstraints] - list $r1 $r2 $r3 - } - -cleanup { - tcltest::limitConstraints $keeplc - tcltest::testConstraint knownBug $keepkb - } - -result {false knownBug knownBug} -} - -# -outfile, -errfile, tcltest::outputChannel, tcltest::outputFile, -# tcltest::errorChannel, tcltest::errorFile -set printerror [makeFile { - package require tcltest - namespace import -force ::tcltest::* - puts $::tcltest::outputChannel "a test" - ::tcltest::PrintError "a really short string" - ::tcltest::PrintError "a really really really really really really long \ - string containing \"quotes\" and other bad bad stuff" - ::tcltest::PrintError "a really really long string containing a \ - \"Path/that/is/really/long/and/contains/no/spaces\"" - ::tcltest::PrintError "a really really long string containing a \ - \"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] - -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}] - set result2 [catch {exec grep "a really" a.tmp}] - list [regexp "a test" $msg] [regexp "a really" $msg] \ - $result1 $result2 [file exists a.tmp] [file delete a.tmp] -} {0 1 0 1 1 {}} -test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc} { - catch {exec $::tcltest::tcltest printerror.tcl -errfile a.tmp} msg - set result1 [catch {exec grep "a test" a.tmp}] - set result2 [catch {exec grep "a really" a.tmp}] - list [regexp "a test" $msg] [regexp "a really" $msg] \ - $result1 $result2 [file exists a.tmp] [file delete a.tmp] -} {1 0 1 0 1 {}} -test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc} { - catch {exec $::tcltest::tcltest printerror.tcl -outfile a.tmp -errfile b.tmp} msg - set result1 [catch {exec grep "a test" a.tmp}] - set result2 [catch {exec grep "a really" b.tmp}] - list [regexp "a test" $msg] [regexp "a really" $msg] \ - $result1 $result2 \ - [file exists a.tmp] [file delete a.tmp] \ - [file exists b.tmp] [file delete b.tmp] -} {0 0 0 0 1 {} 1 {}} - -test tcltest-6.5 {tcltest::errorChannel - retrieval} { - -setup { - set of [tcltest::errorChannel] - set tcltest::errorChannel stderr - } - -body { - tcltest::errorChannel - } - -result {stderr} - -cleanup { - set tcltest::errorChannel $of - } -} - -test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { - -setup { - set ef [tcltest::makeFile {} efile] - set of [tcltest::errorFile] - set tcltest::errorChannel stderr - set tcltest::errorFile stderr - } - -body { - set f0 [tcltest::errorChannel] - set f1 [tcltest::errorFile] - set f2 [tcltest::errorFile $ef] - set f3 [tcltest::errorChannel] - set f4 [tcltest::errorFile] - list $f0 $f1 $f2 $f3 $f4 - } - -result {stderr stderr .*efile file[0-9a-f]+ .*efile} - -match regexp - -cleanup { - tcltest::errorFile $of - } -} -test tcltest-6.7 {tcltest::outputChannel - retrieval} { - -setup { - set of [tcltest::outputChannel] - set tcltest::outputChannel stdout - } - -body { - tcltest::outputChannel - } - -result {stdout} - -cleanup { - set tcltest::outputChannel $of - } -} - -test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { - -setup { - set ef [tcltest::makeFile {} efile] - set of [tcltest::outputFile] - set tcltest::outputChannel stdout - set tcltest::outputFile stdout - } - -body { - set f0 [tcltest::outputChannel] - set f1 [tcltest::outputFile] - set f2 [tcltest::outputFile $ef] - set f3 [tcltest::outputChannel] - set f4 [tcltest::outputFile] - list $f0 $f1 $f2 $f3 $f4 - } - -result {stdout stdout .*efile file[0-9a-f]+ .*efile} - -match regexp - -cleanup { - tcltest::outputFile $of - } -} - -# -debug, tcltest::debug -test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} { - catch {exec $::tcltest::tcltest test.tcl -debug 0} msg - regexp "Flags passed into tcltest" $msg -} {0} -test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} { - catch {exec $::tcltest::tcltest test.tcl -debug 1 -skip b*} msg - list [regexp userSpecifiedSkip $msg] \ - [regexp "Flags passed into tcltest" $msg] -} {1 0} -test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} { - catch {exec $::tcltest::tcltest test.tcl -debug 1 -match b*} msg - list [regexp userSpecifiedNonMatch $msg] \ - [regexp "Flags passed into tcltest" $msg] -} {1 0} -test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} { - catch {exec $::tcltest::tcltest test.tcl -debug 2} msg - list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] -} {1 0} -test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} { - catch {exec $::tcltest::tcltest test.tcl -debug 3} msg - list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] -} {1 1} - -test tcltest-7.6 {tcltest::debug} { - -setup { - set old $tcltest::debug - set tcltest::debug 0 - } - -body { - set f1 [tcltest::debug] - set f2 [tcltest::debug 1] - set f3 [tcltest::debug] - set f4 [tcltest::debug 2] - set f5 [tcltest::debug] - list $f1 $f2 $f3 $f4 $f5 - } - -result {0 1 1 2 2} - -cleanup { - set tcltest::debug $old - } -} - -# directory tests - -makeFile { - package require tcltest - namespace import -force ::tcltest::* - makeFile {} a.tmp - puts "testdir: [tcltest::testsDirectory]" - exit -} a.tcl - -makeFile {} thisdirectoryisafile - -set normaldirectory [tcltest::makeDirectory normaldirectory] - -# -tmpdir, tcltest::temporaryDirectory -test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} { - file delete -force thisdirectorydoesnotexist - exec $::tcltest::tcltest a.tcl -tmpdir thisdirectorydoesnotexist - list [file exists [file join thisdirectorydoesnotexist a.tmp]] \ - [file delete -force thisdirectorydoesnotexist] -} {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] -set notWriteableDir [file join $::tcltest::temporaryDirectory notwriteable] - -::tcltest::makeDirectory notreadable -::tcltest::makeDirectory notwriteable - -switch $tcl_platform(platform) { - "unix" { - file attributes $notReadableDir -permissions 00333 - file attributes $notWriteableDir -permissions 00555 - } - default { - file attributes $notWriteableDir -readonly 1 - } -} - -test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly} { - catch {exec $::tcltest::tcltest a.tcl -tmpdir $notReadableDir} msg - # The join is necessary because the message can be split on multiple lines - list [regexp {not readable} [join $msg]] -} {1} - -test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc} { - catch {exec $::tcltest::tcltest a.tcl -tmpdir $notWriteableDir} msg - # The join is necessary because the message can be split on multiple lines - list [regexp {not writeable} [join $msg]] -} {1} - -test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { - catch {exec $::tcltest::tcltest a.tcl -tmpdir $normaldirectory} msg - # The join is necessary because the message can be split on multiple lines - file exists [file join $normaldirectory a.tmp] -} {1} - -set current [pwd] -test tcltest-8.6 {tcltest::temporaryDirectory} { - -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 - } - -result "$normaldirectory $current $current" - -cleanup { - set tcltest::temporaryDirectory $old - } -} - -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 - catch {exec $::tcltest::tcltest a.tcl -testdir thisdirectorydoesnotexist} msg - list [regexp "does not exist" [join $msg]] -} {1} - -test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { - catch {exec $::tcltest::tcltest a.tcl -testdir 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.12 {tcltest a.tcl -testdir notReadableDir} {unixOnly} { - catch {exec $::tcltest::tcltest a.tcl -testdir $notReadableDir} msg - # The join is necessary because the message can be split on multiple lines - list [regexp {not readable} [join $msg]] -} {1} - - -test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} { - catch {exec $::tcltest::tcltest a.tcl -testdir normaldirectory} msg - # The join is necessary because the message can be split on multiple lines - regexp "testdir: $normaldirectory" [join $msg] -} {1} - -test tcltest-8.14 {tcltest::testsDirectory} { - -setup { - set old $tcltest::testsDirectory - set current [pwd] - set tcltest::testsDirectory $normaldirectory - } - -body { - set f1 [tcltest::testsDirectory] - set f2 [tcltest::testsDirectory $current] - set f3 [tcltest::testsDirectory] - list $f1 $f2 $f3 - } - -result "$normaldirectory $current $current" - -cleanup { - set tcltest::testsDirectory $old - } -} - -# tcltest::workingDirectory -test tcltest-8.60 {tcltest::workingDirectory} { - -setup { - set old $tcltest::workingDirectory - set current [pwd] - set tcltest::workingDirectory $normaldirectory - cd $normaldirectory - } - -body { - set f1 [tcltest::workingDirectory] - set f2 [pwd] - set f3 [tcltest::workingDirectory $current] - set f4 [pwd] - set f5 [tcltest::workingDirectory] - list $f1 $f2 $f3 $f4 $f5 - } - -result "$normaldirectory $normaldirectory $current $current $current" - -cleanup { - set tcltest::workingDirectory $old - cd $current - } -} - -# clean up from directory testing - -switch $tcl_platform(platform) { - "unix" { - file attributes $notReadableDir -permissions 777 - file attributes $notWriteableDir -permissions 777 - } - default { - file attributes $notWriteableDir -readonly 0 - } -} - -file delete -force $notReadableDir $notWriteableDir - -# -file, -notfile, tcltest::matchFiles, tcltest::skipFiles -test tcltest-9.1 {-file a*.tcl} {unixOrPc} { - catch {exec $::tcltest::tcltest \ - [file join $::tcltest::testsDirectory all.tcl] -file a*.test} msg - list [regexp assocd\.test $msg] -} {1} -test tcltest-9.2 {-file a*.tcl} {unixOrPc} { - catch {exec $::tcltest::tcltest \ - [file join $::tcltest::testsDirectory all.tcl] \ - -file a*.test -notfile assocd*} msg - list [regexp assocd\.test $msg] -} {0} - -test tcltest-9.3 {tcltest::matchFiles} { - -body { - set old [tcltest::matchFiles] - tcltest::matchFiles foo - set current [tcltest::matchFiles] - tcltest::matchFiles bar - set new [tcltest::matchFiles] - tcltest::matchFiles $old - list $current $new - } - -result {foo bar} -} - -test tcltest-9.4 {tcltest::skipFiles} { - -body { - set old [tcltest::skipFiles] - tcltest::skipFiles foo - set current [tcltest::skipFiles] - tcltest::skipFiles bar - set new [tcltest::skipFiles] - tcltest::skipFiles $old - list $current $new - } - -result {foo bar} -} - -# -preservecore, tcltest::preserveCore -makeFile { - package require tcltest - namespace import -force ::tcltest::* - - test makecore {make a core file} { - set f [open core w] - close $f - } {} - ::tcltest::cleanupTests - return -} makecore.tcl - -test tcltest-10.1 {-preservecore 0} {unixOrPc} { - catch {exec $::tcltest::tcltest makecore.tcl -preservecore 0} msg - file delete core - regexp "Core file produced" $msg -} {0} -test tcltest-10.2 {-preservecore 1} {unixOrPc} { - catch {exec $::tcltest::tcltest makecore.tcl -preservecore 1} msg - file delete core - regexp "Core file produced" $msg -} {1} -test tcltest-10.3 {-preservecore 2} {unixOrPc} { - catch {exec $::tcltest::tcltest makecore.tcl -preservecore 2} msg - file delete core - list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ - [regexp "core-" $msg] [file delete core-makecore] -} {1 1 1 {}} -test tcltest-10.4 {-preservecore 3} {unixOrPc} { - catch {exec $::tcltest::tcltest makecore.tcl -preservecore 3} msg - file delete core - list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ - [regexp "core-" $msg] [file delete core-makecore] -} {1 1 1 {}} - -test tcltest-10.5 {tcltest::preserveCore} { - -body { - set old [tcltest::preserveCore] - set result [tcltest::preserveCore foo] - set result2 [tcltest::preserveCore] - tcltest::preserveCore $old - list $result $result2 - } - -result {foo foo} -} - -# -load, -loadfile, tcltest::loadScript, tcltest::loadFile -set loadfile [makeFile { - package require tcltest - namespace import -force ::tcltest::* - puts $::tcltest::loadScript - exit -} load.tcl] - -test tcltest-12.1 {-load xxx} {unixOrPc} { - catch {exec $::tcltest::tcltest load.tcl -load xxx} msg - set msg -} {xxx} - -test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} { - catch {exec $::tcltest::tcltest load.tcl -debug 2 -loadfile load.tcl} msg - list \ - [regexp {tcltest} [join $msg [split $msg \n]]] \ - [regexp {loadScript} [join $msg [split $msg \n]]] -} {1 1} - -test tcltest-12.3 {tcltest::loadScript} { - -setup { - set old $tcltest::loadScript - set tcltest::load-body {} - } - -body { - set f1 [tcltest::loadScript] - set f2 [tcltest::loadScript xxx] - set f3 [tcltest::loadScript] - list $f1 $f2 $f3 - } - -result {{} xxx xxx} - -cleanup { - set tcltest::loadScript $old - } -} - -test tcltest-12.4 {tcltest::loadFile} { - -setup { - set olds $tcltest::loadScript - set tcltest::load-body {} - set oldf $tcltest::loadFile - set tcltest::loadFile {} - } - -body { - set f1 [tcltest::loadScript] - set f2 [tcltest::loadFile] - set f3 [tcltest::loadFile load.tcl] - set f4 [tcltest::loadScript] - set f5 [tcltest::loadFile] - list $f1 $f2 $f3 $f4 $f5 - } - -result "{} {} $loadfile { - package require tcltest - namespace import -force ::tcltest::* - puts \$::tcltest::loadScript - exit -} $loadfile -" - -cleanup { - set tcltest::loadScript $olds - set tcltest::loadFile $oldf - } -} - -# tcltest::interpreter -test tcltest-13.1 {tcltest::interpreter} { - -setup { - set old $tcltest::tcltest - set tcltest::tcltest tcltest - } - -body { - set f1 [tcltest::interpreter] - set f2 [tcltest::interpreter tclsh] - set f3 [tcltest::interpreter] - list $f1 $f2 $f3 - } - -result {tcltest tclsh tclsh} - -cleanup { - set tcltest::tcltest $old - } -} - -# -singleproc, tcltest::singleProcess -makeDirectory singleprocdir -makeFile { - set foo 1 -} [file join singleprocdir single1.test] - -makeFile { - unset foo -} [file join singleprocdir single2.test] - -set allfile [makeFile { - package require tcltest - namespace import -force tcltest::* - tcltest::testsDirectory [file join [tcltest::temporaryDirectory] singleprocdir] - tcltest::runAllTests -} [file join singleprocdir all-single.tcl]] - -test tcltest-14.1 {-singleproc - single process} { - -constraints {unixOrPc} - -body { - exec [tcltest::interpreter] $allfile -singleproc 0 - } - -result {Test file error: can't unset .foo.: no such variable} - -match regexp -} - -test tcltest-14.2 {-singleproc - multiple process} { - -constraints {unixOrPc} - -body { - exec [tcltest::interpreter] $allfile -singleproc 1 - } - -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0} - -match regexp -} - -test tcltest-14.3 {tcltest::singleProcess} { - -setup { - set old $tcltest::singleProcess - set tcltest::singleProcess 0 - } - -body { - set f1 [tcltest::singleProcess] - set f2 [tcltest::singleProcess 1] - set f3 [tcltest::singleProcess] - list $f1 $f2 $f3 - } - -result {0 1 1} - -cleanup { - set tcltest::singleProcess $old - } -} - -# -asidefromdir, -relateddir, tcltest::matchDirectories, -# tcltest::skipDirectories - -# Before running these tests, need to set up test subdirectories with their own -# all.tcl files. - -makeDirectory dirtestdir -makeDirectory [file join dirtestdir dirtestdir2.1] -makeDirectory [file join dirtestdir dirtestdir2.2] -makeDirectory [file join dirtestdir dirtestdir2.3] -makeFile { - package require tcltest - namespace import -force tcltest::* - tcltest::testsDirectory [file join [tcltest::temporaryDirectory] \ - dirtestdir] - tcltest::runAllTests -} [file join dirtestdir all.tcl] -makeFile { - package require tcltest - namespace import -force tcltest::* - tcltest::testsDirectory [file join [tcltest::temporaryDirectory] \ - dirtestdir dirtestdir2.1] - tcltest::runAllTests -} [file join dirtestdir dirtestdir2.1 all.tcl] -makeFile { - package require tcltest - namespace import -force tcltest::* - tcltest::testsDirectory [file join [tcltest::temporaryDirectory] \ - dirtestdir dirtestdir2.2] - tcltest::runAllTests -} [file join dirtestdir dirtestdir2.2 all.tcl] -makeFile { - package require tcltest - namespace import -force tcltest::* - tcltest::testsDirectory [file join [tcltest::temporaryDirectory] \ - dirtestdir dirtestdir2.3] - tcltest::runAllTests -} [file join dirtestdir dirtestdir2.3 all.tcl] - -test tcltest-15.1 {basic directory walking} { - -constraints {unixOrPc} - -body { - exec [tcltest::interpreter] [file join \ - [tcltest::temporaryDirectory] dirtestdir all.tcl] - } - -match regexp - -returnCodes 1 - -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*Tests located in:.*dirtestdir2.3} -} - -test tcltest-15.2 {-asidefromdir} { - -constraints {unixOrPc} - -body { - exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -asidefromdir dirtestdir2.3 - } - -match regexp - -returnCodes 1 - -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*dirtestdir2.2 test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Error: No test files remain after applying your match and skip patterns! -Error: No test files remain after applying your match and skip patterns! -Error: No test files remain after applying your match and skip patterns!$} -} - -test tcltest-15.3 {-relateddir, non-existent dir} { - -constraints {unixOrPc} - -body { - exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -relateddir [file join [tcltest::temporaryDirectory] dirtestdir0] - } - -returnCodes 1 - -match regexp - -result {[^~]|dirtestdir[^2]} -} - -test tcltest-15.4 {-relateddir, subdir} { - -constraints {unixOrPc} - -body { - exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -relateddir dirtestdir2.1 - } - -returnCodes 1 - -match regexp - -result {Tests located in:.*dirtestdir2.[^23]} -} -test tcltest-15.5 {-relateddir, -asidefromdir} { - -constraints {unixOrPc} - -body { - exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -relateddir "dirtestdir2.1 dirtestdir2.2" -asidefromdir dirtestdir2.2 - } - -match regexp - -returnCodes 1 - -result {Tests located in:.*dirtestdir2.[^23]} -} - -test tcltest-15.6 {tcltest::matchDirectories} { - -setup { - set old [tcltest::matchDirectories] - set tcltest::matchDirectories {} - } - -body { - set r1 [tcltest::matchDirectories] - set r2 [tcltest::matchDirectories foo] - set r3 [tcltest::matchDirectories] - list $r1 $r2 $r3 - } - -cleanup { - set tcltest::matchDirectories $old - } - -result {{} foo foo} -} - -test tcltest-15.7 {tcltest::skipDirectories} { - -setup { - set old [tcltest::skipDirectories] - set tcltest::skipDirectories {} - } - -body { - set r1 [tcltest::skipDirectories] - set r2 [tcltest::skipDirectories foo] - set r3 [tcltest::skipDirectories] - list $r1 $r2 $r3 - } - -cleanup { - set tcltest::skipDirectories $old - } - -result {{} foo foo} -} - -# TCLTEST_OPTIONS -test tcltest-19.1 {TCLTEST_OPTIONS default} { - -constraints {unixOrPc} - -setup { - if {[info exists ::env(TCLTEST_OPTIONS)]} { - set oldoptions $::env(TCLTEST_OPTIONS) - unset ::env(TCLTEST_OPTIONS) -c } else { - set oldoptions none - } - set ::env(TCLTEST_OPTIONS) {} - set olddebug [tcltest::debug] - tcltest::debug 2 - } - -cleanup { - if {$oldoptions == "none"} { - unset ::env(TCLTEST_OPTIONS) - } else { - set ::env(TCLTEST_OPTIONS) $oldoptions - } - tcltest::debug $olddebug - } - -body { - tcltest::processCmdLineArgs - set ::env(TCLTEST_OPTIONS) "-debug 3" - tcltest::processCmdLineArgs - } - -result {^$} - -match regexp - -output {tcltest::debug\s+= 2.*tcltest::debug\s+= 3} -} - -# Begin testing of tcltest procs ... - -# PrintError -test tcltest-20.1 {PrintError} {unixOrPc} { - set result [catch {exec $::tcltest::tcltest printerror.tcl} msg] - list $result [regexp "Error: a really short string" $msg] \ - [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \ - [regexp " \"Really" $msg] [regexp Problem $msg] -} {1 1 1 1 1 1} - -# test::test -test tcltest-21.1 {expect with glob} { - -body { - list a b c d e - } - -match glob - -result {[ab] b c d e} -} - -test tcltest-21.2 {force a test command failure} { - -body { - test foo { - return 2 - } {1} - } - -errorOutput {^test foo: bad flag 1 supplied to tcltest::test\n$} - -result {1} - -match regexp -} - -test tcltest-21.3 {test command with setup} { - -setup { - set foo 1 - } - -body { - set foo - } - -cleanup {unset foo} - -result {1} -} - -test tcltest-21.4 {test command with cleanup failure} { - -setup { - if {[info exists foo]} { - unset foo - } - } - -body { - test foo-1 {foo-1} { - -cleanup {unset foo} - } - } - -result {^0$} - -match regexp - -output "Test cleanup failed:.*can't unset \"foo\": no such variable" -} - -test tcltest-21.5 {test command with setup failure} { - -setup { - if {[info exists foo]} { - unset foo - } - } - -body { - test foo-2 {foo-2} { - -setup {unset foo} - } - } - -result {^0$} - -match regexp - -output "Test setup failed:.*can't unset \"foo\": no such variable" -} - -test tcltest-21.6 {test command - setup occurs before cleanup & before script} { - -body { - test foo-3 {foo-3} { - -setup { - if {[info exists foo]} { - unset foo - } - set foo 1 - set expected 2 - } - -body { - incr foo - set foo - } - -cleanup { - if {$foo != 2} { - puts [tcltest::outputChannel] "foo is wrong" - } else { - puts [tcltest::outputChannel] "foo is 2" - } - } - -result {$expected} - } - } - -result {^0$} - -match regexp - -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) - -test tcltest-21.7 {expect with glob} \ - -body {list a b c d e} \ - -result {[ab] b c d e} \ - -match glob - -test tcltest-21.8 {force a test command failure} -body { - test foo { - return 2 - } {1} -} -errorOutput {test foo: bad flag 1 supplied to tcltest::test -} -result {1} - -test tcltest-21.9 {test command with setup} \ - -setup {set foo 1} \ - -body {set foo} \ - -cleanup {unset foo} \ - -result {1} - -test tcltest-21.10 {test command with cleanup failure} -setup { - if {[info exists foo]} { - unset foo - } -} -body { - test foo-1 {foo-1} -cleanup {unset foo} -} -result {^0$} -match regexp \ - -output {Test cleanup failed:.*can't unset \"foo\": no such variable} - -test tcltest-21.11 {test command with setup failure} -setup { - if {[info exists foo]} { - unset foo - } -} -body { - test foo-2 {foo-2} -setup {unset foo} -} -result {^0$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp - -test tcltest-21.12 {test command - setup occurs before cleanup & before script} -body { - test foo-3 {foo-3} -setup { - if {[info exists foo]} { - unset foo - } - set foo 1 - set expected 2 - } -body { - incr foo - set foo - } -cleanup { - if {$foo != 2} { - puts [tcltest::outputChannel] "foo is wrong" - } else { - puts [tcltest::outputChannel] "foo is 2" - } - } -result {$expected} -} -result {^0$} -output {foo is 2} -match regexp - -# test all.tcl usage (runAllTests); simulate .test file failure, as well as -# crashes to determine whether or not these errors are logged. - -makeDirectory alltestdir -makeFile { - package require tcltest - namespace import -force tcltest::* - tcltest::testsDirectory [file join [tcltest::temporaryDirectory] \ - alltestdir] - tcltest::runAllTests -} [file join alltestdir all.tcl] -makeFile { - exit 1 -} [file join alltestdir exit.test] -makeFile { - error "throw an error" -} [file join alltestdir error.test] -makeFile { - package require tcltest - namespace import -force tcltest::* - test foo-1.1 {foo} { - -body { return 1 } - -result {1} - } - tcltest::cleanupTests -} [file join alltestdir test.test] - -test tcltest-22.1 {runAllTests} { - -constraints {unixOrPc} - -body { - exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] alltestdir all.tcl] -verbose t - } - -match regexp - -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 -} - -::tcltest::cleanupTests -return |