2004-11-02 Don Porter <dgp@users.sourceforge.net>

        * library/tcltest/tcltest.tcl:          Corrected some misleading
        * tests/tcltest.test (tcltest-26.1,2):  displays of ::errorInfo and
        ::errorCode information when the -setup, -body, and/or -cleanup scripts
        return an unexpected return code.  Thanks to Robert Seeger for the
        fix. [RFE 1017151].

3 files changed, 74 insertions, 5 deletions

diff --git a/ChangeLog b/ChangeLog
index 98a7280..f0f86fb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2004-11-02  Don Porter  <dgp@users.sourceforge.net>
+
+	* library/tcltest/tcltest.tcl:		Corrected some misleading
+	* tests/tcltest.test (tcltest-26.1,2):	displays of ::errorInfo and
+	::errorCode information when the -setup, -body, and/or -cleanup scripts
+	return an unexpected return code.  Thanks to Robert Seeger for the
+	fix. [RFE 1017151].
+
 2004-11-02  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
 	* generic/tclExecute.c (TclExecuteByteCode): Improved version of
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 0e01828..5132f8e 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -16,7 +16,7 @@
 # Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
 # All rights reserved.
 #
-# RCS: @(#) $Id: tcltest.tcl,v 1.92 2004/10/30 02:16:52 dgp Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.93 2004/11/02 19:03:29 dgp Exp $
 
 package require Tcl 8.3		;# uses [glob -directory]
 namespace eval tcltest {
@@ -1949,6 +1949,10 @@ proc tcltest::test {name description args} {
 
     # First, run the setup script
     set code [catch {uplevel 1 $setup} setupMsg]
+    if {$code == 1} {
+	set errorInfo(setup) $::errorInfo
+	set errorCode(setup) $::errorCode
+    }
     set setupFailure [expr {$code != 0}]
 
     # Only run the test body if the setup was successful
@@ -1967,10 +1971,18 @@ proc tcltest::test {name description args} {
 	    set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
 	}
 	foreach {actualAnswer returnCode} $testResult break
+	if {$returnCode == 1} {
+	    set errorInfo(body) $::errorInfo
+	    set errorCode(body) $::errorCode
+	}
     }
 
     # Always run the cleanup script
     set code [catch {uplevel 1 $cleanup} cleanupMsg]
+    if {$code == 1} {
+	set errorInfo(cleanup) $::errorInfo
+	set errorCode(cleanup) $::errorCode
+    }
     set cleanupFailure [expr {$code != 0}]
 
     set coreFailure 0
@@ -2084,6 +2096,10 @@ proc tcltest::test {name description args} {
     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)"
+	}
     }
     if {$scriptFailure} {
 	if {$scriptCompare} {
@@ -2107,9 +2123,9 @@ proc tcltest::test {name description args} {
 	puts [outputChannel] "---- Return code should have been\
 		one of: $returnCodes"
 	if {[IsVerbose error]} {
-	    if {[info exists ::errorInfo]} {
-		puts [outputChannel] "---- errorInfo: $::errorInfo"
-		puts [outputChannel] "---- errorCode: $::errorCode"
+	    if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} {
+		puts [outputChannel] "---- errorInfo: $errorInfo(body)"
+		puts [outputChannel] "---- errorCode: $errorCode(body)"
 	    }
 	}
     }
@@ -2133,6 +2149,10 @@ proc tcltest::test {name description args} {
     }
     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)"
+	}
     }
     if {$coreFailure} {
 	puts [outputChannel] "---- Core file produced while running\
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 6e2ba7b..5dee76f 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.45 2004/09/11 00:39:47 davygrvy Exp $
+# RCS: @(#) $Id: tcltest.test,v 1.46 2004/11/02 19:03:29 dgp Exp $
 
 # Note that there are several places where the value of 
 # tcltest::currentFailure is stored/reset in the -setup/-cleanup
@@ -1740,6 +1740,47 @@ test tcltest-25.3 {
 	verbose $v
 } -match glob -output {*generated error; Return code was: 1*}
 
+test tcltest-26.1 {Bug/RFE 1017151} -setup {
+    makeFile {
+	package require tcltest
+	set errorInfo "Should never see this"
+	tcltest::test tcltest-26.1.0 {
+	    no errorInfo when only return code mismatch
+	} -body {
+	    set x 1
+	} -returnCodes error -result 1
+	tcltest::cleanupTests
+    } test.tcl
+} -body {
+    slave msg test.tcl
+    set msg
+} -cleanup {
+    removeFile test.tcl
+} -match glob -result {*
+---- Return code should have been one of: 1
+==== tcltest-26.1.0 FAILED*}
+
+test tcltest-26.2 {Bug/RFE 1017151} -setup {
+    makeFile {
+	package require tcltest
+	set errorInfo "Should never see this"
+	tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body {
+	    error "body error"
+	} -cleanup {
+	    error "cleanup error"
+	} -result 1
+	tcltest::cleanupTests
+    } test.tcl
+} -body {
+    slave msg test.tcl
+    set msg
+} -cleanup {
+    removeFile test.tcl
+} -match glob -result {*
+---- errorInfo: body error
+*
+---- errorInfo(cleanup): cleanup error*}
+
 cleanupTests
 }