Index: doc/tcltest.n ================================================================== --- doc/tcltest.n +++ doc/tcltest.n @@ -6,19 +6,19 @@ '\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH "tcltest" n 2.3 tcltest "Tcl Bundled Packages" +.TH "tcltest" n 2.5 tcltest "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcltest \- Test harness support code and utilities .SH SYNOPSIS .nf -\fBpackage require tcltest\fR ?\fB2.3\fR? +\fBpackage require tcltest\fR ?\fB2.5\fR? \fBtcltest::test \fIname description\fR ?\fI\-option value ...\fR? \fBtcltest::test \fIname description\fR ?\fIconstraints\fR? \fIbody result\fR \fBtcltest::loadTestedCommands\fR @@ -452,10 +452,11 @@ ?\fB\-cleanup \fIcleanupScript\fR? ?\fB\-result \fIexpectedAnswer\fR? ?\fB\-output \fIexpectedOutput\fR? ?\fB\-errorOutput \fIexpectedError\fR? ?\fB\-returnCodes \fIcodeList\fR? + ?\fB\-errorCode \fIexpectedErrorCode\fR? ?\fB\-match \fImode\fR? .CE .PP The \fIname\fR may be any string. It is conventional to choose a \fIname\fR according to the pattern: @@ -575,10 +576,19 @@ a code not in the \fIexpectedCodeList\fR, the test fails. All return codes known to \fBreturn\fR, in both numeric and symbolic form, including extended return codes, are acceptable elements in the \fIexpectedCodeList\fR. Default value is .QW "\fBok return\fR" . +.TP +\fB\-errorCode \fIexpectedErrorCode\fR +. +The optional \fB\-errorCode\fR attribute supplies \fIexpectedErrorCode\fR, +a glob pattern that should match the error code reported from evaluation of the +\fB\-body\fR script. If evaluation of the \fB\-body\fR script returns +a code not matching \fIexpectedErrorCode\fR, the test fails. Default value is +.QW "\fB*\fR" . +If \fB\-returnCodes\fR does not include \fBerror\fR it is set to \fBerror\fR. .PP To pass, a test must successfully evaluate its \fB\-setup\fR, \fB\-body\fR, and \fB\-cleanup\fR scripts. The return code of the \fB\-body\fR script and its result must match expected values, and if specified, output and error data from the test must match expected \fB\-output\fR and \fB\-errorOutput\fR Index: library/init.tcl ================================================================== --- library/init.tcl +++ library/init.tcl @@ -808,10 +808,10 @@ 0 http 2.9.0 {http http.tcl} 1 msgcat 1.7.0 {msgcat msgcat.tcl} 1 opt 0.4.7 {opt optparse.tcl} 0 platform 1.0.14 {platform platform.tcl} 0 platform::shell 1.1.4 {platform shell.tcl} - 1 tcltest 2.4.1 {tcltest tcltest.tcl} + 1 tcltest 2.5.0 {tcltest tcltest.tcl} } { if {$isafe && !$safe} continue package ifneeded $package $version [list source [file join $dir {*}$file]] } Index: library/tcltest/pkgIndex.tcl ================================================================== --- library/tcltest/pkgIndex.tcl +++ library/tcltest/pkgIndex.tcl @@ -7,6 +7,6 @@ # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]] Index: library/tcltest/tcltest.tcl ================================================================== --- library/tcltest/tcltest.tcl +++ library/tcltest/tcltest.tcl @@ -20,11 +20,11 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.4.1 + variable Version 2.5.0 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] # yourself. You don't need tcltest to wrap it for you. variable version [package provide Tcl] @@ -1839,10 +1839,13 @@ # is optional; default is {}. # errorOutput - Expected output sent to stderr. This attribute # is optional; default is {}. # returnCodes - Expected return codes. This attribute is # optional; default is {0 2}. +# errorCode - Expected error code. This attribute is +# optional; default is {*}. It is a glob pattern. +# If given, returnCodes defaults to {1}. # setup - Code to run before $script (above). This # attribute is optional; default is {}. # cleanup - Code to run after $script (above). This # attribute is optional; default is {}. # match - specifies type of matching to do on result, @@ -1880,19 +1883,22 @@ incr testLevel # Pre-define everything to null except output and errorOutput. We # determine whether or not to trap output based on whether or not # these variables (output & errorOutput) are defined. - lassign {} constraints setup cleanup body result returnCodes match + lassign {} constraints setup cleanup body result returnCodes errorCode match # Set the default match mode set match exact # Set the default match values for return codes (0 is the standard # expected return value if everything went well; 2 represents # 'return' being used in the test script). set returnCodes [list 0 2] + + # Set the default error code pattern + set errorCode "*" # The old test format can't have a 3rd argument (constraints or # script) that starts with '-'. if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { if {[llength $args] == 1} { @@ -1899,11 +1905,11 @@ set list [SubstArguments [lindex $args 0]] foreach {element value} $list { set testAttributes($element) $value } foreach item {constraints match setup body cleanup \ - result returnCodes output errorOutput} { + result returnCodes errorCode output errorOutput} { if {[info exists testAttributes(-$item)]} { set testAttributes(-$item) [uplevel 1 \ ::concat $testAttributes(-$item)] } } @@ -1910,11 +1916,11 @@ } else { array set testAttributes $args } set validFlags {-setup -cleanup -body -result -returnCodes \ - -match -output -errorOutput -constraints} + -errorCode -match -output -errorOutput -constraints} foreach flag [array names testAttributes] { if {$flag ni $validFlags} { incr testLevel -1 set sorted [lsort $validFlags] @@ -1942,10 +1948,14 @@ # Replace symbolic valies supplied for -returnCodes foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] } + # errorCode without returnCode 1 is meaningless + if {$errorCode ne "*" && 1 ni $returnCodes} { + set returnCodes 1 + } } else { # This is parsing for the old test command format; it is here # for backward compatibility. set result [lindex $args end] if {[llength $args] == 2} { @@ -1974,11 +1984,11 @@ # First, run the setup script set code [catch {uplevel 1 $setup} setupMsg] if {$code == 1} { set errorInfo(setup) $::errorInfo - set errorCode(setup) $::errorCode + set errorCodeRes(setup) $::errorCode } set setupFailure [expr {$code != 0}] # Only run the test body if the setup was successful if {!$setupFailure} { @@ -2001,18 +2011,23 @@ set testResult [uplevel 1 [list [namespace origin Eval] $command 1]] } lassign $testResult actualAnswer returnCode if {$returnCode == 1} { set errorInfo(body) $::errorInfo - set errorCode(body) $::errorCode + set errorCodeRes(body) $::errorCode } } # check if the return code matched the expected return code set codeFailure 0 if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 + } + set errorCodeFailure 0 + if {!$setupFailure && !$codeFailure && $returnCode == 1 && \ + ![string match $errorCode $errorCodeRes(body)]} { + set errorCodeFailure 1 } # If expected output/error strings exist, we have to compare # them. If the comparison fails, then so did the test. set outputFailure 0 @@ -2053,11 +2068,11 @@ # Always run the cleanup script set code [catch {uplevel 1 $cleanup} cleanupMsg] if {$code == 1} { set errorInfo(cleanup) $::errorInfo - set errorCode(cleanup) $::errorCode + set errorCodeRes(cleanup) $::errorCode } set cleanupFailure [expr {$code != 0}] set coreFailure 0 set coreMsg "" @@ -2104,11 +2119,11 @@ # if we didn't experience any failures, then we passed variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure || $outputFailure || $errorFailure || $codeFailure - || $scriptFailure)} { + || $errorCodeFailure || $scriptFailure)} { if {$testLevel == 1} { incr numTests(Passed) if {[IsVerbose pass]} { puts [outputChannel] "++++ $name PASSED" } @@ -2157,11 +2172,11 @@ if {$setupFailure} { puts [outputChannel] "---- Test setup\ failed:\n$setupMsg" if {[info exists errorInfo(setup)]} { puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" - puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" + puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)" } } if {$scriptFailure} { if {$scriptCompare} { puts [outputChannel] "---- Error testing result: $scriptMatch" @@ -2169,10 +2184,14 @@ puts [outputChannel] "---- Result was:\n$actualAnswer" puts [outputChannel] "---- Result should have been\ ($match matching):\n$result" } } + if {$errorCodeFailure} { + puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'" + puts [outputChannel] "---- Error code should have been: '$errorCode'" + } if {$codeFailure} { switch -- $returnCode { 0 { set msg "Test completed normally" } 1 { set msg "Test generated error" } 2 { set msg "Test generated return exception" } @@ -2184,11 +2203,11 @@ puts [outputChannel] "---- Return code should have been\ one of: $returnCodes" if {[IsVerbose error]} { if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { puts [outputChannel] "---- errorInfo: $errorInfo(body)" - puts [outputChannel] "---- errorCode: $errorCode(body)" + puts [outputChannel] "---- errorCode: $errorCodeRes(body)" } } } if {$outputFailure} { if {$outputCompare} { @@ -2210,11 +2229,11 @@ } if {$cleanupFailure} { puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" if {[info exists errorInfo(cleanup)]} { puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" - puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" + puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)" } } if {$coreFailure} { puts [outputChannel] "---- Core file produced while running\ test! $coreMsg" Index: tests/assemble.test ================================================================== --- tests/assemble.test +++ tests/assemble.test @@ -10,11 +10,11 @@ #----------------------------------------------------------------------------- # Commands covered: assemble if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } namespace eval tcl::unsupported {namespace export assemble} namespace import tcl::unsupported::assemble @@ -850,14 +850,15 @@ } test assemble-8.5 {bad context} { -body { namespace eval assem { set x 1 - list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode] + assemble {load x} } } - -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} + -result {cannot use this instruction to create a variable in a non-proc context} + -errorCode {TCL ASSEM LVT} -cleanup {namespace delete assem} } test assemble-8.6 {load1} { -body { proc x {a} { @@ -1108,14 +1109,14 @@ } -result hello } test assemble-9.7 {concat} { -body { - list [catch {assemble {concat 0}} result] $result $::errorCode + assemble {concat 0} } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {unset result} + -result {operand must be positive} + -errorCode {TCL ASSEM POSITIVE} } # assemble-10 -- eval and expr test assemble-10.1 {eval - wrong # args} { Index: tests/dict.test ================================================================== --- tests/dict.test +++ tests/dict.test @@ -8,11 +8,11 @@ # Copyright (c) 2003-2009 Donal K. Fellows # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -173,15 +173,11 @@ test dict-4.12 {dict replace command: canonicality is forced} { dict replace {a b c d a e} } {a e c d} test dict-4.13 {dict replace command: type check is mandatory} -body { dict replace { a b c d e } -} -returnCodes error -result {missing value to go with key} -test dict-4.13a {dict replace command: type check is mandatory} { - catch {dict replace { a b c d e }} -> opt - dict get $opt -errorcode -} {TCL VALUE DICTIONARY} +} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key} test dict-4.14 {dict replace command: type check is mandatory} -body { dict replace { a b {}c d } } -returnCodes error -result {dict element in braces followed by "c" instead of space} test dict-4.14a {dict replace command: type check is mandatory} { catch {dict replace { a b {}c d }} -> opt @@ -201,15 +197,11 @@ catch {dict replace " a b \"c d "} -> opt dict get $opt -errorcode } {TCL VALUE DICTIONARY QUOTE} test dict-4.17 {dict replace command: type check is mandatory} -body { dict replace " a b \{c d " -} -returnCodes error -result {unmatched open brace in dict} -test dict-4.17a {dict replace command: type check is mandatory} { - catch {dict replace " a b \{c d "} -> opt - dict get $opt -errorcode -} {TCL VALUE DICTIONARY BRACE} +} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict} test dict-4.18 {dict replace command: canonicality forcing doesn't leak} { set example { a b c d } list $example [dict replace $example] } {{ a b c d } {a b c d}} Index: tests/ioCmd.test ================================================================== --- tests/ioCmd.test +++ tests/ioCmd.test @@ -12,11 +12,11 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -152,14 +152,14 @@ [list 1 [format "channel \"%s\" wasn't opened for reading" $f] none] } 0 test iocmd-4.12 {read command} -setup { set f [open $path(test1)] } -body { - list [catch {read $f 12z} msg] $msg $::errorCode + read $f 12z } -cleanup { close $f -} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}} +} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER} test iocmd-5.1 {seek command} -returnCodes error -body { seek } -result {wrong # args: should be "seek channelId offset ?origin?"} test iocmd-5.2 {seek command} -returnCodes error -body { Index: tests/source.test ================================================================== --- tests/source.test +++ tests/source.test @@ -10,12 +10,12 @@ # Contributions from Don Porter, NIST, 2003. (not subject to US copyright) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." +if {[catch {package require tcltest 2.5}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.5 required." return } namespace eval ::tcl::test::source { namespace import ::tcltest::* @@ -101,14 +101,13 @@ } -returnCodes continue test source-2.6 {source error conditions} -setup { set sourcefile [makeFile {} _non_existent_] removeFile _non_existent_ } -body { - list [catch {source $sourcefile} msg] $msg $::errorCode -} -match listGlob -result [list 1 \ - {couldn't read file "*_non_existent_": no such file or directory} \ - {POSIX ENOENT {no such file or directory}}] + source $sourcefile +} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \ + -errorCode {POSIX ENOENT {no such file or directory}} test source-2.7 {utf-8 with BOM} -setup { set sourcefile [makeFile {} source.file] } -body { set out [open $sourcefile w] fconfigure $out -encoding utf-8 Index: tests/tcltest.test ================================================================== --- tests/tcltest.test +++ tests/tcltest.test @@ -1205,11 +1205,11 @@ test tcltest-21.2.0 { return 2 } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { -setup { set foo 1 @@ -1298,11 +1298,11 @@ test tcltest-21.7.0 {foo-4} { -foobar {} } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -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) @@ -1318,11 +1318,11 @@ return 2 } {1} } \ -returnCodes 1 \ -cleanup {set ::tcltest::currentFailure $fail} \ - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ -body {set foo} \ -cleanup {unset foo} \ Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -931,13 +931,13 @@ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done @echo "Installing package msgcat 1.7.0 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \ "$(MODULE_INSTALL_DIR)"/tcl8/8.7/msgcat-1.7.0.tm - @echo "Installing package tcltest 2.4.1 as a Tcl Module" + @echo "Installing package tcltest 2.5.0 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ - "$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.4.1.tm + "$(MODULE_INSTALL_DIR)"/tcl8/8.5/tcltest-2.5.0.tm @echo "Installing package platform 1.0.14 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ "$(MODULE_INSTALL_DIR)"/tcl8/8.4/platform-1.0.14.tm @echo "Installing package platform::shell 1.1.4 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \