[TIP 525] Backport package tcltest 2.5

6 files changed, 55 insertions, 26 deletions

diff --git a/doc/tcltest.n b/doc/tcltest.n
index 05c1922..b161a2b 100644
--- a/doc/tcltest.n
+++ b/doc/tcltest.n
@@ -8,7 +8,7 @@
 '\" 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!
@@ -16,7 +16,7 @@
 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
@@ -454,6 +454,7 @@ The valid options for \fBtest\fR are summarized:
         ?\fB\-output \fIexpectedOutput\fR?
         ?\fB\-errorOutput \fIexpectedError\fR?
         ?\fB\-returnCodes \fIcodeList\fR?
+        ?\fB\-errorCode \fIexpectedErrorCode\fR?
         ?\fB\-match \fImode\fR?
 .CE
 .PP
@@ -577,6 +578,15 @@ 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
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
index c9d3759..fde3ffe 100644
--- a/library/tcltest/pkgIndex.tcl
+++ b/library/tcltest/pkgIndex.tcl
@@ -8,5 +8,5 @@
 # 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]]
+if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
+package ifneeded tcltest 2.5.0 [list source [file join $dir tcltest.tcl]]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index f1b6082..410aa24 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -22,7 +22,7 @@ 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]
@@ -1841,6 +1841,9 @@ proc tcltest::SubstArguments {argList} {
 #                       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
@@ -1882,7 +1885,7 @@ proc tcltest::test {name description args} {
     # 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
@@ -1892,6 +1895,9 @@ proc tcltest::test {name description args} {
     # '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)} {
@@ -1901,7 +1907,7 @@ proc tcltest::test {name description args} {
 		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)]
@@ -1912,7 +1918,7 @@ proc tcltest::test {name description 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} {
@@ -1944,6 +1950,10 @@ proc tcltest::test {name description args} {
 	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.
@@ -1976,7 +1986,7 @@ proc tcltest::test {name description args} {
     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}]
 
@@ -2003,7 +2013,7 @@ proc tcltest::test {name description args} {
 	lassign $testResult actualAnswer returnCode
 	if {$returnCode == 1} {
 	    set errorInfo(body) $::errorInfo
-	    set errorCode(body) $::errorCode
+	    set errorCodeRes(body) $::errorCode
 	}
     }
 
@@ -2012,6 +2022,11 @@ proc tcltest::test {name description args} {
     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.
@@ -2055,7 +2070,7 @@ proc tcltest::test {name description args} {
     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}]
 
@@ -2106,7 +2121,7 @@ proc tcltest::test {name description args} {
     variable numTests
     if {!($setupFailure || $cleanupFailure || $coreFailure
 	    || $outputFailure || $errorFailure || $codeFailure
-	    || $scriptFailure)} {
+	    || $errorCodeFailure || $scriptFailure)} {
 	if {$testLevel == 1} {
 	    incr numTests(Passed)
 	    if {[IsVerbose pass]} {
@@ -2159,7 +2174,7 @@ proc tcltest::test {name description args} {
 		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} {
@@ -2171,6 +2186,10 @@ proc tcltest::test {name description args} {
 		    ($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" }
@@ -2186,7 +2205,7 @@ proc tcltest::test {name description args} {
 	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)"
 	    }
 	}
     }
@@ -2212,7 +2231,7 @@ proc tcltest::test {name description args} {
 	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} {
@@ -2722,7 +2741,7 @@ proc tcltest::GetMatchingDirectories {rootdir} {
 #	shell being tested
 #
 # Results:
-#	None.
+#	Whether there were any failures.
 #
 # Side effects:
 #	None.
@@ -2868,7 +2887,7 @@ proc tcltest::runAllTests { {shell ""} } {
 	puts [outputChannel] ""
 	puts [outputChannel] [string repeat ~ 44]
     }
-    return
+    return [info exists testFileFailures]
 }
 
 #####################################################################
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 0bcf342..ca720ee 100644
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -908,7 +908,7 @@ removeFile load.tcl
 
 # [interpreter]
 test tcltest-13.1 {interpreter} {
-    -constraints notValgrind 
+    -constraints notValgrind
     -setup {
 	#to do:  Why is $::tcltest::tcltest being saved and restored here?
 	set old $::tcltest::tcltest
@@ -926,7 +926,7 @@ test tcltest-13.1 {interpreter} {
 	# constraint, which involves a call to [exec] that might fail after
 	# "fork" and before "exec", in which case the forked process will not
 	# have a chance to clean itself up before exiting, which causes
-	# valgrind to issue numerous "still reachable" reports. 
+	# valgrind to issue numerous "still reachable" reports.
 	set ::tcltest::tcltest $old
     }
 }
@@ -1207,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} {
 	} {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} {
@@ -1300,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} {
 	}
     }
     -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
@@ -1320,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \
     } \
     -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} \
diff --git a/unix/Makefile.in b/unix/Makefile.in
index a2621a3..66114ba 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -851,8 +851,8 @@ install-libraries: libraries
 	    done;
 	@echo "Installing package msgcat 1.6.1 as a Tcl Module";
 	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm;
-	@echo "Installing package tcltest 2.4.1 as a Tcl Module";
-	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm;
+	@echo "Installing package tcltest 2.5.0 as a Tcl Module";
+	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_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 "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm;
diff --git a/win/Makefile.in b/win/Makefile.in
index 8ce57f2..9d955cd 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -660,8 +660,8 @@ install-libraries: libraries install-tzdata install-msgs
 	    done;
 	@echo "Installing package msgcat 1.6.1 as a Tcl Module";
 	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm;
-	@echo "Installing package tcltest 2.4.1 as a Tcl Module";
-	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.1.tm;
+	@echo "Installing package tcltest 2.5.0 as a Tcl Module";
+	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.5.0.tm;
 	@echo "Installing package platform 1.0.14 as a Tcl Module";
 	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm;
 	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";