merge trunk

1 files changed, 64 insertions, 66 deletions

diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index c30d2e4..29ef778 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.3.6
+    variable Version 2.3.8
 
     # Compatibility support for dumb variables defined in tcltest 1
     # Do not use these.  Call [package provide Tcl] and [info patchlevel]
@@ -347,7 +347,7 @@ namespace eval tcltest {
 	# This is very subtle and tricky, so let me try to explain.
 	# (Hopefully this longer comment will be clear when I come
 	# back in a few months, unlike its predecessor :) )
-	# 
+	#
 	# The [outputChannel] command (and underlying variable) have to
 	# be kept in sync with the [configure -outfile] configuration
 	# option ( and underlying variable Option(-outfile) ).  This is
@@ -362,12 +362,12 @@ namespace eval tcltest {
 	# configuration options to parse the command line option the first
 	# time they are read.  These traces are cancelled whenever the
 	# program itself calls [configure].
-	# 
+	#
 	# OK, then so to support tcltest 1 compatibility, it seems we want
 	# to get the return from [outputFile] to trigger the read traces,
 	# just in case.
 	#
-	# BUT!  A little known feature of Tcl variable traces is that 
+	# BUT!  A little known feature of Tcl variable traces is that
 	# traces are disabled during the handling of other traces.  So,
 	# if we trigger read traces on Option(-outfile) and that triggers
 	# command line parsing which turns around and sets an initial
@@ -608,7 +608,7 @@ namespace eval tcltest {
 	set code [catch {Configure {*}$args} msg]
 	return -code $code $msg
     }
-    
+
     proc AcceptVerbose { level } {
 	set level [AcceptList $level]
 	if {[llength $level] == 1} {
@@ -639,7 +639,7 @@ namespace eval tcltest {
 	skipped tests if 's' is specified, the bodies of failed tests if
 	'b' is specified, and when tests start if 't' is specified.
 	ErrorInfo is displayed if 'e' is specified. Source file line
-	information of failed tests is displayed if 'l' is specified. 
+	information of failed tests is displayed if 'l' is specified.
     } AcceptVerbose verbose
 
     # Match and skip patterns default to the empty list, except for
@@ -687,7 +687,7 @@ namespace eval tcltest {
     # some additional output regarding operations of the test harness.
     # The tcltest package currently implements only up to debug level 3.
     Option -debug 0 {
-	Internal debug level 
+	Internal debug level
     } AcceptInteger debug
 
     proc SetSelectedConstraints args {
@@ -715,7 +715,7 @@ namespace eval tcltest {
     }
     Option -limitconstraints 0 {
 	whether to run only tests with the constraints
-    } AcceptBoolean limitConstraints 
+    } AcceptBoolean limitConstraints
     trace add variable Option(-limitconstraints) write \
 	    [namespace code {ClearUnselectedConstraints ;#}]
 
@@ -728,7 +728,7 @@ namespace eval tcltest {
     # Default is to run each test file in a separate process
     Option -singleproc 0 {
 	whether to run all tests in one process
-    } AcceptBoolean singleProcess 
+    } AcceptBoolean singleProcess
 
     proc AcceptTemporaryDirectory { directory } {
 	set directory [AcceptAbsolutePath $directory]
@@ -1257,7 +1257,7 @@ proc tcltest::DefineConstraintInitializers {} {
     # setting files into nonblocking mode.
 
     ConstraintInitializer nonBlockFiles {
-	    set code [expr {[catch {set f [open defs r]}] 
+	    set code [expr {[catch {set f [open defs r]}]
 		    || [catch {chan configure $f -blocking off}]}]
 	    catch {close $f}
 	    set code
@@ -1271,7 +1271,7 @@ proc tcltest::DefineConstraintInitializers {} {
     # (Mark Diekhans).
 
     ConstraintInitializer asyncPipeClose {expr {
-	    !([string equal unix $::tcl_platform(platform)] 
+	    !([string equal unix $::tcl_platform(platform)]
 	    && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
 
     # Test to see if we have a broken version of sprintf with respect
@@ -1954,7 +1954,7 @@ proc tcltest::test {name description args} {
 	return
     }
 
-    # Save information about the core file.  
+    # Save information about the core file.
     if {[preserveCore]} {
 	if {[file exists [file join [workingDirectory] core]]} {
 	    set coreModTime [file mtime [file join [workingDirectory] core]]
@@ -1991,47 +1991,6 @@ proc tcltest::test {name description args} {
 	}
     }
 
-    # 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
-    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 +2035,47 @@ proc tcltest::test {name description args} {
 	set scriptFailure 1
     }
 
+    # 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
+    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
@@ -2100,7 +2100,7 @@ proc tcltest::test {name description args} {
     variable currentFailure true
     if {![IsVerbose body]} {
 	set body ""
-    }	
+    }
     puts [outputChannel] "\n"
     if {[IsVerbose line]} {
 	if {![catch {set testFrame [info frame -1]}] &&
@@ -2121,7 +2121,7 @@ proc tcltest::test {name description args} {
 	    puts [outputChannel] "$testFile:$testLine: error: test failed:\
 		    $name [string trim $description]"
 	}
-    }	
+    }
     puts [outputChannel] "==== $name\
 	    [string trim $description] FAILED"
     if {[string length $body]} {
@@ -2277,7 +2277,7 @@ proc tcltest::Skipped {name constraints} {
 		}
 	    }
 	}
-	
+
 	if {!$doTest} {
 	    if {[IsVerbose skip]} {
 		puts [outputChannel] "++++ $name SKIPPED: $constraints"
@@ -2498,17 +2498,15 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
 	    if {![info exists originalEnv($index)]} {
 		lappend newEnv $index
 		unset ::env($index)
-	    } else {
-		if {$::env($index) != $originalEnv($index)} {
-		    lappend changedEnv $index
-		    set ::env($index) $originalEnv($index)
-		}
 	    }
 	}
 	foreach index [array names originalEnv] {
 	    if {![info exists ::env($index)]} {
 		lappend removedEnv $index
 		set ::env($index) $originalEnv($index)
+	    } elseif {$::env($index) ne $originalEnv($index)} {
+		lappend changedEnv $index
+		set ::env($index) $originalEnv($index)
 	    }
 	}
 	if {[llength $newEnv] > 0} {
@@ -2836,9 +2834,9 @@ proc tcltest::runAllTests { {shell ""} } {
 	set dir [file tail $directory]
 	puts [outputChannel] [string repeat ~ 44]
 	puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
-	
+
 	uplevel 1 [list ::source [file join $directory all.tcl]]
-	
+
 	set endTime [eval $timeCmd]
 	puts [outputChannel] "\n$dir test ended at $endTime"
 	puts [outputChannel] ""
@@ -3021,7 +3019,7 @@ proc tcltest::removeFile {name {directory ""}} {
 	DebugDo 1 {
 	    Warn "removeFile removing \"$fullName\":\n  not created by makeFile"
 	}
-    } 
+    }
     if {![file isfile $fullName]} {
 	DebugDo 1 {
 	    Warn "removeFile removing \"$fullName\":\n  not a file"
@@ -3092,7 +3090,7 @@ proc tcltest::removeDirectory {name {directory ""}} {
 	    Warn "removeDirectory removing \"$fullName\":\n  not created\
 		    by makeDirectory"
 	}
-    } 
+    }
     if {![file isdirectory $fullName]} {
 	DebugDo 1 {
 	    Warn "removeDirectory removing \"$fullName\":\n  not a directory"
@@ -3287,7 +3285,7 @@ proc tcltest::threadReap {} {
 	testthread errorproc ThreadError
 	return [llength [testthread names]]
     } elseif {[info commands thread::id] ne {}} {
-	
+
 	# Thread extension
 
 	thread::errorproc ThreadNullError