diff options
| -rw-r--r-- | ChangeLog | 45 | ||||
| -rwxr-xr-x | doc/tcltest2.n | 1044 | ||||
| -rw-r--r-- | generic/tcl.h | 3 | ||||
| -rw-r--r-- | library/tcltest/pkgIndex.tcl | 12 | ||||
| -rwxr-xr-x | library/tcltest/tcltest2.tcl | 3122 | ||||
| -rw-r--r-- | library/tcltest1.0/pkgIndex.tcl | 12 | ||||
| -rwxr-xr-x | library/tcltest1.0/tcltest2.tcl | 3122 | ||||
| -rw-r--r-- | tests/all.tcl | 83 | ||||
| -rw-r--r-- | tests/cmdAH.test | 6 | ||||
| -rw-r--r-- | tests/socket.test | 9 | ||||
| -rwxr-xr-x | tests/tcltest.test | 16 | ||||
| -rwxr-xr-x | tests/tcltest2.test | 1121 | ||||
| -rw-r--r-- | tools/tcl.wse.in | 5 | ||||
| -rw-r--r-- | unix/mkLinks | 4 |
14 files changed, 8530 insertions, 74 deletions
@@ -1,3 +1,48 @@ +2000-09-20 Jennifer Hom <jenn@ajubasolutions.com> + + * library/tcltest1.0/pkgIndex.tcl: Updated to load tcltest 2.0. + * library/tcltest1.0/tcltest2.tcl: New version of tcltest. + Cleanup of command line parsing: allows users to specify command + line arguments through an environment variable named + TCLTEST_OPTIONS [RFE: 3748], does not respond to incorrect + arguments, and forces usage of entire flag name when using command + line arguments. Defines accessor procs for all tcltest + variables. Allows users to use 'return' in test scripts. Allow + users to specify whether test files should be sourced or run in a + separate process. 'all.tcl' code moved to tcltest package. + 'test' proc modified to use attribute-value pairs. Allow users to + specify what return codes, output, and errors can be compared and + whether these values should be compared using regexp, glob, or + exact matching. makeDirectory & removeDirectory now operate with + respect to temporaryDirectory [Bug: 6001]. Test results from + tests run in slave interpreters are now included in test totals + [Bug: 1493]. Test files that return error values are now reported. + + * tests/all.tcl: Added code to check for the tcltest version + loaded; modified to figure out which tests to run based on the + tcltest version loaded. + * tests/tcltest.test: Modified to explicitly load version 1.0 of + tcltest. + * tests/tcltest2.test: New test suite for tcltest; includes all of + the old tests plus new ones reflecting changes made for version + 2.0. + * tests/cmdAH.test: Added singleTestInterp constraint to + cmdAH-31.2; this test does not run if tests aren't sourced into a + single interpreter. + * tests/socket.test: Fixed two tests that were referencing + variables outside of scope. + + * tools/tcl.wse.in: Added code to install tcltest2.tcl. + + * doc/tcltest2.n: New documentation for tcltest version 2.0. + Removes documentation for tcltest namespace variables. Adds + documentation for new tcltest procs. + + * unix/mkLinks: Added code to link to tcltest2.n. + + * generic/tcl.h: Added comment to modify tcltest2.tcl as well as + tcltest.tcl for version changes. + 2000-09-19 Eric Melski <ericm@ajubasolutions.com> * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): When using -all, all diff --git a/doc/tcltest2.n b/doc/tcltest2.n new file mode 100755 index 0000000..86c2f48 --- /dev/null +++ b/doc/tcltest2.n @@ -0,0 +1,1044 @@ +'\" +'\" 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.1 2000/09/20 23:09:49 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 {?attribute 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?level?\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\fR +.sp +\fBtcltest::removeFile \fIname\fR +.sp +\fBtcltest::makeDirectory \fIname\fR +.sp +\fBtcltest::removeDirectory \fIname\fR +.sp +\fBtcltest::viewFile \fIname\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 {?attribute 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?level?\fR +Sets or returns the current verbosity level. This level must be a +substring of "bpst". The default verbosity level is "b". See the +"Test output" section for a more detailed explanation of this +option. Levels are defined as: +.RS +.IP b +Display the body of failed tests +.IP p +Print output when a test passes +.IP s +Print output when a test is skipped +.IP t +Print output whenever a test starts +.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. +.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::mainThread\fR +Sets or returns the main thread ID. This defaults to 1. This is the +only thread that is not killed by tcltest::threadReap and is set +according to the return value of \fItestthread names\fR at +initialization. +.TP +\fBtcltest::makeFile\fP \fIcontents name\fR +Create a file that will be automatically be removed by +\fBtcltest::cleanupTests\fR at the end of a test file. This file is +created relative to tcltest::temporaryDirectory. +Returns the full path of the file created. +.TP +\fBtcltest::removeFile\fP \fIname\fR +Force the file referenced by \fIname\fR to be removed. This file name +should be relative to \fItcltest::temporaryDirectory\fR. This proc has no +defined return values. +.TP +\fBtcltest::makeDirectory\fP \fIname\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 tcltest::temporaryDirectory. This proc +has no defined return value. +.TP +\fBtcltest::viewFile\fP \fIfile\fR +Returns the contents of \fIfile\fR. +.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. +.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: +.DS +test \fIname\fR { + description \fIdescription\fR + ?constraints \fIkeywordList|expression\fR + ?setup \fIsetupScript\fR? + ?script \fItestScript\fR? + ?cleanup \fIcleanupScript\fR? + ?expect \fIexpectedAnswer\fR? | + ?expect {-exact \fIexpectedAnswer\fR?}? | + ?expect {-regexp \fIexpectedAnswer\fR?}? | + ?expect {-glob \fIexpectedAnswer\fR?}? + ?expect_out \fIexpectedOutput\fR? | + ?expect_out {-exact \fIexpectedOutput\fR?}? | + ?expect_out {-regexp \fIexpectedOutput\fR?}? | + ?expect_out {-glob \fIexpectedOutput\fR?}? + ?expect_err \fIexpectedError\fR? | + ?expect_err {-exact \fIexpectedError\fR?}? | + ?expect_err {-regexp \fIexpectedError\fR?}? | + ?expect_err {-glob \fIexpectedError\fR?}? + ?expect_codes \fIcodeList\fR +} +.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 +Valid attributes and associated values are: +.TP +\fBdescription \fIdesc\fR\fP +A value must be provided for the required \fIdescription\fR attribute. +This should be a short textual description of the test used to help humans +understand the purpose of the test. 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. +.TP +\fBconstraints \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 +\fBsetup \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 +\fBscript \fIscript\fR\fP +The \fIscript\fR attribute indicates the script to run to carry out the +test. It must return a result that can be checked for correctness. +.TP +\fBcleanup \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 +\fBexpect \fI{?option? expectedValue}|expectedValue\fR\fP +The \fIexpect\fR attribute supplies the comparison value with which +the return value from script will be compared. Valid options for the +value supplied are "-regexp", "-glob", and "-exact". The default +comparison option is "-exact". +.TP +\fBexpect_out \fI{?option? expectedValue}|expectedValue\fR\fP +The \fIexpect_out\fR attribute supplies the comparison value with which +any output sent to stdout or tcltest::outputChannel during the script +run will be compared. Valid options for the +value supplied are "-regexp", "-glob", and "-exact". The default +comparison option is "-exact". Note that only output printed using +puts is used for comparison. +.TP +\fBexpect_err \fI{?option? expectedValue}|expectedValue\fR\fP +The \fIexpect_err\fR attribute supplies the comparison value with which +any output sent to stderr or tcltest::errorChannel during the script +run will be compared. Valid options for the +value supplied are "-regexp", "-glob", and "-exact". The default +comparison option is "-exact". Note that only output printed using +puts is used for comparison. +.TP +\fBexpect_codes \fIexpectedCodes\fR\fP +The optional \fIexpect_code\fR attribute indicates which return codes +from the script supplied with the \fIscript\fR attribute are correct. +Default values for \fIexpectedCodes\fR are 0 (normal return) and 2 +(return exception). +.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 "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 +\fIpc\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 +\fIunixOrPc\fR +test can only be run on a UNIX or PC platform +.TP +\fImacOrPc\fR +test can only be run on a Mac or PC platform +.TP +\fImacOrUnix\fR +test can only be run on a Mac or UNIX platform +.TP +\fItempNotPc\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 +\fIpcCrash\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 commands such as 'cat', 'echo', +etc. 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 0|1\fR +if 0, run test files in multiple interpreters. if 1, source test +files into the current intpreter. +.TP +\fB-verbose <level>\fR +set the level of verbosity to a substring of "bpst". See the "Test +output" section for an explanation of this option. (tcltest::verbose) +.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::loadScript) +.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::outputChannel) +.TP +\fB-errfile <filename>\fR +print errors generated by the tcltest package to the named file. This +defaults to stderr. (tcltest::errorChannel) +.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 'ps'"). 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), determines which test +files to run, sources each of these files, calls +tcltest::cleanupTests and then exits. +.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 substring or permutation +of "bpst". In the string "bpst", the 'b' stands for a test's "body", +the 'p' stands for "passed" tests, the 's' stands for "skipped" +tests, and the 't' indicates when a test "starts". +The default value of \fBtcltest::verbose\fR is "b". If 'b' +is present, then the entire body of the test is printed for each +failed test, otherwise only the test's name, desired output, and +actual output, are printed for each failed test. If 'p' is present, +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 +the consraints that cause the test to be skipped) is printed for each +skipped test, otherwise no line is printed for skipped tests. If 't' +is present, then a line is printed each time a new test starts. +.PP +You can set \fBtcltest::verbose\fR either interactively (after the +\fBtcltest\fR package has been loaded) or by using the command line +argument \fB-verbose\fR, for example: +.DS +tclsh socket.test -verbose bps +.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 { + description {save 1 in variable name foo} + script { + set foo 1 + } + expect {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' +.IP [5] A test that uses the unixOnly constraint and should only be +run on Unix +.DS +test getAttribute-1.1 { + description {testing file permissions} + constraints {unixOnly} + script { + lindex [file attributes foo.tcl] 5 + } + expect {00644} +} +.DE +.IP [6] A constraint containing an 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 + unixOnly && !testthread +.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 { + description {level 1} + script { + test level-2.1 { + description {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/generic/tcl.h b/generic/tcl.h index 5d239e9..62d895f 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.79 2000/09/14 18:42:29 ericm Exp $ + * RCS: @(#) $Id: tcl.h,v 1.80 2000/09/20 23:09:51 jenn Exp $ */ #ifndef _TCL @@ -51,6 +51,7 @@ extern "C" { * unix/README (not patchlevel) (part (h)) * unix/tcl.spec (2 LOC Major/Minor, 1 LOC patch) * library/tcltest1.0/tcltest.tcl (1 LOC M/M, 1 LOC patch) + * library/tcltest1.0/tcltest2.tcl (1 LOC M/M, 1 LOC patch) * tools/tcl.hpj.in (not patchlevel, for windows installer) * tools/tcl.wse.in (for windows installer) * tools/tclSplash.bmp (not patchlevel) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 7a58882..e3746e2 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -1,5 +1,5 @@ # Tcl package index file, version 1.1 -# This file is generated by the "pkg_mkIndex" command +# This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related @@ -8,11 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 \ - {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests \ - ::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg \ - ::tcltest::removeDirectory ::tcltest::removeFile \ - ::tcltest::restoreState ::tcltest::saveState ::tcltest::test \ - ::tcltest::threadReap ::tcltest::viewFile ::tcltest::grep \ - ::tcltest::getMatchingFiles ::tcltest::loadTestedCommands \ - ::tcltest::normalizePath }}}] +package ifneeded tcltest 1.0 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.0 [list source [file join $dir tcltest2.tcl]] diff --git a/library/tcltest/tcltest2.tcl b/library/tcltest/tcltest2.tcl new file mode 100755 index 0000000..9a6104e --- /dev/null +++ b/library/tcltest/tcltest2.tcl @@ -0,0 +1,3122 @@ +# 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.1 2000/09/20 23:09:52 jenn Exp $ + +package provide tcltest 2.0 + +# 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 "b" + if {![info exists verbose]} { + variable verbose "b" + } + + # 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 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. + # 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 + 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]] + } + } + + # Tcl version numbers + if {![info exists version]} { + variable version 8.4 + } + if {![info exists patchLevel]} { + variable patchLevel 8.4a1 + } + + # stdout and stderr buffers for use when we want to store them + if {![info exists outData]} { + variable outData {} + } + 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. +# + +proc tcltest::DebugPuts {level string} { + variable debug + if {$debug >= $level} { + puts $string + } +} + +# 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. +# + +proc tcltest::DebugPArray {level arrayvar} { + variable debug + + if {$debug >= $level} { + catch {upvar $arrayvar $arrayvar} + parray $arrayvar + } +} + +# 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. +# + +proc tcltest::DebugDo {level script} { + variable debug + + if {$debug >= $level} { + uplevel $script + } +} + +##################################################################### + +# 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]} { + 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. +# + +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. +# + +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. +# +# Arguments: +# A string containing any combination of 'pbst'. +# p = print output whenever a test passes +# b = print the body of the test when it fails +# s = print when a test is skipped +# t = print when a test starts +# +# Results: +# content of tcltest::verbose +# +# Side effects: +# None. + +proc tcltest::verbose { {level __QUERY} } { + if {$level == "__QUERY"} { + return $tcltest::verbose + } + set tcltest::verbose $level +} + +# 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 __QUERY} } { + if {$matchList == "__QUERY"} { + 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 __QUERY} } { + if {$skipList == "__QUERY"} { + 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 __QUERY} } { + if {$matchFileList == "__QUERY"} { + 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 __QUERY} } { + if {$skipFileList == "__QUERY"} { + 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 __QUERY} } { + if {$dirlist == "__QUERY"} { + 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 __QUERY} } { + if {$dirlist == "__QUERY"} { + 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 __QUERY} } { + if {$coreLevel == "__QUERY"} { + 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 __QUERY} } { + if {$filename == "__QUERY"} { + 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 __QUERY} } { + if {$filename == "__QUERY"} { + 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 __QUERY} } { + if {$filename == "__QUERY"} { + 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 __QUERY} } { + if {$filename == "__QUERY"} { + 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 __QUERY} } { + if {$debugLevel == "__QUERY"} { + 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 __QUERY}} { + DebugPuts 3 "entering testConstraint $constraint $value" + if {$value == "__QUERY"} { + 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 __QUERY} } { + DebugPuts 3 "entering limitConstraints $constraintList" + if {$constraintList == "__QUERY"} { + 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 __QUERY} } { + if {$script == "__QUERY"} { + 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 __QUERY} } { + if {$scriptFile == "__QUERY"} { + 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 __QUERY} } { + if {$dir == "__QUERY"} { + 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 __QUERY} } { + if {$dir == "__QUERY"} { + 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 __QUERY} } { + if {$dir == "__QUERY"} { + 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: +# 0 = source each test file +# 1 = run each test file in its own process +# +# Results: +# content of tcltest::singleProcess +# +# Side effects: +# None. + +proc tcltest::singleProcess { {value __QUERY} } { + if {$value == "__QUERY"} { + 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 __QUERY} } { + if {$interp == "__QUERY"} { + 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 __QUERY} } { + if {$threadid == "__QUERY"} { + 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. + +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 +# + +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::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. + +proc tcltest::safeFetch {n1 n2 op} { + DebugPuts 3 "entering safeFetch $n1 $n2 $op" + if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { + tcltest::testConstraint $n2 0 + } +} + +proc tcltest::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. + + trace variable tcltest::testConstraints r tcltest::safeFetch + + tcltest::initConstraintsHook + + tcltest::testConstraint singleTestInterp [singleProcess] + + 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 unix [tcltest::testConstraint unixOnly] + tcltest::testConstraint mac [tcltest::testConstraint macOnly] + tcltest::testConstraint pc [tcltest::testConstraint pcOnly] + + tcltest::testConstraint unixOrPc \ + [expr {[tcltest::testConstraint unix] \ + || [tcltest::testConstraint pc]}] + tcltest::testConstraint macOrPc \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint pc]}] + 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 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 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 +# + +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' and 't'. 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 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] +} + +# 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. + +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 +} + +##################################################################### + +# 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. + 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 +# subst - perform subst on the expected value if this is true +# +# Results: +# result of the match +# +# Side effects: +# None. + +proc tcltest::compareStrings {actual expected mode {subst false}} { + if {$subst} { + switch -- $mode { + exact { + set expected [uplevel 2 subst \{$expected\}] + } + glob - + regexp { + set expected [uplevel 2 subst -nocommand -nobackslashes \{$expected\}] + } + } + } + switch -- $mode { + exact { + set retval [string equal $actual $expected] + } + glob { + set retval [string match $expected $actual] + } + regexp { + set retval [regexp $expected $actual] + } + } + return $retval +} + + +# 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. +# +# 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 attribute is optional; default is {} +# script - 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 {} +# expect - Expected result from script. This attribute is +# optional; default is {}. +# expect_out - Expected output sent to stdout. This attribute +# is optional; default is {}. +# expect_err - Expected output sent to stderr. This attribute +# is optional; default is {}. +# expect_codes - 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 {}. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# +# Results: +# 0 if the command ran successfully; 1 otherwise. +# +# Side effects: +# +proc tcltest::test {name args} { + DebugPuts 3 "Test $name $args" + + incr tcltest::testLevel + + # Pre-define everything to null except expect_out and expect_err. We + # determine whether or not to trap output based on whether or not these + # variables (expect_out & expect_err) are defined. + foreach item {constraints setup cleanup description script \ + expect expect_codes} { + set $item {} + } + + # Set the default match mode + set expectMatch exact + set expect_outMatch exact + set expect_errMatch exact + + # default test format is the old format (where we don't have to subst the + # expected answer + set substExpected false + + # 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 expect_codes [list 0 2] + + if {[llength $args] >= 3} { + # This is parsing for the old test command format; it is here for + # backward compatibility. + set description [lindex $args 0] + set expect [lindex $args end] + if {[llength $args] == 3} { + set script [lindex $args 1] + } else { + set constraints [lindex $args 1] + set script [lindex $args 2] + } + } else { + # we'll have to do a subst on the expected values later + set substExpected true + + set testAttributes [lindex $args 0] + + # These are attribute value pairs; there must be an even number in the + # list. + if {[expr {[llength $testAttributes] %2}] == 1} { + puts [errorChannel] "value for \"[lindex $testAttributes end]\" missing" + incr tcltest::testLevel -1 + return 1 + } + + # store whatever the user gave us + foreach {item value} $testAttributes { + set $item $value + } + + foreach mode {expect expect_out expect_err} { + if {[info exists $mode]} { + set expectedContent [subst $$mode] + set suffix Match + # Set the match mode and the content based on whether or not + # the exact, glob, or regexp flags are being used. If they + # are, set the appropriate match flag and reset the match + # pattern. + if {[llength $expectedContent] == 2} { + set flag [lindex $expectedContent 0] + if {[regexp -- {-(exact|glob|regexp)} $flag fullMatch \ + $mode$suffix]} { + set $mode [lindex $expectedContent 1] + } + } + } + } + } + + if {($name == {}) || ($description == {})} { + puts [errorChannel] "one of: name, description empty" + 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 $script \ + $expect $constraints] + if {!$setupFailure} { + if {[info exists expect_out] || [info exists expect_err]} { + 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} { + puts "checking for core" + 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)} { + puts "core failure (> 1)" + 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 expectedAnswer $expect + + 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 expect_out]} { + set outputFailure [expr ![compareStrings $tcltest::outData \ + $expect_out $expect_outMatch $substExpected]] + } + if {[info exists expect_err]} { + set errorFailure [expr ![compareStrings $tcltest::errData \ + $expect_err $expect_errMatch $substExpected]] + } + + set testFailed 1 + set codeFailure 0 + + if {!($setupFailure || $cleanupFailure || $coreFailure || \ + $outputFailure || $errorFailure)} { + # if the strings compare properly, and we didn't experience a + # problem with setup or cleanup, we might have passed. + if {[compareStrings $actualAnswer $expectedAnswer $expectMatch $substExpected]} { + # if the return code matches the expected return codes, we + # definitely passed. + if {[lsearch -exact $code $expect_codes]} { + set codeFailure 0 + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Passed) + if {[string first p $tcltest::verbose] != -1} { + puts [outputChannel] "++++ $name PASSED" + } + } + set testFailed 0 + } else { + set codeFailure 1 + } + } + } + + if {$testFailed} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Failed) + } + set tcltest::currentFailure true + if {[string first b $tcltest::verbose] == -1} { + set script "" + } + puts [outputChannel] "\n==== $name $description FAILED" + if {$script != ""} { + puts [outputChannel] "==== Contents of test case:" + puts [outputChannel] $script + } + if {$setupFailure} { + puts [outputChannel] "---- Test setup failed:\n$setupMsg" + } else { + puts [outputChannel] "---- Result should have been ($expectMatch matching):\n$expectedAnswer" + puts [outputChannel] "---- Result was:\n$actualAnswer" + } + if {$codeFailure} { + puts [outputChannel] "---- Return code should have been one of: $expect_codes" + 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" + } + if {$outputFailure} { + puts [outputChannel] "---- Output should have been ($expect_outMatch matching):\n$expect_out" + puts [outputChannel] "---- Output was:\n$tcltest::outData" + } + if {$errorFailure} { + puts [outputChannel] "---- Error output should have been ($expect_errMatch matching):\n$expect_err" + puts [outputChannel] "---- Error output was:\n$tcltest::errData" + } + 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. +# +# Returns: +# empty list if test is skipped; otherwise returns list containing +# actual returned value from the test and the return code. + +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 {[string first s $tcltest::verbose] != -1} { + 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} { + puts "check for core 2" + 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 {[string first t $tcltest::verbose] != -1} { + 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). + +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] +} + +##################################################################### + +# 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 +# +# Results: +# The constructed list is returned to the user. This will primarily +# be used in 'all.tcl' files. + +proc tcltest::getMatchingFiles {args} { + set matchingFiles {} + if {[llength $args]} { + set searchDirectory $args + } else { + set searchDirectory [list $tcltest::testsDirectory] + } + # 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: +# none +# +# 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. + +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 [list [list shell [tcltest::interpreter]]] { + global argv + + 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 {[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} { + 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 { + set pipeFd [open $cmd "r"] + while {[gets $pipeFd line] >= 0} { + if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + incr tcltest::numTests($index) [set $index] + } + incr tcltest::numTestFiles + if {$Failed > 0} { + lappend tcltest::failFiles $testFile + } + } 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] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + } +} + +##################################################################### + +# 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 + +proc tcltest::loadTestedCommands {} { + if {$tcltest::loadScript == {}} { + return + } + + uplevel $tcltest::loadScript +} + +# The following two procs are used in the io tests. + +proc tcltest::openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +proc tcltest::leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak +} + +# tcltest::saveState -- +# +# Save information regarding what procs and variables exist. +# +# Arguments: +# none +# +# Results: +# Modifies the variable tcltest::saveState + +proc tcltest::saveState {} { + uplevel {set tcltest::saveState [list [info procs] [info vars]]} + DebugPuts 2 "tcltest::saveState: $tcltest::saveState" +} + +# tcltest::restoreState -- +# +# Remove procs and variables that didn't exist before the call to +# tcltest::saveState. +# +# Arguments: +# none +# +# Results: +# Removes procs and variables from your environment if they don't exist +# in the tcltest::saveState variable. + +proc tcltest::restoreState {} { + foreach p [info procs] { + if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \ + (![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}" + } + } +} + +# tcltest::normalizeMsg -- +# +# Removes "extra" newlines from a string. +# +# Arguments: +# msg String to be modified +# + +proc tcltest::normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + regsub -all "\n\n" $msg "\n" msg + regsub -all "\n\}" $msg "\}" msg + return $msg +} + +# 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. +# +proc tcltest::makeFile {contents name} { + global tcl_platform + + DebugPuts 3 "tcltest::makeFile: putting $contents into $name" + + set fullName [file join $tcltest::temporaryDirectory $name] + 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 +# + +proc tcltest::removeFile {name} { + DebugPuts 3 "tcltest::removeFile: removing $name" + file delete [file join $tcltest::temporaryDirectory $name] +} + +# 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. +# +proc tcltest::makeDirectory {name} { + DebugPuts 3 "tcltest::makeDirectory: creating $name" + set fullName [file join $tcltest::temporaryDirectory $name] + 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 +# + +proc tcltest::removeDirectory {name} { + DebugPuts 3 "tcltest::removeDirectory: deleting $name" + file delete -force [file join $tcltest::temporaryDirectory $name] +} + +proc tcltest::viewFile {name} { + global tcl_platform + if {([string equal $tcl_platform(platform) "macintosh"]) || \ + ([tcltest::testConstraint 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] + } +} + +# grep -- +# +# Evaluate a given expression against each element of a list and return all +# elements for which the expression evaluates to true. For the purposes of +# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the +# value of the current element within the expression. This is equivalent to +# the perl grep command where CURRENT_ELEMENT would be the name for the special +# variable $_. +# +# Examples of usage would be: +# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] +# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] +# +# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is +# assumed to be the final argument to the expression provided. +# +# Example: +# grep {regexp a} $someList +# +proc tcltest::grep { expression searchList } { + foreach element $searchList { + if {[regsub -all CURRENT_ELEMENT $expression $element \ + newExpression] == 0} { + set newExpression "$expression {$element}" + } + if {[eval $newExpression] == 1} { + lappend returnList $element + } + } + if {[info exists returnList]} { + return $returnList + } + return +} + +# +# 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. + +proc tcltest::bytestring {string} { + encoding convertfrom identity $string +} + +# +# Internationalization / ISO support procs -- dl +# +proc tcltest::set_iso8859_1_locale {} { + if {[info commands testlocale] != ""} { + set tcltest::previousLocale [testlocale ctype] + testlocale ctype $tcltest::isoLocale + } + return +} + +proc tcltest::restore_locale {} { + if {[info commands testlocale] != ""} { + testlocale ctype $tcltest::previousLocale + } + return +} + +# 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. +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 + } +} + +# 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] + } +} + diff --git a/library/tcltest1.0/pkgIndex.tcl b/library/tcltest1.0/pkgIndex.tcl index 7a58882..e3746e2 100644 --- a/library/tcltest1.0/pkgIndex.tcl +++ b/library/tcltest1.0/pkgIndex.tcl @@ -1,5 +1,5 @@ # Tcl package index file, version 1.1 -# This file is generated by the "pkg_mkIndex" command +# This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related @@ -8,11 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 \ - {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests \ - ::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg \ - ::tcltest::removeDirectory ::tcltest::removeFile \ - ::tcltest::restoreState ::tcltest::saveState ::tcltest::test \ - ::tcltest::threadReap ::tcltest::viewFile ::tcltest::grep \ - ::tcltest::getMatchingFiles ::tcltest::loadTestedCommands \ - ::tcltest::normalizePath }}}] +package ifneeded tcltest 1.0 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.0 [list source [file join $dir tcltest2.tcl]] diff --git a/library/tcltest1.0/tcltest2.tcl b/library/tcltest1.0/tcltest2.tcl new file mode 100755 index 0000000..9a6104e --- /dev/null +++ b/library/tcltest1.0/tcltest2.tcl @@ -0,0 +1,3122 @@ +# 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.1 2000/09/20 23:09:52 jenn Exp $ + +package provide tcltest 2.0 + +# 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 "b" + if {![info exists verbose]} { + variable verbose "b" + } + + # 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 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. + # 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 + 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]] + } + } + + # Tcl version numbers + if {![info exists version]} { + variable version 8.4 + } + if {![info exists patchLevel]} { + variable patchLevel 8.4a1 + } + + # stdout and stderr buffers for use when we want to store them + if {![info exists outData]} { + variable outData {} + } + 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. +# + +proc tcltest::DebugPuts {level string} { + variable debug + if {$debug >= $level} { + puts $string + } +} + +# 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. +# + +proc tcltest::DebugPArray {level arrayvar} { + variable debug + + if {$debug >= $level} { + catch {upvar $arrayvar $arrayvar} + parray $arrayvar + } +} + +# 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. +# + +proc tcltest::DebugDo {level script} { + variable debug + + if {$debug >= $level} { + uplevel $script + } +} + +##################################################################### + +# 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]} { + 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. +# + +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. +# + +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. +# +# Arguments: +# A string containing any combination of 'pbst'. +# p = print output whenever a test passes +# b = print the body of the test when it fails +# s = print when a test is skipped +# t = print when a test starts +# +# Results: +# content of tcltest::verbose +# +# Side effects: +# None. + +proc tcltest::verbose { {level __QUERY} } { + if {$level == "__QUERY"} { + return $tcltest::verbose + } + set tcltest::verbose $level +} + +# 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 __QUERY} } { + if {$matchList == "__QUERY"} { + 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 __QUERY} } { + if {$skipList == "__QUERY"} { + 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 __QUERY} } { + if {$matchFileList == "__QUERY"} { + 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 __QUERY} } { + if {$skipFileList == "__QUERY"} { + 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 __QUERY} } { + if {$dirlist == "__QUERY"} { + 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 __QUERY} } { + if {$dirlist == "__QUERY"} { + 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 __QUERY} } { + if {$coreLevel == "__QUERY"} { + 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 __QUERY} } { + if {$filename == "__QUERY"} { + 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 __QUERY} } { + if {$filename == "__QUERY"} { + 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 __QUERY} } { + if {$filename == "__QUERY"} { + 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 __QUERY} } { + if {$filename == "__QUERY"} { + 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 __QUERY} } { + if {$debugLevel == "__QUERY"} { + 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 __QUERY}} { + DebugPuts 3 "entering testConstraint $constraint $value" + if {$value == "__QUERY"} { + 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 __QUERY} } { + DebugPuts 3 "entering limitConstraints $constraintList" + if {$constraintList == "__QUERY"} { + 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 __QUERY} } { + if {$script == "__QUERY"} { + 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 __QUERY} } { + if {$scriptFile == "__QUERY"} { + 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 __QUERY} } { + if {$dir == "__QUERY"} { + 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 __QUERY} } { + if {$dir == "__QUERY"} { + 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 __QUERY} } { + if {$dir == "__QUERY"} { + 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: +# 0 = source each test file +# 1 = run each test file in its own process +# +# Results: +# content of tcltest::singleProcess +# +# Side effects: +# None. + +proc tcltest::singleProcess { {value __QUERY} } { + if {$value == "__QUERY"} { + 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 __QUERY} } { + if {$interp == "__QUERY"} { + 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 __QUERY} } { + if {$threadid == "__QUERY"} { + 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. + +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 +# + +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::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. + +proc tcltest::safeFetch {n1 n2 op} { + DebugPuts 3 "entering safeFetch $n1 $n2 $op" + if {($n2 != {}) && ([info exists tcltest::testConstraints($n2)] == 0)} { + tcltest::testConstraint $n2 0 + } +} + +proc tcltest::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. + + trace variable tcltest::testConstraints r tcltest::safeFetch + + tcltest::initConstraintsHook + + tcltest::testConstraint singleTestInterp [singleProcess] + + 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 unix [tcltest::testConstraint unixOnly] + tcltest::testConstraint mac [tcltest::testConstraint macOnly] + tcltest::testConstraint pc [tcltest::testConstraint pcOnly] + + tcltest::testConstraint unixOrPc \ + [expr {[tcltest::testConstraint unix] \ + || [tcltest::testConstraint pc]}] + tcltest::testConstraint macOrPc \ + [expr {[tcltest::testConstraint mac] \ + || [tcltest::testConstraint pc]}] + 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 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 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 +# + +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' and 't'. 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 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] +} + +# 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. + +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 +} + +##################################################################### + +# 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. + 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 +# subst - perform subst on the expected value if this is true +# +# Results: +# result of the match +# +# Side effects: +# None. + +proc tcltest::compareStrings {actual expected mode {subst false}} { + if {$subst} { + switch -- $mode { + exact { + set expected [uplevel 2 subst \{$expected\}] + } + glob - + regexp { + set expected [uplevel 2 subst -nocommand -nobackslashes \{$expected\}] + } + } + } + switch -- $mode { + exact { + set retval [string equal $actual $expected] + } + glob { + set retval [string match $expected $actual] + } + regexp { + set retval [regexp $expected $actual] + } + } + return $retval +} + + +# 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. +# +# 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 attribute is optional; default is {} +# script - 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 {} +# expect - Expected result from script. This attribute is +# optional; default is {}. +# expect_out - Expected output sent to stdout. This attribute +# is optional; default is {}. +# expect_err - Expected output sent to stderr. This attribute +# is optional; default is {}. +# expect_codes - 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 {}. +# +# Arguments: +# name - Name of test, in the form foo-1.2. +# +# Results: +# 0 if the command ran successfully; 1 otherwise. +# +# Side effects: +# +proc tcltest::test {name args} { + DebugPuts 3 "Test $name $args" + + incr tcltest::testLevel + + # Pre-define everything to null except expect_out and expect_err. We + # determine whether or not to trap output based on whether or not these + # variables (expect_out & expect_err) are defined. + foreach item {constraints setup cleanup description script \ + expect expect_codes} { + set $item {} + } + + # Set the default match mode + set expectMatch exact + set expect_outMatch exact + set expect_errMatch exact + + # default test format is the old format (where we don't have to subst the + # expected answer + set substExpected false + + # 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 expect_codes [list 0 2] + + if {[llength $args] >= 3} { + # This is parsing for the old test command format; it is here for + # backward compatibility. + set description [lindex $args 0] + set expect [lindex $args end] + if {[llength $args] == 3} { + set script [lindex $args 1] + } else { + set constraints [lindex $args 1] + set script [lindex $args 2] + } + } else { + # we'll have to do a subst on the expected values later + set substExpected true + + set testAttributes [lindex $args 0] + + # These are attribute value pairs; there must be an even number in the + # list. + if {[expr {[llength $testAttributes] %2}] == 1} { + puts [errorChannel] "value for \"[lindex $testAttributes end]\" missing" + incr tcltest::testLevel -1 + return 1 + } + + # store whatever the user gave us + foreach {item value} $testAttributes { + set $item $value + } + + foreach mode {expect expect_out expect_err} { + if {[info exists $mode]} { + set expectedContent [subst $$mode] + set suffix Match + # Set the match mode and the content based on whether or not + # the exact, glob, or regexp flags are being used. If they + # are, set the appropriate match flag and reset the match + # pattern. + if {[llength $expectedContent] == 2} { + set flag [lindex $expectedContent 0] + if {[regexp -- {-(exact|glob|regexp)} $flag fullMatch \ + $mode$suffix]} { + set $mode [lindex $expectedContent 1] + } + } + } + } + } + + if {($name == {}) || ($description == {})} { + puts [errorChannel] "one of: name, description empty" + 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 $script \ + $expect $constraints] + if {!$setupFailure} { + if {[info exists expect_out] || [info exists expect_err]} { + 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} { + puts "checking for core" + 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)} { + puts "core failure (> 1)" + 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 expectedAnswer $expect + + 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 expect_out]} { + set outputFailure [expr ![compareStrings $tcltest::outData \ + $expect_out $expect_outMatch $substExpected]] + } + if {[info exists expect_err]} { + set errorFailure [expr ![compareStrings $tcltest::errData \ + $expect_err $expect_errMatch $substExpected]] + } + + set testFailed 1 + set codeFailure 0 + + if {!($setupFailure || $cleanupFailure || $coreFailure || \ + $outputFailure || $errorFailure)} { + # if the strings compare properly, and we didn't experience a + # problem with setup or cleanup, we might have passed. + if {[compareStrings $actualAnswer $expectedAnswer $expectMatch $substExpected]} { + # if the return code matches the expected return codes, we + # definitely passed. + if {[lsearch -exact $code $expect_codes]} { + set codeFailure 0 + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Passed) + if {[string first p $tcltest::verbose] != -1} { + puts [outputChannel] "++++ $name PASSED" + } + } + set testFailed 0 + } else { + set codeFailure 1 + } + } + } + + if {$testFailed} { + if {$tcltest::testLevel == 1} { + incr tcltest::numTests(Failed) + } + set tcltest::currentFailure true + if {[string first b $tcltest::verbose] == -1} { + set script "" + } + puts [outputChannel] "\n==== $name $description FAILED" + if {$script != ""} { + puts [outputChannel] "==== Contents of test case:" + puts [outputChannel] $script + } + if {$setupFailure} { + puts [outputChannel] "---- Test setup failed:\n$setupMsg" + } else { + puts [outputChannel] "---- Result should have been ($expectMatch matching):\n$expectedAnswer" + puts [outputChannel] "---- Result was:\n$actualAnswer" + } + if {$codeFailure} { + puts [outputChannel] "---- Return code should have been one of: $expect_codes" + 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" + } + if {$outputFailure} { + puts [outputChannel] "---- Output should have been ($expect_outMatch matching):\n$expect_out" + puts [outputChannel] "---- Output was:\n$tcltest::outData" + } + if {$errorFailure} { + puts [outputChannel] "---- Error output should have been ($expect_errMatch matching):\n$expect_err" + puts [outputChannel] "---- Error output was:\n$tcltest::errData" + } + 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. +# +# Returns: +# empty list if test is skipped; otherwise returns list containing +# actual returned value from the test and the return code. + +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 {[string first s $tcltest::verbose] != -1} { + 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} { + puts "check for core 2" + 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 {[string first t $tcltest::verbose] != -1} { + 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). + +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] +} + +##################################################################### + +# 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 +# +# Results: +# The constructed list is returned to the user. This will primarily +# be used in 'all.tcl' files. + +proc tcltest::getMatchingFiles {args} { + set matchingFiles {} + if {[llength $args]} { + set searchDirectory $args + } else { + set searchDirectory [list $tcltest::testsDirectory] + } + # 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: +# none +# +# 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. + +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 [list [list shell [tcltest::interpreter]]] { + global argv + + 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 {[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} { + 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 { + set pipeFd [open $cmd "r"] + while {[gets $pipeFd line] >= 0} { + if {[regexp {^([^:]+):\tTotal\t([0-9]+)\tPassed\t([0-9]+)\tSkipped\t([0-9]+)\tFailed\t([0-9]+)} $line null testFile Total Passed Skipped Failed]} { + foreach index [list "Total" "Passed" "Skipped" "Failed"] { + incr tcltest::numTests($index) [set $index] + } + incr tcltest::numTestFiles + if {$Failed > 0} { + lappend tcltest::failFiles $testFile + } + } 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] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" + } +} + +##################################################################### + +# 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 + +proc tcltest::loadTestedCommands {} { + if {$tcltest::loadScript == {}} { + return + } + + uplevel $tcltest::loadScript +} + +# The following two procs are used in the io tests. + +proc tcltest::openfiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +proc tcltest::leakfiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {[lsearch $old $p] < 0} { + lappend leak $p + } + } + return $leak +} + +# tcltest::saveState -- +# +# Save information regarding what procs and variables exist. +# +# Arguments: +# none +# +# Results: +# Modifies the variable tcltest::saveState + +proc tcltest::saveState {} { + uplevel {set tcltest::saveState [list [info procs] [info vars]]} + DebugPuts 2 "tcltest::saveState: $tcltest::saveState" +} + +# tcltest::restoreState -- +# +# Remove procs and variables that didn't exist before the call to +# tcltest::saveState. +# +# Arguments: +# none +# +# Results: +# Removes procs and variables from your environment if they don't exist +# in the tcltest::saveState variable. + +proc tcltest::restoreState {} { + foreach p [info procs] { + if {([lsearch [lindex $tcltest::saveState 0] $p] < 0) && \ + (![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}" + } + } +} + +# tcltest::normalizeMsg -- +# +# Removes "extra" newlines from a string. +# +# Arguments: +# msg String to be modified +# + +proc tcltest::normalizeMsg {msg} { + regsub "\n$" [string tolower $msg] "" msg + regsub -all "\n\n" $msg "\n" msg + regsub -all "\n\}" $msg "\}" msg + return $msg +} + +# 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. +# +proc tcltest::makeFile {contents name} { + global tcl_platform + + DebugPuts 3 "tcltest::makeFile: putting $contents into $name" + + set fullName [file join $tcltest::temporaryDirectory $name] + 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 +# + +proc tcltest::removeFile {name} { + DebugPuts 3 "tcltest::removeFile: removing $name" + file delete [file join $tcltest::temporaryDirectory $name] +} + +# 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. +# +proc tcltest::makeDirectory {name} { + DebugPuts 3 "tcltest::makeDirectory: creating $name" + set fullName [file join $tcltest::temporaryDirectory $name] + 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 +# + +proc tcltest::removeDirectory {name} { + DebugPuts 3 "tcltest::removeDirectory: deleting $name" + file delete -force [file join $tcltest::temporaryDirectory $name] +} + +proc tcltest::viewFile {name} { + global tcl_platform + if {([string equal $tcl_platform(platform) "macintosh"]) || \ + ([tcltest::testConstraint 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] + } +} + +# grep -- +# +# Evaluate a given expression against each element of a list and return all +# elements for which the expression evaluates to true. For the purposes of +# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the +# value of the current element within the expression. This is equivalent to +# the perl grep command where CURRENT_ELEMENT would be the name for the special +# variable $_. +# +# Examples of usage would be: +# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] +# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] +# +# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is +# assumed to be the final argument to the expression provided. +# +# Example: +# grep {regexp a} $someList +# +proc tcltest::grep { expression searchList } { + foreach element $searchList { + if {[regsub -all CURRENT_ELEMENT $expression $element \ + newExpression] == 0} { + set newExpression "$expression {$element}" + } + if {[eval $newExpression] == 1} { + lappend returnList $element + } + } + if {[info exists returnList]} { + return $returnList + } + return +} + +# +# 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. + +proc tcltest::bytestring {string} { + encoding convertfrom identity $string +} + +# +# Internationalization / ISO support procs -- dl +# +proc tcltest::set_iso8859_1_locale {} { + if {[info commands testlocale] != ""} { + set tcltest::previousLocale [testlocale ctype] + testlocale ctype $tcltest::isoLocale + } + return +} + +proc tcltest::restore_locale {} { + if {[info commands testlocale] != ""} { + testlocale ctype $tcltest::previousLocale + } + return +} + +# 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. +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 + } +} + +# 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] + } +} + diff --git a/tests/all.tcl b/tests/all.tcl index df5cb3d..7c7ea53 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -5,51 +5,56 @@ # in this directory. # # Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: all.tcl,v 1.10 2000/04/10 17:18:56 ericm Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -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 nameofexecutable]" -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" -} +# RCS: @(#) $Id: all.tcl,v 1.11 2000/09/20 23:09:54 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" -} + 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]" + 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 + # 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 } -# cleanup -puts stdout "\nTests ended at [eval $timeCmd]" -::tcltest::cleanupTests 1 return - diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 68e4255..912cd30 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.10 2000/04/10 17:18:57 ericm Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.11 2000/09/20 23:09:54 jenn Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1495,13 +1495,13 @@ test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} { test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} { list [catch {file channels a b} msg] $msg } {1 {wrong # args: should be "file channels ?pattern?"}} -test cmdAH-31.2 {Tcl_FileObjCmd: channels, too many args} { +test cmdAH-31.2 {Tcl_FileObjCmd: channels, too many args} {singleTestInterp} { file chan } {stderr stdout stdin} test cmdAH-31.3 {Tcl_FileObjCmd: channels, too many args} { string equal [file channels] [file channels *] } {1} -test cmdAH-31.4 {Tcl_FileObjCmd: channels} { +test cmdAH-31.4 {Tcl_FileObjCmd: channels} {singleTestInterp} { set old [file channels gorp.file] set f [open gorp.file w] set new [file channels file*] diff --git a/tests/socket.test b/tests/socket.test index ba25211..9754f05 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: socket.test,v 1.14 2000/04/10 17:19:04 ericm Exp $ +# RCS: @(#) $Id: socket.test,v 1.15 2000/09/20 23:09:54 jenn Exp $ # Running socket tests with a remote server: # ------------------------------------------ @@ -1385,12 +1385,11 @@ test socket-12.1 {testing inheritance of server sockets} \ set f [open script2 w] puts $f [list set tcltest $::tcltest::tcltest] puts $f { - package require tcltest set f [socket -server accept 2828] proc accept { file addr port } { close $file } - exec $::tcltest::tcltest script1 & + exec $tcltest script1 & close $f after 1000 exit vwait forever @@ -1439,7 +1438,7 @@ test socket-12.2 {testing inheritance of client sockets} \ puts $f [list set tcltest $::tcltest::tcltest] puts $f { set f [socket 127.0.0.1 2829] - exec $::tcltest::tcltest script1 & + exec $tcltest script1 & puts $f testing flush $f after 1000 exit @@ -1521,7 +1520,7 @@ test socket-12.3 {testing inheritance of accepted sockets} \ proc accept { file host port } { global tcltest puts $file {test data on socket} - exec $::tcltest::tcltest script1 & + exec $tcltest script1 & after 1000 exit } vwait forever diff --git a/tests/tcltest.test b/tests/tcltest.test index 322ae35..4e735be 100755 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -10,15 +10,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.test,v 1.10 2000/04/10 17:19:05 ericm Exp $ +# RCS: @(#) $Id: tcltest.test,v 1.11 2000/09/20 23:09:55 jenn Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 1.0 namespace import -force ::tcltest::* } makeFile { - package require tcltest + package require tcltest 1.0 namespace import -force ::tcltest::* test a-1.0 {test a} { list 0 @@ -147,7 +147,7 @@ test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} { } {0 0 0 1 1} makeFile { - package require tcltest + package require tcltest 1.0 namespace import -force ::tcltest::* puts $::tcltest::outputChannel "a test" ::tcltest::PrintError "a really short string" @@ -215,7 +215,7 @@ test tcltest-7.5 {tcltest test.tcl -d 3} {unixOrPc} { } {1 1} makeFile { - package require tcltest + package require tcltest 1.0 namespace import -force ::tcltest::* makeFile {} a.tmp exit @@ -313,7 +313,7 @@ test tcltest-9.2 {-file a*.tcl} {unixOrPc} { makeFile { - package require tcltest + package require tcltest 1.0 namespace import -force ::tcltest::* test makecore {make a core file} { @@ -349,7 +349,7 @@ test tcltest-10.4 {-preservecore 3} {unixOrPc} { } {1 1 1 {}} makeFile { - package require tcltest + package require tcltest 1.0 namespace import -force ::tcltest::* puts "=$::tcltest::parameters=" exit @@ -373,7 +373,7 @@ test tcltest-11.3 {-args {-foo bar -baz}} {unixOrPc} { # -load -loadfile makeFile { - package require tcltest + package require tcltest 1.0 namespace import -force ::tcltest::* puts $::tcltest::loadScript exit diff --git a/tests/tcltest2.test b/tests/tcltest2.test new file mode 100755 index 0000000..09c970c --- /dev/null +++ b/tests/tcltest2.test @@ -0,0 +1,1121 @@ +# 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.1 2000/09/20 23:09:55 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} { + } {} + ::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.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] +} {0 1 0 0 1} +test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -verbose 'b'} msg] + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ + [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] +} {0 1 0 0 1} +test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -verbose 'p'} msg] + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ + [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] +} {0 0 1 0 1} +test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -verbose 's'} msg] + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ + [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] +} {0 0 0 1 1} +test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -verbose 'ps'} msg] + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ + [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] +} {0 0 1 1 1} +test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -verbose 'psb'} msg] + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ + [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] +} {0 1 1 1 1} + +test tcltest-2.6 { + description {tcltest -verbose 't'} + constraints {unixOrPc} + script { + set result [catch {exec $::tcltest::tcltest test.tcl -verbose 't'} msg] + list $result $msg + } + expect {-regexp "^0 .*a-1.0 start.*b-1.0 start"} +} + +test tcltest-2.7 { + description {tcltest::verbose} + script { + set oldVerbosity [tcltest::verbose] + tcltest::verbose bar + set currentVerbosity [tcltest::verbose] + tcltest::verbose foo + set newVerbosity [tcltest::verbose] + tcltest::verbose $oldVerbosity + list $currentVerbosity $newVerbosity + } + expect {bar foo} +} + +# -match, tcltest::match +test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -match a* -verbose 'ps'} msg] + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg] +} {0 1 0 0 1} +test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -match b* -verbose 'ps'} msg] + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] +} {0 0 1 0 1} +test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -match c* -verbose 'ps'} msg] + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+0.+Skipped.+3.+Failed.+0" $msg] +} {0 0 0 1 1} +test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -match {a* b*} -verbose 'ps'} msg] + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] +} {0 1 1 0 1} + +test tcltest-3.5 { + description {tcltest::match} + script { + set oldMatch [tcltest::match] + tcltest::match foo + set currentMatch [tcltest::match] + tcltest::match bar + set newMatch [tcltest::match] + tcltest::match $oldMatch + list $currentMatch $newMatch + } + expect {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.+3.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] +} {0 0 1 1 1} +test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -skip b* -verbose 'ps'} msg] + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg] +} {0 1 0 1 1} +test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -skip c* -verbose 'ps'} msg] + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg] +} {0 1 1 0 1} +test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -skip {a* b*} -verbose 'ps'} msg] + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+0.+Skipped.+3.+Failed.+0" $msg] +} {0 0 0 1 1} +test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -match {a* b*} -skip b* -verbose 'ps'} msg] + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg] +} {0 1 0 0 1} + +test tcltest-4.6 { + description {tcltest::skip} + script { + set oldSkip [tcltest::skip] + tcltest::skip foo + set currentSkip [tcltest::skip] + tcltest::skip bar + set newSkip [tcltest::skip] + tcltest::skip $oldSkip + list $currentSkip $newSkip + } + expect {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.+3.+Passed.+2.+Skipped.+0.+Failed.+1" $msg] +} {0 1 1 1 1} +test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} { + set result [catch {exec $::tcltest::tcltest test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1} msg] + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ + [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg] +} {0 0 0 1 1} + +test tcltest-5.3 { + description {tcltest::testConstraint - constraint empty (tcltest::safeFetch)} + script { + set r1 [tcltest::testConstraint tcltestFakeConstraint] + set r2 [tcltest::testConstraint tcltestFakeConstraint 4] + set r3 [tcltest::testConstraint tcltestFakeConstraint] + list $r1 $r2 $r3 + } + expect {0 4 4} + cleanup {unset tcltest::testConstraints(tcltestFakeConstraint)} +} + +test tcltest-5.4 { + description {tcltest::constraintsSpecified} + setup { + set constraintlist $tcltest::constraintsSpecified + set tcltest::constraintsSpecified {} + } + script { + set r1 [tcltest::constraintsSpecified] + tcltest::testConstraint tcltestFakeConstraint1 1 + set r2 [tcltest::constraintsSpecified] + tcltest::testConstraint tcltestFakeConstraint2 1 + set r3 [tcltest::constraintsSpecified] + list $r1 $r2 $r3 + } + expect {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} + cleanup { + set tcltest::constraintsSpecified $constraintlist + unset tcltest::testConstraints(tcltestFakeConstraint1) + unset tcltest::testConstraints(tcltestFakeConstraint2) + } +} + +test tcltest-5.5 { + description {tcltest::constraintList} + constraints {!$tcltest::singleTestInterp} + script { + tcltest::constraintList + } + expect {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 { + description {tcltest::limitConstraints} + setup { + set keeplc $tcltest::limitConstraints + set keepkb [tcltest::testConstraint knownBug] + } + script { + 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 + } + expect {false knownBug knownBug} +} + +# -outfile, -errfile, tcltest::outputChannel, tcltest::outputFile, +# tcltest::errorChannel, tcltest::errorFile +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} {unixOrPc} { + catch {exec $::tcltest::tcltest printerror.tcl} msg + list [regexp "a test" $msg] [regexp "a really" $msg] +} {1 1} +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 { + description {tcltest::errorChannel - retrieval} + setup { + set of [tcltest::errorChannel] + set tcltest::errorChannel stderr + } + script { + tcltest::errorChannel + } + expect {stderr} + cleanup { + set tcltest::errorChannel $of + } +} + +test tcltest-6.6 { + description {tcltest::errorFile (implicit errorChannel)} + setup { + set ef [tcltest::makeFile {} efile] + set of [tcltest::errorFile] + set tcltest::errorChannel stderr + set tcltest::errorFile stderr + } + script { + 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 + } + expect {-regexp "stderr stderr $ef file[0-9a-f]+ $ef"} + cleanup { + tcltest::errorFile $of + } +} +test tcltest-6.7 { + description {tcltest::outputChannel - retrieval} + setup { + set of [tcltest::outputChannel] + set tcltest::outputChannel stdout + } + script { + tcltest::outputChannel + } + expect {stdout} + cleanup { + set tcltest::outputChannel $of + } +} + +test tcltest-6.8 { + description {tcltest::outputFile (implicit outputFile)} + setup { + set ef [tcltest::makeFile {} efile] + set of [tcltest::outputFile] + set tcltest::outputChannel stdout + set tcltest::outputFile stdout + } + script { + 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 + } + expect {-regexp "stdout stdout $ef file[0-9a-f]+ $ef"} + 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 { + description {tcltest::debug} + setup { + set old $tcltest::debug + set tcltest::debug 0 + } + script { + 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 + } + expect {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} {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 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} + +test tcltest-8.6 { + description {tcltest::temporaryDirectory} + setup { + set old $tcltest::temporaryDirectory + set current [pwd] + set tcltest::temporaryDirectory $normaldirectory + } + script { + set f1 [tcltest::temporaryDirectory] + set f2 [tcltest::temporaryDirectory $current] + set f3 [tcltest::temporaryDirectory] + list $f1 $f2 $f3 + } + expect {$normaldirectory $current $current} + cleanup { + set tcltest::temporaryDirectory $old + } +} + +# -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 { + description {tcltest::testsDirectory} + setup { + set old $tcltest::testsDirectory + set current [pwd] + set tcltest::testsDirectory $normaldirectory + } + script { + set f1 [tcltest::testsDirectory] + set f2 [tcltest::testsDirectory $current] + set f3 [tcltest::testsDirectory] + list $f1 $f2 $f3 + } + expect {$normaldirectory $current $current} + cleanup { + set tcltest::testsDirectory $old + } +} + +# tcltest::workingDirectory +test tcltest-8.60 { + description {tcltest::workingDirectory} + setup { + set old $tcltest::workingDirectory + set current [pwd] + set tcltest::workingDirectory $normaldirectory + cd $normaldirectory + } + script { + 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 + } + expect {$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 { + description {tcltest::matchFiles} + script { + set old [tcltest::matchFiles] + tcltest::matchFiles foo + set current [tcltest::matchFiles] + tcltest::matchFiles bar + set new [tcltest::matchFiles] + tcltest::matchFiles $old + list $current $new + } + expect {foo bar} +} + +test tcltest-9.4 { + description {tcltest::skipFiles} + script { + set old [tcltest::skipFiles] + tcltest::skipFiles foo + set current [tcltest::skipFiles] + tcltest::skipFiles bar + set new [tcltest::skipFiles] + tcltest::skipFiles $old + list $current $new + } + expect {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 { + description {tcltest::preserveCore} + script { + set old [tcltest::preserveCore] + set result [tcltest::preserveCore foo] + set result2 [tcltest::preserveCore] + tcltest::preserveCore $old + list $result $result2 + } + expect {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 { + description {tcltest::loadScript} + setup { + set old $tcltest::loadScript + set tcltest::loadScript {} + } + script { + set f1 [tcltest::loadScript] + set f2 [tcltest::loadScript xxx] + set f3 [tcltest::loadScript] + list $f1 $f2 $f3 + } + expect {{} xxx xxx} + cleanup { + set tcltest::loadScript $old + } +} + +test tcltest-12.4 { + description {tcltest::loadFile} + setup { + set olds $tcltest::loadScript + set tcltest::loadScript {} + set oldf $tcltest::loadFile + set tcltest::loadFile {} + set f [open load.tcl] + set content [read $f] + close $f + } + script { + 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 + } + expect {{} {} $loadfile {$content} $loadfile} + cleanup { + set tcltest::loadScript $olds + set tcltest::loadFile $oldf + } +} + +# tcltest::interpreter +test tcltest-13.1 { + description {tcltest::interpreter} + setup { + set old $tcltest::tcltest + set tcltest::tcltest tcltest + } + script { + set f1 [tcltest::interpreter] + set f2 [tcltest::interpreter tclsh] + set f3 [tcltest::interpreter] + list $f1 $f2 $f3 + } + expect {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 { + description {-singleproc - single process} + constraints {unixOrPc} + script { + exec [tcltest::interpreter] $allfile -singleproc 0 + } + expect {-regexp {Test file error: can't unset .foo.: no such variable}} +} + +test tcltest-14.2 { + description {-singleproc - multiple process} + constraints {unixOrPc} + script { + exec [tcltest::interpreter] $allfile -singleproc 1 + } + expect {-regexp {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}} +} + +test tcltest-14.3 { + description {tcltest::singleProcess} + setup { + set old $tcltest::singleProcess + set tcltest::singleProcess 0 + } + script { + set f1 [tcltest::singleProcess] + set f2 [tcltest::singleProcess 1] + set f3 [tcltest::singleProcess] + list $f1 $f2 $f3 + } + expect {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 { + description {basic directory walking} + constraints {unixOrPc} + script { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] + } + expect {-regexp {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*Tests located in:.*dirtestdir2.3}} +} + +test tcltest-15.2 { + description {-asidefromdir} + constraints {unixOrPc} + script { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -asidefromdir dirtestdir2.3 + } + expect {-regexp {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 { + description {-relateddir, non-existent dir} + constraints {unixOrPc} + script { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -relateddir [file join [tcltest::temporaryDirectory] dirtestdir0] + } + expect {-regexp {[^~]|dirtestdir[^2]}} +} + +test tcltest-15.4 { + description {-relateddir, subdir} + constraints {unixOrPc} + script { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -relateddir dirtestdir2.1 + } + expect {-regexp {Tests located in:.*dirtestdir2.[^23]}} +} +test tcltest-15.5 { + description {-relateddir, -asidefromdir} + constraints {unixOrPc} + script { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] dirtestdir all.tcl] -relateddir "dirtestdir2.1 dirtestdir2.2" -asidefromdir dirtestdir2.2 + } + expect {-regexp {Tests located in:.*dirtestdir2.[^23]}} +} + +test tcltest-15.6 { + description {tcltest::matchDirectories} + setup { + set old [tcltest::matchDirectories] + set tcltest::matchDirectories {} + } + script { + set r1 [tcltest::matchDirectories] + set r2 [tcltest::matchDirectories foo] + set r3 [tcltest::matchDirectories] + list $r1 $r2 $r3 + } + cleanup { + set tcltest::matchDirectories $old + } + expect {{} foo foo} +} + +test tcltest-15.7 { + description {tcltest::skipDirectories} + setup { + set old [tcltest::skipDirectories] + set tcltest::skipDirectories {} + } + script { + set r1 [tcltest::skipDirectories] + set r2 [tcltest::skipDirectories foo] + set r3 [tcltest::skipDirectories] + list $r1 $r2 $r3 + } + cleanup { + set tcltest::skipDirectories $old + } + expect {{} foo foo} +} + +# TCLTEST_OPTIONS +test tcltest-19.1 { + constraints {unixOrPc} + description {TCLTEST_OPTIONS default} + 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 + } + script { + tcltest::processCmdLineArgs + set ::env(TCLTEST_OPTIONS) "-debug 3" + tcltest::processCmdLineArgs + } + expect {} + expect_out {-regexp {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 { + description {expect with glob} + script { + list a b c d e + } + expect {-glob "[ab] b c d e"} +} + +test tcltest-21.2 { + description {force a test command failure} + script { + test foo { + return 2 + } {1} + } + expect_err {one of: name, description empty\n} + expect {1} +} + +test tcltest-21.3 { + description {test command with setup} + setup { + set foo 1 + } + script { + set foo + } + cleanup {unset foo} + expect {1} +} + +test tcltest-21.4 { + description {test command with cleanup failure} + setup { + if {[info exists foo]} { + unset foo + } + } + script { + test foo-1 { + description {foo-1} + cleanup {unset foo} + } + } + expect {0} + expect_out {-regexp "Test cleanup failed:.*can't unset \"foo\": no such variable"} +} + +test tcltest-21.5 { + description {test command with setup failure} + setup { + if {[info exists foo]} { + unset foo + } + } + script { + test foo-2 { + description {foo-2} + setup {unset foo} + } + } + expect {0} + expect_out {-regexp "Test setup failed:.*can't unset \"foo\": no such variable"} +} + +test tcltest-21.6 { + description {test command - setup occurs before cleanup & before script} + script { + test foo-3 { + description {foo-3} + setup { + if {[info exists foo]} { + unset foo + } + set foo 1 + set expected 2 + } + script { + incr foo + set foo + } + cleanup { + if {$foo != 2} { + puts [tcltest::outputChannel] "foo is wrong" + } else { + puts [tcltest::outputChannel] "foo is 2" + } + } + expect {$expected} + } + } + expect {0} + expect_out {-regexp "foo is 2"} +} + +# 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 { + description {foo} + script { return 1 } + expect {1} + } + tcltest::cleanupTests +} [file join alltestdir test.test] + +test tcltest-22.1 { + description {runAllTests} + constraints {unixOrPc} + script { + exec [tcltest::interpreter] [file join [tcltest::temporaryDirectory] alltestdir all.tcl] -verbose t + } + expect {-regexp "Test files exiting with errors:.*error.test.*exit.test"} + +} + +# cleanup +if {[file exists a.tmp]} { + file delete -force a.tmp +} + +::tcltest::cleanupTests +return diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in index 57e4fd9..c291c91 100644 --- a/tools/tcl.wse.in +++ b/tools/tcl.wse.in @@ -1072,6 +1072,11 @@ item: Install File Flags=0000000000000010 end item: Install File + Source=${__TCLBASEDIR__}\library\tcltest1.0\tcltest2.tcl + Destination=%MAINDIR%\lib\tcl%VER%\tcltest1.0\tcltest2.tcl + Flags=0000000000000010 +end +item: Install File Source=${__TCLBASEDIR__}\library\encoding\symbol.enc Destination=%MAINDIR%\lib\tcl%VER%\encoding\symbol.enc Flags=0000000000000010 diff --git a/unix/mkLinks b/unix/mkLinks index e7c34fd..cdb1a3c 100644 --- a/unix/mkLinks +++ b/unix/mkLinks @@ -960,4 +960,8 @@ if test -r tcltest.n; then rm -f Tcltest.n ln tcltest.n Tcltest.n fi +if test -r tcltest2.n; then + rm -f Tcltest2.n + ln tcltest2.n Tcltest2.n +fi exit 0 |