diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | doc/tcltest.n | 356 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 179 | ||||
| -rw-r--r-- | library/tcltest1.0/tcltest.tcl | 179 |
4 files changed, 424 insertions, 297 deletions
@@ -1,3 +1,10 @@ +1999-07-26 Jennifer Hom <jenn@scriptics.com> + + * tests/tcltest.test: + * library/tcltest1.0/tcltest.tcl: + * doc/tcltest.n: Cleaned up code in ::tcltest::PrintError, revised + documentation, and added tests for the tcltest package. + 1999-07-23 <redman@scriptics.com> * tests/info.test: diff --git a/doc/tcltest.n b/doc/tcltest.n index 951595b..557fac3 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -6,10 +6,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tcltest.n,v 1.3 1999/07/09 00:01:01 jenn Exp $ +'\" RCS: @(#) $Id: tcltest.n,v 1.4 1999/07/26 22:50:53 jenn Exp $ '\" .so man.macros -.TH "Tcltest" n 8.1 Tcl "Tcl Built-In Commands" +.TH "Tcltest" n 8.2 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -35,14 +35,8 @@ Tcltest \- Test harness support code and utilities .sp \fB::tcltest::normalizeMsg \fImsg\fR .sp -\fB::tcltest::grep \fIexpression list\fR -.sp \fB::tcltest::bytestring \fIstring\fR .sp -\fB::tcltest::set_iso8850_1_locale -.sp -\fB::tcltest::restore_locale -.sp \fB::tcltest::saveState .sp \fB::tcltest::restoreState @@ -59,8 +53,8 @@ The Tcl test suite consists of multiple .test files, each of which contains multiple test cases. Each test case consists of a call to the test command, which specifies the name of test, a short description, any constraints that apply to the test case, the script -to be run, and expected results. See the sections \fI"Tests"\fR and -\fI"Test Constraints"\fR and \fI"Test Files and How to Run Them"\fR +to be run, and expected results. See the sections \fI"Tests,"\fR +\fI"Test Constraints,"\fR and \fI"Test Files and How to Run Them"\fR for more details. .PP It is also possible to add to this test harness to create your own @@ -73,23 +67,29 @@ thanks to her for donating her work back to the public Tcl release. .SH COMMANDS .TP \fB::tcltest::test\fP \fIname desc ?constraints? script expectedAnswer\fR -The \fB::tcltest::test\fR command is used to run a test script defined -within a test file. It prints an error message if the test fails. If -\fB::tcltest::verbose\fR has been set (either by using \fB-verbose\fR -or by manually setting the value of the variable) it can also print +The \fB::tcltest::test\fR command is used \fIscript\fR and compare the +its result to \fIexpectedAnswer\fR. It prints an error message if the two do +not match. If \fB::tcltest::verbose\fR contains "p" or "s", it also prints out a message if the test passed or was skipped. The test will be skipped if it doesn't match the \fB::tcltest::match\fR variable, if it matches an element in \fB::tcltest::skip\fR, or if one of the elements -of \fIconstraint\fR turns out not to be true. See the \fI"Writing a new -test"\fR section for more details on this command. +of \fIconstraint\fR turns out not to be true. The +\fB::tcltest::test\fR command has no defined return values. See the +\fI"Writing a new test"\fR section for more details on this command. .TP \fB::tcltest::cleanupTests\fP \fI?calledFromAll?\fR This command should be called at the end of a test file. It prints statistics about the tests run and removes files that were created by \fB::tcltest::makeDirectory\fR and \fB::tcltest::makeFile\fR. Names -of files created without the \fB::tcltest::makeFile\fR command are -printed. This command also restores the original shell -environment. The default value for \fIcalledFromAll\fR is false. +of files and directories created outside of +\fB::tcltest::makeFile\fR and \fB::tcltest::makeDirectory\fR and +never deleted are printed to \fB::tcltest::outputChannel\fR. This command +also restores the original shell environment, as described by the ::env +array. \fIcalledFromAll\fR should be specified when +\fB::tcltest::cleanupTests\fR is called from an "all.tcl" file. Tcl files +files are generally used to run multiple tests. For more details on how to +run multiple tests, please see the section \fI"Running test files"\fR. +This proc has no defined return value. .TP \fB::tcltest::getMatchingTestFiles\fP This command is used when you want to run multiple test files. It returns @@ -98,56 +98,52 @@ section \fI"Running test files"\fR for more information. .TP \fB::tcltest::makeFile\fP \fIcontents name\fR Create a file that will be automatically be removed by -\fB::tcltest::cleanupTests\fR at the end of a test run. +\fB::tcltest::cleanupTests\fR at the end of a test file. +This proc has no defined return value. .TP \fB::tcltest::removeFile\fP \fIname\fR -Force a file to be removed +Force the file referenced by \fIname\fR to be removed. This file name +should be relative to \fI::tcltest::temporaryDirectory\fR. This proc has no +defined return values. .TP \fB::tcltest::makeDirectory\fP \fIname\fR -Create a directory that will automatically be removed by -\fB::tcltest::cleanupTests\fR at the end of a test run. +Create a directory named \fIname\fR that will automatically be removed +by \fB::tcltest::cleanupTests\fR at the end of a test file. This proc +has no defined return value. .TP \fB::tcltest::removeDirectory\fP \fIname\fR -Force a directory to be removed. +Force the directory referenced by \fIname\fR to be removed. This proc +has no defined return value. .TP -\fB::tcltest::viewFile\fP \fIname\fR -Returns the contents of a file. +\fB::tcltest::viewFile\fP \fIfile\fR +Returns the contents of \fIfile\fR. .TP \fB::tcltest::normalizeMsg\fP \fImsg\fR -Remove extra newlines from a string. -.TP -\fB::tcltest::grep\fP \fIexpression list\fR -Evaluate a given expression against each element of a list and return all -elements for which \fIexpression\fR evaluates to true. Use of the -keyword \fICURRENT_ELEMENT\fR within \fIexpression\fR will flag the -proc to use the value of the current element within the expression. -Use of the \fICURRENT_ELEMENT\fR keyword is optional. If it is left -out, it is assumed to be the final argument to the expression provided. -Examples of usage: -.DS -set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] -set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] -grep {regexp a} $someList -.DE +Remove extra newlines from \fImsg\fR. .TP \fB::tcltest::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. -.TP -\fB::tcltest::set_iso8859_1_locale\fP -Set the locale to iso8859_1 -.TP -\fB::tcltest::restore_locale\fP -Restore the locale to its original setting +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 \fB::tcltest::saveState\fP -Save the procedure and global variable names -.TP \fB::tcltest::restoreState\fP -Restore the procedure and global variable names +Save and restore the procedure and global variable names. +A test file might contain calls to \fB::tcltest::saveState\fR and +\fB::tcltest:restoreState\fR if it creates or deletes global variables +or procs. .TP \fB::tcltest::threadReap\fP -Kill all threads except for the main thread +\fB::tcltest::threadReap\fR only works if \fItestthread\fR is +defined, generally by compiling tcltest. If \fItestthread\fR is +defined, \fB::tcltest::threadReap\fR kills all threads except for the +main thread. It gets the ID of the main thread by calling +\fItestthread names\fR during initialization. This value is stored in +\fI::tcltest::mainThread\fR. \fB::tcltest::threadReap\fR returns the +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. @@ -165,12 +161,20 @@ target should be the name of the feature being tested. Related tests should share a major number. .PP The <description> argument is a short textual description of the test, -to help humans understand what it does. +to help humans understand what it tests. The name of a Tcl or C +function being tested should be included for regression tests. If the +test case exists to reproduce a bug, include the bug ID in the +description. .PP -The optional <constraints> argument is list of one or more keywords, -each of which must be the name of an element in the array +The optional <constraints> argument can be list of one or more +keywords or an expression. If the <constraints> argument consists of +keywords, each of these keywords must be the name of an element in the array \fI::tcltest::testConstraints\fR. If any of these elements is false or does -not exist, the test is skipped. Add appropriate constraints (e.g., +not exist, the test is skipped. If the <constraints> argument +consists of an expression, that expression is evaluated. If the +expression evaluates to true, then the test is run. +.PP +Add appropriate constraints (e.g., unixOnly) to any tests that should not always be run. For example, a test that should only be run on Unix should look like the following: .PP @@ -180,6 +184,19 @@ test getAttribute-1.1 {testing file permissions} {unixOnly} { } {00644} .DE .PP +An example of a test that contains an expression: +.PP +.DS +test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly && !testthread} { + catch {vwait x} + set f [open foo w] + fileevent $f writable {set x 1} + vwait x + close $f + list [catch {vwait x} msg] $msg +} {1 {can't wait for variable "x": would wait forever}} +.DE +.PP See the "Test Constraints" section for a list of built-in constraints and information on how to add your own constraints. .PP @@ -200,47 +217,58 @@ The following variables are also defined in the \fBtcltest\fR namespace and can be used by tests: .TP \fB::tcltest::outputChannel\fR -output file ID - defaults to stdout and can be specified using -outfile +output file ID - defaults to stdout and can be specified using +-outfile on the command line. +Any test that prints test related output should send +that output to \fI::tcltest::outputChannel\fR rather than letting +that output default to stdout. .TP \fB::tcltest::errorChannel\fR error file ID - defaults to stderr and can be specified using -errfile +on the command line. +Any test that prints error messages should send +that output to \fI::tcltest::errorChannel\fR rather than printing +directly to stderr. .TP \fB::tcltest::mainThread\fR -main thread ID - defaults to 1 +main thread ID - defaults to 1. This is the only thread that is not +killed by ::tcltest::threadReap and is set according to the return +value of \fItestthread names\fR at initialization. .TP \fB::tcltest::originalEnv\fR -values of environment variables at the beginning of the test run (::env) +copy of the global "env" array at the beginning of the test run. This +array is used to restore the "env" array to its original state when +\fI::tcltest::cleanupTests\fR is called. .TP \fB::tcltest::workingDirectory\fR -the current working directory ([pwd]) +the directory in which the test suite was launched. .TP \fB::tcltest::temporaryDirectory\fR -the output directory - defaults to the current working directory and can be -specified using -tmpdir +the output directory - defaults to \fI::tcltest::workingDirectory\fR and can be +specified using -tmpdir on the command line. .TP \fB::tcltest::testsDirectory\fR -where the tests reside -.TP -\fB::tcltest::isoLocale\fR -used for internationalization support - default language is French; default -value is fr_FR.ISO_8859-1 for FreeBSD, fr_FR.iso88591 for HP-UX, fr for -Linux and IRIX, iso_8859_1 for other UNIX systems, and French for Windows. +where the tests reside - defaults to \fI::tcltest::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 \fB::tcltest::tcltest\fR -the name of the tcltest executable ([info nameofexecutable]) +the name of the executable used to invoke the test suite. .SH "TEST CONSTRAINTS" Constraints are used to determine whether a test should be skipped. Each constraint is stored as an index in the array -::tcltest::testConstraints. For example, the unixOnly constraint is +\fI::tcltest::testConstraints\fR. For example, the unixOnly constraint is defined as the following: -.PP .DS set ::tcltest::testConstraints(unixOnly) \\ [string equal $tcl_platform(platform) "unix"] .DE -.PP If a test is constrained by "unixOnly", then it will only be run if -the value of ::tcltest::testConstraints(unixOnly) is true. +the value of ::tcltest::testConstraints(unixOnly) is true. Several +constraints are defined in the \fBtcltest\fR package. To add file- or +test-specific constraints, you can set the desired index of the +::tcltest::testsConstraints array in your own test file. .PP The following is a list of constraints defined in the \fBtcltest\fR package: .TP @@ -348,10 +376,11 @@ test can only be run if the current app can be spawned via a pipe Use the following command to run a test file that uses package tcltest: .DS -<shell> <testFile> ?<option> <value>? ... +<shell> <testFile> ?<option> ?<value>?? ... .DE -Command line options include (variables that correspond to each flag -are listed at the end of each flag description in parenthesis): +Command line options include (tcltest namespace variables that +correspond to each flag are listed at the end of each flag description +in parenthesis): .RS .TP \fB-help\fR @@ -359,38 +388,55 @@ display usage information. .TP \fB-verbose <level>\fR set the level of verbosity to a substring of "bps". See the "Test -output" section for an explanation of this option. +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> +<matchList>. (::tcltest::match) .TP \fB-skip <skipList>\fR do not run tests that match one or more of the glob patterns in -<skipList> +<skipList>. (::tcltest::skip) .TP \fB-file <globPatternList>\fR only source test files that match any of the items in -<globPatternList> (relative to ::tcltest::testsDirectory). +<globPatternList> relative to ::tcltest::testsDirectory. +This option +only makes sense if you are running tests using "all.tcl" as the +<testFile> instead of running single test files directly. +(::tcltest::matchFiles) .TP \fB-notfile <globPatternList>\fR source files except for those that match any of the items in -<globPatternList> (relative to ::tcltest::testsDirectory). +<globPatternList> relative to ::tcltest::testsDirectory. +This option +only makes sense if you are running tests using "all.tcl" as the +<testFile> instead of running single test files directly. +(::tcltest::skipFiles) .TP \fB-constraints <list>\fR tests with any constraints in <list> will not be skipped. Note that -elements of <list> must exactly match the existing constraints. +elements of <list> must exactly match the existing constraints. This +is useful if you want to make sure that tests with a particular +constraint are run (for example, if the tester wants to run all tests +with the knownBug constraint). +(::tcltest::testConstraints(\fIconstraintName\fR)) .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). +default value for this flag is 0 (false). This is useful if you want +to run \fBonly\fR those tests that match the constraints listed using +the -constraints option. A tester might want to do this if he were +interested in running only those tests that are constrained to be +unixOnly and no other tests. +(::tcltest::limitConstraints) .TP \fB-tmpdir <directoryName>\fR put any temporary files (created with ::tcltest::makeFile and ::tcltest::makeDirectory) into the named directory. The default -location is your current working directory. +location is ::tcltest::workingDirectory. (::tcltest::temporaryDirectory) .TP \fB-preservecore <level>\fR check for core files. This flag is used to determine how much @@ -408,10 +454,13 @@ Check for core files at the end of each test command and whenever Check for core files at the end of all test commands and whenever ::tcltest::cleanupTests is called from all.tcl. Save any core files produced in ::tcltest::temporaryDirectory. +.RE +.sp +(::tcltest::preserveCore) .TP \fB-debug <debugLevel>\fR -print out debug information. This is used to debug code in the test -harness. The default debug level is 0. Levels are defined as: +print debug information to stdout. This is used to debug code in the +test harness. The default debug level is 0. Levels are defined as: .RS .IP 0 Do not display any debug information. @@ -422,68 +471,50 @@ doesn't match any of the tests that were specified using -match or 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 +contents of the ::env array, and all user-defined variables that exist in the current namespace as they are used. .IP 3 Display information regarding what individual procs in the test harness are doing. .RE +.sp +(::tcltest::debug) +.TP \fB-outfile <filename>\fR -send normal output to the named file. This defaults to stdout. Note -that debug output always goes to stdout, regardless of this flag's -setting. +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 -send errors to the named file. This defaults to stderr. Note -that debug output always goes to stdout, regardless of this flag's -setting. +print errors generated by the tcltest package to the named file. This +defaults to stderr. (::tcltest::errorChannel) .RE .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. These variables (and their corresponding flags) are: -.RS -.IP -match -::tcltest::match -.IP -skip -::tcltest::skip -.IP -verbose -::tcltest::verbose -.IP -outfile -::tcltest::outputChannel -.IP -errfile -::tcltest::errorChannel -.IP -preservecore -::tcltest::preserveCore -.IP -debug -::tcltest::debug, ::tcltest::debugLevel -.IP -tmpdir -::tcltest::temporaryDirectory -.IP -constraints -::tcltest::testConstraints(\fIconstraintName\fR) -.IP -limitconstraints -::tcltest::limitConstraints -.RE +package. .PP -See the \fI"Test Constraints"\fR for all available constraint names +See \fI"Test Constraints"\fR for all built-in constraint names that can be used in the \fB::tcltest::testConstraints\fR array. See \fI"Tcltest namespace variables"\fR for details on other variables defined in the \fBtcltest\fR namespace. .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. An extremely simple all.tcl file -would simply source all files with a .test extension within the -current directory. A more elaborate one might do some pre- and -post-processing before sourcing each .test file, use separate -interpreters for each file, or handle complex directory structures. +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 -In all cases, no output will be generated if all goes well, except for -a listing of the test files and a statistical summary. If there are -errors, then additional messages will appear in the format described -below. Note that some tests will be skipped if you run as superuser. +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 @@ -577,17 +608,26 @@ See the \fI"Constraints"\fR package for information about using built-in constraints and adding new ones. .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. To add new -constraints, define your own version of \fB::tcltest::initConstraintsHook\fR. -Within your proc, you can add to the \fB::tcltest::testConstraints\fR array. -For example: -.DS -proc ::tcltest::initConstraintsHook {} { - set ::tcltest::testConstraints(win95Or98) \\ - [expr {$::tcltest::testConstraints(95) || \\ - $::tcltest::testConstraints(98)}] -} -.DE +namespace. Within this file, require package \fBtcltest\fR. Commands +that can be redefined to customize the test harness include: +.TP +\fB::tcltest::PrintUsageInfoHook\fP +print additional usage information specific to your situation. +.TP +\fB::tcltest::processCmdLineArgsFlagHook\fP +tell the test harness about additional flags that you want it to understand. +.TP +\fB::tcltest::processCmdLineArgsHook\fR flags\fP +process the additional flags that you told the harness about in +::tcltest::processCmdLineArgsFlagHook. +.TP +\fB::tcltest::initConstraintsHook\fP +used to add additional built-in constraints to those already defined +by \fBtcltest\fR. +.TP +\fB::tcltest::cleanupTestsHook\fP +do additional cleanup +.PP .PP To add new flags to your customized test harness, redefine \fB::tcltest::processCmdLineArgsAddFlagHook\fR to define additional flags to be @@ -612,6 +652,25 @@ proc ::tcltest::processCmdLineArgsHook {flagArray} { 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 +\fB::tcltest::initConstraintsHook\fR. +Within your proc, you can add to the \fB::tcltest::testConstraints\fR array. +For example: +.DS +proc ::tcltest::initConstraintsHook {} { + set ::tcltest::testConstraints(win95Or98) \\ + [expr {$::tcltest::testConstraints(95) || \\ + $::tcltest::testConstraints(98)}] +} +.DE .PP Finally, if you want to add additional cleanup code to your harness you can define your own \fB::tcltest::cleanupTestsHook\fR. For example: @@ -624,26 +683,35 @@ proc ::tcltest::cleanupTestsHook {} { .IP [1] A simple test file (foo.test) .DS -package require tcltest -import namespace ::tcltest::* +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + import namespace ::tcltest::* +} + test foo-1.1 {save 1 in variable name foo} {} { set foo 1 } {1} -cleanupTests + +::tcltest::cleanupTests return .DE .IP [2] A simple all.tcl .DS -package require tcltest -import namespace ::tcltest::* -set ::tcltest::testSingleFile 0 +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + import namespace ::tcltest::* +} + +set ::tcltest::testSingleFile false set ::tcltest::testsDirectory [file dir [info script]] + foreach file [::tcltest::getMatchingTestFiles] { if {[catch {source $file} msg]} { puts stdout $msg } } + ::tclttest::cleanupTests 1 return .DE @@ -657,8 +725,6 @@ Running multiple tests .DS tclsh all.tcl -file 'foo*.test' -notfile 'foo2.test' .DE -.SH "SEE ALSO" -tktest(n) .SH KEYWORDS test, test harness, test suite diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index b94c739..3974335 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.6 1999/07/12 21:03:48 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.7 1999/07/26 22:50:55 jenn Exp $ package provide tcltest 1.0 @@ -55,15 +55,14 @@ namespace eval tcltest { variable errorChannel stderr - # debug output doesn't get printed by default; default debugLevel (1) spits + # debug output doesn't get printed by default; debug level 1 spits # up only the tets that were skipped because they didn't match or were - # specifically skipped. A debugLevel of 2 would spit up the tcltest - # variables and flags provided; a debugLevel of 3 causes some additional + # 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 debugLevel 3. + # currently implements only up to debug level 3. - variable debug false - variable debugLevel 1 + variable debug 0 # 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 @@ -232,22 +231,43 @@ proc ::tcltest::PrintError {errorMsg} { set InitialMessage "Error: " set InitialMsgLen [string length $InitialMessage] puts -nonewline $::tcltest::errorChannel $InitialMessage - set beginningIndex [string last " " [string range $errorMsg 0 \ - [string wordend $errorMsg 72]]] - puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] + + # Keep track of where we last started from and where the end of the + # string is. + set priorBeginningIndex 0 set endingIndex [string length $errorMsg] - while {$beginningIndex < $endingIndex} { - set newEndingIndex [string last " " [string range $errorMsg \ - $beginningIndex [string wordend $errorMsg \ - [expr {$beginningIndex + 72}]]]] - if {$newEndingIndex == 0} { - set newEndingIndex $endingIndex - } - puts -nonewline $::tcltest::errorChannel \ - [string repeat " " $InitialMsgLen] - puts $::tcltest::errorChannel [string trim \ - [string range $errorMsg $beginningIndex $newEndingIndex]] - set beginningIndex $newEndingIndex + + if {$endingIndex < 80} { + puts $::tcltest::errorChannel $errorMsg + } else { + # Print up to 80 characters on the first line, including the + # InitialMessage. + set beginningIndex [string last " " [string range $errorMsg 0 \ + [string wordend $errorMsg [expr {80 - $InitialMsgLen}]]]] + puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] + + while {$beginningIndex != "end"} { + puts -nonewline $::tcltest::errorChannel \ + [string repeat " " $InitialMsgLen] + if {[expr {$endingIndex - $beginningIndex}] < 72} { + puts $::tcltest::errorChannel [string trim \ + [string range $errorMsg $beginningIndex end]] + set beginningIndex end + } else { + set newEndingIndex [string last " " [string range $errorMsg \ + $beginningIndex [string wordend $errorMsg \ + [expr {$beginningIndex + 72}]]]] + if {($newEndingIndex <= 0) \ + || ($newEndingIndex == $beginningIndex)} { + set newEndingIndex end + } + puts $::tcltest::errorChannel [string trim \ + [string range $errorMsg \ + $beginningIndex $newEndingIndex]] + set beginningIndex $newEndingIndex + set priorBeginningIndex $beginningIndex + } + } } flush $::tcltest::errorChannel return @@ -639,8 +659,8 @@ proc ::tcltest::processCmdLineArgs {} { # conflicts with the wish option -visual. # Process -help first - if {([lsearch -exact $flagArray{-help}] != -1) || \ - ([lsearch -exact $flagArray{-h}] != -1)} { + if {([lsearch -exact $flagArray {-help}] != -1) || \ + ([lsearch -exact $flagArray {-h}] != -1)} { ::tcltest::PrintUsageInfo exit } @@ -721,34 +741,6 @@ proc ::tcltest::processCmdLineArgs {} { } } - # If an alternate error or output files are specified, change the - # default channels. - - if {[info exists flag(-outfile)]} { - set tmp $flag(-outfile) - if {[string compare [file pathtype $tmp] "absolute"] != 0} { - set tmp [file join $::tcltest::temporaryDirectory $tmp] - } - set ::tcltest::outputChannel [open $tmp w] - } - - if {[info exists flag(-errfile)]} { - set tmp $flag(-errfile) - if {[string compare [file pathtype $tmp] "absolute"] != 0} { - set tmp [file join $::tcltest::temporaryDirectory $tmp] - } - set ::tcltest::errorChannel [open $tmp w] - } - - # If the user specifies debug testing, print out extra information during - # the run. - if {[info exists flag(-debug)]} { - set ::tcltest::debug true - if {$flag(-debug) != {}} { - set ::tcltest::debugLevel $flag(-debug) - } - } - # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if # given. # @@ -787,6 +779,10 @@ proc ::tcltest::processCmdLineArgs {} { } else { file mkdir $::tcltest::temporaryDirectory } + set oldpwd [pwd] + cd $::tcltest::temporaryDirectory + set ::tcltest::temporaryDirectory [pwd] + cd $oldpwd # Save the names of files that already exist in # the output directory. @@ -795,20 +791,44 @@ proc ::tcltest::processCmdLineArgs {} { lappend ::tcltest::filesExisted [file tail $file] } + # If an alternate error or output files are specified, change the + # default channels. + + if {[info exists flag(-outfile)]} { + set tmp $flag(-outfile) + if {[string compare [file pathtype $tmp] "absolute"] != 0} { + set tmp [file join $::tcltest::temporaryDirectory $tmp] + } + set ::tcltest::outputChannel [open $tmp w] + } + + if {[info exists flag(-errfile)]} { + set tmp $flag(-errfile) + if {[string compare [file pathtype $tmp] "absolute"] != 0} { + set tmp [file join $::tcltest::temporaryDirectory $tmp] + } + set ::tcltest::errorChannel [open $tmp w] + } + + # If the user specifies debug testing, print out extra information during + # the run. + if {[info exists flag(-debug)]} { + set ::tcltest::debug $flag(-debug) + } + # Handle -preservecore if {[info exists flag(-preservecore)]} { - set ::tcltest::preserveCore $flag(-preserveCore) + set ::tcltest::preserveCore $flag(-preservecore) } # Call the hook ::tcltest::processCmdLineArgsHook [array get flag] - # Spit out everything you know if ::tcltest::debug is set. - if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} { + # Spit out everything you know if we're at debug level 2 or greater + if {$::tcltest::debug > 1} { puts "Flags passed into tcltest:" parray flag puts "::tcltest::debug = $::tcltest::debug" - puts "::tcltest::debugLevel = $::tcltest::debugLevel" puts "::tcltest::testsDirectory = $::tcltest::testsDirectory" puts "::tcltest::workingDirectory = $::tcltest::workingDirectory" puts "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory" @@ -998,13 +1018,17 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { if {[file exists [file join $::tcltest::workingDirectory core]]} { if {$::tcltest::preserveCore > 1} { - file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory core-$name] - puts $::tcltest::outputChannel "produced core file! \ - Moved file to: \ + Moving file to: \ [file join $::tcltest::temporaryDirectory core-$name]" + flush $::tcltest::outputChannel + catch {file rename -force \ + [file join $::tcltest::workingDirectory core] \ + [file join $::tcltest::temporaryDirectory \ + core-$name]} msg + if {[string length $msg] > 0} { + ::tcltest::PrintError "Problem renaming file: $msg" + } } 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 @@ -1055,7 +1079,7 @@ proc ::tcltest::cleanupTestsHook {} {} # expectedAnswer - Expected result from script. proc ::tcltest::test {name description script expectedAnswer args} { - if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + if {$::tcltest::debug > 2} { puts "Running $name ($description)" } @@ -1211,13 +1235,16 @@ proc ::tcltest::test {name description script expectedAnswer args} { set currentTclPlatform [array get tcl_platform] if {[file exists [file join $::tcltest::workingDirectory core]]} { if {$::tcltest::preserveCore > 1} { - file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory core-$name] - puts $::tcltest::outputChannel "==== $name produced core file! \ - Moved file to: \ + 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 @@ -1318,7 +1345,7 @@ proc ::tcltest::leakfiles {old} { proc ::tcltest::saveState {} { uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} - if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} { + if {$::tcltest::debug > 1} { puts "::tcltest::saveState: $::tcltest::saveState" } } @@ -1339,7 +1366,7 @@ proc ::tcltest::restoreState {} { foreach p [info procs] { if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \ (![string equal ::tcltest::$p [namespace origin $p]])} { - if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + if {$::tcltest::debug > 2} { puts "::tcltest::restoreState: Removing proc $p" } rename $p {} @@ -1347,7 +1374,7 @@ proc ::tcltest::restoreState {} { } foreach p [uplevel #0 {info vars}] { if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { - if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + if {$::tcltest::debug > 2} { puts "::tcltest::restoreState: Removing variable $p" } uplevel #0 "unset $p" @@ -1381,10 +1408,10 @@ proc ::tcltest::normalizeMsg {msg} { proc ::tcltest::makeFile {contents name} { global tcl_platform - if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + if {$::tcltest::debug > 2} { puts "::tcltest::makeFile: putting $contents into $name" } - set fd [open $name w] + set fd [open [file join $::tcltest::temporaryDirectory $name] w] fconfigure $fd -translation lf @@ -1412,10 +1439,10 @@ proc ::tcltest::makeFile {contents name} { # proc ::tcltest::removeFile {name} { - if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + if {$::tcltest::debug > 2} { puts "::tcltest::removeFile: removing $name" } - file delete $name + file delete [file join $::tcltest::temporaryDirectory $name] } # makeDirectory -- @@ -1451,12 +1478,12 @@ proc ::tcltest::viewFile {name} { global tcl_platform if {([string equal $tcl_platform(platform) "macintosh"]) || \ ($::tcltest::testConstraints(unixExecs) == 0)} { - set f [open $name] + set f [open [file join $::tcltest::temporaryDirectory $name]] set data [read -nonewline $f] close $f return $data } else { - exec cat $name + exec cat [file join $::tcltest::temporaryDirectory $name] } } diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl index b94c739..3974335 100644 --- a/library/tcltest1.0/tcltest.tcl +++ b/library/tcltest1.0/tcltest.tcl @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.6 1999/07/12 21:03:48 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.7 1999/07/26 22:50:55 jenn Exp $ package provide tcltest 1.0 @@ -55,15 +55,14 @@ namespace eval tcltest { variable errorChannel stderr - # debug output doesn't get printed by default; default debugLevel (1) spits + # debug output doesn't get printed by default; debug level 1 spits # up only the tets that were skipped because they didn't match or were - # specifically skipped. A debugLevel of 2 would spit up the tcltest - # variables and flags provided; a debugLevel of 3 causes some additional + # 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 debugLevel 3. + # currently implements only up to debug level 3. - variable debug false - variable debugLevel 1 + variable debug 0 # 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 @@ -232,22 +231,43 @@ proc ::tcltest::PrintError {errorMsg} { set InitialMessage "Error: " set InitialMsgLen [string length $InitialMessage] puts -nonewline $::tcltest::errorChannel $InitialMessage - set beginningIndex [string last " " [string range $errorMsg 0 \ - [string wordend $errorMsg 72]]] - puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] + + # Keep track of where we last started from and where the end of the + # string is. + set priorBeginningIndex 0 set endingIndex [string length $errorMsg] - while {$beginningIndex < $endingIndex} { - set newEndingIndex [string last " " [string range $errorMsg \ - $beginningIndex [string wordend $errorMsg \ - [expr {$beginningIndex + 72}]]]] - if {$newEndingIndex == 0} { - set newEndingIndex $endingIndex - } - puts -nonewline $::tcltest::errorChannel \ - [string repeat " " $InitialMsgLen] - puts $::tcltest::errorChannel [string trim \ - [string range $errorMsg $beginningIndex $newEndingIndex]] - set beginningIndex $newEndingIndex + + if {$endingIndex < 80} { + puts $::tcltest::errorChannel $errorMsg + } else { + # Print up to 80 characters on the first line, including the + # InitialMessage. + set beginningIndex [string last " " [string range $errorMsg 0 \ + [string wordend $errorMsg [expr {80 - $InitialMsgLen}]]]] + puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] + + while {$beginningIndex != "end"} { + puts -nonewline $::tcltest::errorChannel \ + [string repeat " " $InitialMsgLen] + if {[expr {$endingIndex - $beginningIndex}] < 72} { + puts $::tcltest::errorChannel [string trim \ + [string range $errorMsg $beginningIndex end]] + set beginningIndex end + } else { + set newEndingIndex [string last " " [string range $errorMsg \ + $beginningIndex [string wordend $errorMsg \ + [expr {$beginningIndex + 72}]]]] + if {($newEndingIndex <= 0) \ + || ($newEndingIndex == $beginningIndex)} { + set newEndingIndex end + } + puts $::tcltest::errorChannel [string trim \ + [string range $errorMsg \ + $beginningIndex $newEndingIndex]] + set beginningIndex $newEndingIndex + set priorBeginningIndex $beginningIndex + } + } } flush $::tcltest::errorChannel return @@ -639,8 +659,8 @@ proc ::tcltest::processCmdLineArgs {} { # conflicts with the wish option -visual. # Process -help first - if {([lsearch -exact $flagArray{-help}] != -1) || \ - ([lsearch -exact $flagArray{-h}] != -1)} { + if {([lsearch -exact $flagArray {-help}] != -1) || \ + ([lsearch -exact $flagArray {-h}] != -1)} { ::tcltest::PrintUsageInfo exit } @@ -721,34 +741,6 @@ proc ::tcltest::processCmdLineArgs {} { } } - # If an alternate error or output files are specified, change the - # default channels. - - if {[info exists flag(-outfile)]} { - set tmp $flag(-outfile) - if {[string compare [file pathtype $tmp] "absolute"] != 0} { - set tmp [file join $::tcltest::temporaryDirectory $tmp] - } - set ::tcltest::outputChannel [open $tmp w] - } - - if {[info exists flag(-errfile)]} { - set tmp $flag(-errfile) - if {[string compare [file pathtype $tmp] "absolute"] != 0} { - set tmp [file join $::tcltest::temporaryDirectory $tmp] - } - set ::tcltest::errorChannel [open $tmp w] - } - - # If the user specifies debug testing, print out extra information during - # the run. - if {[info exists flag(-debug)]} { - set ::tcltest::debug true - if {$flag(-debug) != {}} { - set ::tcltest::debugLevel $flag(-debug) - } - } - # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if # given. # @@ -787,6 +779,10 @@ proc ::tcltest::processCmdLineArgs {} { } else { file mkdir $::tcltest::temporaryDirectory } + set oldpwd [pwd] + cd $::tcltest::temporaryDirectory + set ::tcltest::temporaryDirectory [pwd] + cd $oldpwd # Save the names of files that already exist in # the output directory. @@ -795,20 +791,44 @@ proc ::tcltest::processCmdLineArgs {} { lappend ::tcltest::filesExisted [file tail $file] } + # If an alternate error or output files are specified, change the + # default channels. + + if {[info exists flag(-outfile)]} { + set tmp $flag(-outfile) + if {[string compare [file pathtype $tmp] "absolute"] != 0} { + set tmp [file join $::tcltest::temporaryDirectory $tmp] + } + set ::tcltest::outputChannel [open $tmp w] + } + + if {[info exists flag(-errfile)]} { + set tmp $flag(-errfile) + if {[string compare [file pathtype $tmp] "absolute"] != 0} { + set tmp [file join $::tcltest::temporaryDirectory $tmp] + } + set ::tcltest::errorChannel [open $tmp w] + } + + # If the user specifies debug testing, print out extra information during + # the run. + if {[info exists flag(-debug)]} { + set ::tcltest::debug $flag(-debug) + } + # Handle -preservecore if {[info exists flag(-preservecore)]} { - set ::tcltest::preserveCore $flag(-preserveCore) + set ::tcltest::preserveCore $flag(-preservecore) } # Call the hook ::tcltest::processCmdLineArgsHook [array get flag] - # Spit out everything you know if ::tcltest::debug is set. - if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} { + # Spit out everything you know if we're at debug level 2 or greater + if {$::tcltest::debug > 1} { puts "Flags passed into tcltest:" parray flag puts "::tcltest::debug = $::tcltest::debug" - puts "::tcltest::debugLevel = $::tcltest::debugLevel" puts "::tcltest::testsDirectory = $::tcltest::testsDirectory" puts "::tcltest::workingDirectory = $::tcltest::workingDirectory" puts "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory" @@ -998,13 +1018,17 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { if {[file exists [file join $::tcltest::workingDirectory core]]} { if {$::tcltest::preserveCore > 1} { - file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory core-$name] - puts $::tcltest::outputChannel "produced core file! \ - Moved file to: \ + Moving file to: \ [file join $::tcltest::temporaryDirectory core-$name]" + flush $::tcltest::outputChannel + catch {file rename -force \ + [file join $::tcltest::workingDirectory core] \ + [file join $::tcltest::temporaryDirectory \ + core-$name]} msg + if {[string length $msg] > 0} { + ::tcltest::PrintError "Problem renaming file: $msg" + } } 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 @@ -1055,7 +1079,7 @@ proc ::tcltest::cleanupTestsHook {} {} # expectedAnswer - Expected result from script. proc ::tcltest::test {name description script expectedAnswer args} { - if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + if {$::tcltest::debug > 2} { puts "Running $name ($description)" } @@ -1211,13 +1235,16 @@ proc ::tcltest::test {name description script expectedAnswer args} { set currentTclPlatform [array get tcl_platform] if {[file exists [file join $::tcltest::workingDirectory core]]} { if {$::tcltest::preserveCore > 1} { - file rename -force \ - [file join $::tcltest::workingDirectory core] \ - [file join $::tcltest::temporaryDirectory core-$name] - puts $::tcltest::outputChannel "==== $name produced core file! \ - Moved file to: \ + 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 @@ -1318,7 +1345,7 @@ proc ::tcltest::leakfiles {old} { proc ::tcltest::saveState {} { uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} - if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} { + if {$::tcltest::debug > 1} { puts "::tcltest::saveState: $::tcltest::saveState" } } @@ -1339,7 +1366,7 @@ proc ::tcltest::restoreState {} { foreach p [info procs] { if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \ (![string equal ::tcltest::$p [namespace origin $p]])} { - if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + if {$::tcltest::debug > 2} { puts "::tcltest::restoreState: Removing proc $p" } rename $p {} @@ -1347,7 +1374,7 @@ proc ::tcltest::restoreState {} { } foreach p [uplevel #0 {info vars}] { if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { - if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + if {$::tcltest::debug > 2} { puts "::tcltest::restoreState: Removing variable $p" } uplevel #0 "unset $p" @@ -1381,10 +1408,10 @@ proc ::tcltest::normalizeMsg {msg} { proc ::tcltest::makeFile {contents name} { global tcl_platform - if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + if {$::tcltest::debug > 2} { puts "::tcltest::makeFile: putting $contents into $name" } - set fd [open $name w] + set fd [open [file join $::tcltest::temporaryDirectory $name] w] fconfigure $fd -translation lf @@ -1412,10 +1439,10 @@ proc ::tcltest::makeFile {contents name} { # proc ::tcltest::removeFile {name} { - if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + if {$::tcltest::debug > 2} { puts "::tcltest::removeFile: removing $name" } - file delete $name + file delete [file join $::tcltest::temporaryDirectory $name] } # makeDirectory -- @@ -1451,12 +1478,12 @@ proc ::tcltest::viewFile {name} { global tcl_platform if {([string equal $tcl_platform(platform) "macintosh"]) || \ ($::tcltest::testConstraints(unixExecs) == 0)} { - set f [open $name] + set f [open [file join $::tcltest::temporaryDirectory $name]] set data [read -nonewline $f] close $f return $data } else { - exec cat $name + exec cat [file join $::tcltest::temporaryDirectory $name] } } |