diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 28 | ||||
| -rwxr-xr-x | tests/tcltest.test | 43 |
3 files changed, 74 insertions, 5 deletions
@@ -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): NaN-equality fix from 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\ diff --git a/tests/tcltest.test b/tests/tcltest.test index 90a87af..ae5332d 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.37.2.5 2004/10/26 20:14:37 dgp Exp $ +# RCS: @(#) $Id: tcltest.test,v 1.37.2.6 2004/11/02 19:03:08 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 } |