summaryrefslogtreecommitdiffstats
path: root/library/tcltest/tcltest.tcl
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2004-11-02 19:03:04 (GMT)
committerdgp <dgp@users.sourceforge.net>2004-11-02 19:03:04 (GMT)
commit85b5881a0a77a3e3f640365026d6c8722f83c4df (patch)
tree43d52e5aac7dbc1f74096edb2e9afc91b6f30b1a /library/tcltest/tcltest.tcl
parent22950832b701d9cbc8f109de3cf39f70fe4745b3 (diff)
downloadtcl-85b5881a0a77a3e3f640365026d6c8722f83c4df.zip
tcl-85b5881a0a77a3e3f640365026d6c8722f83c4df.tar.gz
tcl-85b5881a0a77a3e3f640365026d6c8722f83c4df.tar.bz2
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].
Diffstat (limited to 'library/tcltest/tcltest.tcl')
-rw-r--r--library/tcltest/tcltest.tcl28
1 files changed, 24 insertions, 4 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 9398ea4..eac8278 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.78.2.11 2004/10/30 03:16:14 dgp Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.78.2.12 2004/11/02 19:03:07 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\