diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | doc/tcltest.n | 22 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 35 | ||||
| -rwxr-xr-x | tests/tcltest.test | 46 |
4 files changed, 60 insertions, 53 deletions
@@ -1,3 +1,13 @@ +2002-04-15 Don Porter <dgp@users.sourceforge.net> + + * doc/tcltest.n: + * library/tcltest/tcltest.tcl: + * tests/tcltest.test: Revised [tcltest::test] to return errors + when called with invalid syntax and to accept exactly two arguments + as documented. Improved error messages. [Bug 497446, Patch 513983] + ***POTENTIAL INCOMPATIBILITY***: Incompatible with previous + tcltest 2.* releases, found only in alpha releases of Tcl 8.4. + 2002-04-11 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclNotify.c (TclFinalizeNotifier): remove remaining diff --git a/doc/tcltest.n b/doc/tcltest.n index 9996f48..dff7100 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -7,7 +7,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tcltest.n,v 1.14 2002/03/27 08:19:57 dgp Exp $ +'\" RCS: @(#) $Id: tcltest.n,v 1.15 2002/04/15 17:04:29 dgp Exp $ '\" .so man.macros .TH "tcltest" n 8.4 Tcl "Tcl Built-In Commands" @@ -120,12 +120,11 @@ section \fI"How to Customize the Test Harness"\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. +not match, or if an error occurs during evaluation of the \fIscript\fR. +The \fBtcltest::test\fR command returns an empty string. See the +\fI"Tests"\fR section for more details on this command. .TP -\fBtcltest::cleanupTests\fR \fI?runningMultipleTests?\fR +\fBtcltest::cleanupTests\fR \fI?calledFromAllFile?\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 @@ -133,11 +132,12 @@ 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 +array. \fIcalledFromAllFile\fR should be specified as a true value if \fBtcltest::cleanupTests\fR is called explicitly from an "all.tcl" -file. Tcl files files are generally used to run multiple tests. For +file. Tcl files are generally used to run multiple tests. The +\fBtcltest::cleanupTests\fR command returns an empty string. 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. +\fI"Running test files"\fR. .TP \fBtcltest::runAllTests\fR This command should be used in your 'all.tcl' file. It is used to @@ -504,11 +504,11 @@ run will be compared. Note that only output printed using puts is used for comparison. If \fIoutput\fR is not specified, output sent to stdout and tcltest::outputChannel is not processed for comparison. .TP -\fB-errorOutut \fIexpectedValue\fR +\fB-errorOutput \fIexpectedValue\fR The \fIerrorOutput\fR attribute supplies the comparison value with which any output sent to stderr or tcltest::errorChannel during the script run will be compared. Note that only output printed using -puts is used for comparison. If \fIerrorOutut\fR is not specified, output +puts is used for comparison. If \fIerrorOutput\fR is not specified, output sent to stderr and tcltest::errorChannel is not processed for comparison. .TP \fB-returnCodes \fIexpectedCodeList\fR diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index ee56e7a..d2535be 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -15,7 +15,7 @@ # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.47 2002/04/08 18:35:51 dgp Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.48 2002/04/15 17:04:29 dgp Exp $ # create the "tcltest" namespace for all testing variables and # procedures @@ -1823,10 +1823,10 @@ proc tcltest::SubstArguments {argList} { # help humans understand what it does. # # Results: -# 0 if the command ran successfully; 1 otherwise. +# None. # # Side effects: -# None. +# Just about anything is possible depending on the test. # proc tcltest::test {name description args} { @@ -1854,13 +1854,8 @@ proc tcltest::test {name description args} { # The old test format can't have a 3rd argument (constraints or # script) that starts with '-'. - if {[llength $args] == 0} { - puts [errorChannel] "test $name: {wrong # args:\ - should be \"test name desc ?options?\"}" - incr testLevel -1 - return 1 - } elseif {[string match -* [lindex $args 0]] - || ([llength $args] == 1)} { + if {[string match -* [lindex $args 0]] + || ([llength $args] <= 1)} { if {[llength $args] == 1} { set list [SubstArguments [lindex $args 0]] foreach {element value} $list { @@ -1882,10 +1877,11 @@ proc tcltest::test {name description args} { foreach flag [array names testAttributes] { if {[lsearch -exact $validFlags $flag] == -1} { - puts [errorChannel] "test $name:\ - bad flag $flag supplied to tcltest::test" incr tcltest::testLevel -1 - return 1 + set sorted [lsort $validFlags] + set options [join [lrange $sorted 0 end-1] ", "] + append options ", or [lindex $sorted end]" + return -code error "bad option \"$flag\": must be $options" } } @@ -1896,10 +1892,9 @@ proc tcltest::test {name description args} { # Check the values supplied for -match if {[lsearch {regexp glob exact} $match] == -1} { - puts [errorChannel] "test $name: {bad value for -match:\ - must be one of exact, glob, regexp}" incr tcltest::testLevel -1 - return 1 + return -code error "bad -match value \"$match\":\ + must be exact, glob, or regexp" } # Replace symbolic valies supplied for -returnCodes @@ -1918,11 +1913,9 @@ proc tcltest::test {name description args} { set constraints [lindex $args 0] set body [lindex $args 1] } else { - puts [errorChannel] "test $name: {wrong # args:\ - should be \"test name desc ?constraints?\ - script expectedResult\"}" incr tcltest::testLevel -1 - return 1 + return -code error "wrong # args:\ + should be \"test name desc ?options?\"" } } @@ -2107,7 +2100,7 @@ proc tcltest::test {name description args} { } incr testLevel -1 - return 0 + return } diff --git a/tests/tcltest.test b/tests/tcltest.test index 8de5bcf..1078268 100755 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -6,7 +6,7 @@ # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest.test,v 1.18 2002/03/27 08:19:57 dgp Exp $ +# RCS: @(#) $Id: tcltest.test,v 1.19 2002/04/15 17:04:29 dgp Exp $ set tcltestVersion [package require tcltest] namespace import -force ::tcltest::* @@ -1026,6 +1026,10 @@ test tcltest-20.1 {PrintError} {unixOrPc} { } {1 1 1 1 1 1} # test::test +test tcltest-21.0 {name and desc but no args specified} -body { + test foo bar +} -result {} + test tcltest-21.1 {expect with glob} { -body { list a b c d e @@ -1040,9 +1044,8 @@ test tcltest-21.2 {force a test command failure} { return 2 } {1} } - -errorOutput {^test foo: bad flag 1 supplied to tcltest::test\n$} - -result {1} - -match regexp + -returnCodes 1 + -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1067,7 +1070,7 @@ test tcltest-21.4 {test command with cleanup failure} { -cleanup {unset foo} } } - -result {^0$} + -result {^$} -match regexp -output "Test cleanup failed:.*can't unset \"foo\": no such variable" } @@ -1083,7 +1086,7 @@ test tcltest-21.5 {test command with setup failure} { -setup {unset foo} } } - -result {^0$} + -result {^$} -match regexp -output "Test setup failed:.*can't unset \"foo\": no such variable" } @@ -1112,36 +1115,37 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} { -result {$expected} } } - -result {^0$} + -result {^$} -match regexp -output "foo is 2" } test tcltest-21.7 {test command - bad flag} { - -body { + -body { test foo-4 {foo-4} { -foobar {} } } - -result {1} - -errorOutput {test foo-4: bad flag -foobar supplied to tcltest::test*} - -match glob + -returnCodes 1 + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the # exception of being in the all-inline format) -test tcltest-21.7 {expect with glob} \ +test tcltest-21.7a {expect with glob} \ -body {list a b c d e} \ -result {[ab] b c d e} \ -match glob -test tcltest-21.8 {force a test command failure} -body { - test foo { - return 2 - } {1} -} -errorOutput {test foo: bad flag 1 supplied to tcltest::test -} -result {1} +test tcltest-21.8 {force a test command failure} \ + -body { + test foo { + return 2 + } {1} + } \ + -returnCodes 1 \ + -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ @@ -1155,7 +1159,7 @@ test tcltest-21.10 {test command with cleanup failure} -setup { } } -body { test foo-1 {foo-1} -cleanup {unset foo} -} -result {^0$} -match regexp \ +} -result {^$} -match regexp \ -output {Test cleanup failed:.*can't unset \"foo\": no such variable} test tcltest-21.11 {test command with setup failure} -setup { @@ -1164,7 +1168,7 @@ test tcltest-21.11 {test command with setup failure} -setup { } } -body { test foo-2 {foo-2} -setup {unset foo} -} -result {^0$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp +} -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp test tcltest-21.12 {test command - setup occurs before cleanup & before script} -body { test foo-3 {foo-3} -setup { @@ -1183,7 +1187,7 @@ test tcltest-21.12 {test command - setup occurs before cleanup & before script} puts [tcltest::outputChannel] "foo is 2" } } -result {$expected} -} -result {^0$} -output {foo is 2} -match regexp +} -result {^$} -output {foo is 2} -match regexp # test all.tcl usage (runAllTests); simulate .test file failure, as well as # crashes to determine whether or not these errors are logged. |