diff options
author | jan.nijtmans <nijtmans@users.sourceforge.net> | 2014-06-23 12:48:16 (GMT) |
---|---|---|
committer | jan.nijtmans <nijtmans@users.sourceforge.net> | 2014-06-23 12:48:16 (GMT) |
commit | 2b8bf1a9f78976b319f00258e80ed4c3fe467e50 (patch) | |
tree | 5d6b438466d0da5c1a2dbdd3b26a6cb18f655b69 /library/tcltest/tcltest.tcl | |
parent | 5d8942cb06b4c5a6b538dd5d80eb4f039bd36d34 (diff) | |
download | tcl-2b8bf1a9f78976b319f00258e80ed4c3fe467e50.zip tcl-2b8bf1a9f78976b319f00258e80ed4c3fe467e50.tar.gz tcl-2b8bf1a9f78976b319f00258e80ed4c3fe467e50.tar.bz2 |
Fix execute-6.5 test failure on trunk: the "preserveCore" part of tcltest::test assumes that the cleanup is done first, so moving the cleanup means the the "preserverCore" part needs to move with it.
Diffstat (limited to 'library/tcltest/tcltest.tcl')
-rw-r--r-- | library/tcltest/tcltest.tcl | 66 |
1 files changed, 33 insertions, 33 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 22d79e1..8e43859 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1991,39 +1991,6 @@ proc tcltest::test {name description args} { } } - set coreFailure 0 - set coreMsg "" - # check for a core file first - if one was created by the test, - # then the test failed - if {[preserveCore]} { - if {[file exists [file join [workingDirectory] core]]} { - # There's only a test failure if there is a core file - # and (1) there previously wasn't one or (2) the new - # one is different from the old one. - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join [workingDirectory] core]]} { - set coreFailure 1 - } - } else { - set coreFailure 1 - } - - if {([preserveCore] > 1) && ($coreFailure)} { - append coreMsg "\nMoving file to:\ - [file join [temporaryDirectory] core-$name]" - catch {file rename -force -- \ - [file join [workingDirectory] core] \ - [file join [temporaryDirectory] core-$name] - } msg - if {$msg ne {}} { - append coreMsg "\nError:\ - Problem renaming core file: $msg" - } - } - } - } - # check if the return code matched the expected return code set codeFailure 0 if {!$setupFailure && ($returnCode ni $returnCodes)} { @@ -2076,6 +2043,39 @@ proc tcltest::test {name description args} { } set cleanupFailure [expr {$code != 0}] + set coreFailure 0 + set coreMsg "" + # check for a core file first - if one was created by the test, + # then the test failed + if {[preserveCore]} { + if {[file exists [file join [workingDirectory] core]]} { + # There's only a test failure if there is a core file + # and (1) there previously wasn't one or (2) the new + # one is different from the old one. + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [workingDirectory] core]]} { + set coreFailure 1 + } + } else { + set coreFailure 1 + } + + if {([preserveCore] > 1) && ($coreFailure)} { + append coreMsg "\nMoving file to:\ + [file join [temporaryDirectory] core-$name]" + catch {file rename -force -- \ + [file join [workingDirectory] core] \ + [file join [temporaryDirectory] core-$name] + } msg + if {$msg ne {}} { + append coreMsg "\nError:\ + Problem renaming core file: $msg" + } + } + } + } + # if we didn't experience any failures, then we passed variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure |