Index: library/tcltest/pkgIndex.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/tcltest/pkgIndex.tcl,v
retrieving revision 1.17
diff -u -r1.17 pkgIndex.tcl
--- library/tcltest/pkgIndex.tcl	3 Feb 2004 18:51:10 -0000	1.17
+++ library/tcltest/pkgIndex.tcl	23 Feb 2004 20:01:01 -0000
@@ -9,4 +9,4 @@
 # full path name of this file's directory.
 
 if {![package vsatisfies [package provide Tcl] 8.3]} {return}
-package ifneeded tcltest 2.2.5 [list source [file join $dir tcltest.tcl]]
+package ifneeded tcltest 2.3 [list source [file join $dir tcltest.tcl]]
Index: library/tcltest/tcltest.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/tcltest/tcltest.tcl,v
retrieving revision 1.87
diff -u -r1.87 tcltest.tcl
--- library/tcltest/tcltest.tcl	18 Feb 2004 01:41:42 -0000	1.87
+++ library/tcltest/tcltest.tcl	23 Feb 2004 20:01:01 -0000
@@ -14,17 +14,31 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # Copyright (c) 2000 by Ajuba Solutions
 # Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
-# All rights reserved.
+# Contributions from David N. Welton <davidw@dedasys.com>, 2003.
+#
+# See the 'license.terms' file in the Tcl distribution for licensing terms.
 #
 # RCS: @(#) $Id: tcltest.tcl,v 1.87 2004/02/18 01:41:42 dgp Exp $
 
 package require Tcl 8.3		;# uses [glob -directory]
+  namespace eval tcltest {
+    # This namespace holds information about the files evaluated.
+    namespace eval files {}
+    # This namespace is for information about test constraints.
+    namespace eval constraints {}
+}
+
+source [file join [file dirname [info script]] tcltestapi.tcl]
+source [file join [file dirname [info script]] constraints.tcl]
+source [file join [file dirname [info script]] testresults.tcl]
+source [file join [file dirname [info script]] files.tcl]
+
 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.2.5
+    variable Version 2.3
 
     # Compatibility support for dumb variables defined in tcltest 1
     # Do not use these.  Call [package provide Tcl] and [info patchlevel]
@@ -32,7 +46,12 @@
     variable version [package provide Tcl]
     variable patchLevel [info patchlevel]
 
-##### Export the public tcltest procs; several categories
+    # Default callbacks.
+    testcallback tcltest::printcallback
+    printstatscallback tcltest::PrintStats
+    restorecallback tcltest::Restore
+
+    ##### Export the public tcltest procs; several categories
     #
     # Export the main functional commands that do useful things
     namespace export cleanupTests loadTestedCommands makeDirectory \
@@ -172,29 +191,6 @@
     # save the original environment so that it can be restored later
     ArrayDefault originalEnv [array get ::env]
 
-    # initialize numTests array to keep track of the number of tests
-    # that pass, fail, and are skipped.
-    ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
-
-    # createdNewFiles will store test files as indices and the list of
-    # files (that should not have been) left behind by the test files
-    # as values.
-    ArrayDefault createdNewFiles {}
-
-    # initialize skippedBecause array to keep track of constraints that
-    # kept tests from running; a constraint name of "userSpecifiedSkip"
-    # means that the test appeared on the list of tests that matched the
-    # -skip value given to the flag; "userSpecifiedNonMatch" means that
-    # the test didn't match the argument given to the -match flag; both
-    # of these constraints are counted only if tcltest::debug is set to
-    # true.
-    ArrayDefault skippedBecause {}
-
-    # initialize the testConstraints array to keep track of valid
-    # predefined constraints (see the explanation for the
-    # InitConstraints proc for more details).
-    ArrayDefault testConstraints {}
-
 ##### Initialize internal variables of tcltest, but only if the caller
     # has not already pre-initialized them.  This is done to support
     # compatibility with older tests that directly access internals
@@ -220,10 +216,9 @@
     # The currentFailure var stores the boolean value of whether the
     # current test file has had any failures.  The failFiles list
     # stores the names of test files that had failures.
-    Default numTestFiles 0 AcceptInteger
+#    Default numTestFiles 0 AcceptInteger
     Default testSingleFile true AcceptBoolean
     Default currentFailure false AcceptBoolean
-    Default failFiles {} AcceptList
 
     # Tests should remove all files they create.  The test suite will
     # check the current working dir for files created by the tests.
@@ -249,8 +244,12 @@
 
     # Kept only for compatibility
     Default constraintsSpecified {} AcceptList
-    trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
-		[array names ::tcltest::testConstraints] ;# }
+    #    trace variable constraintsSpecified r {set
+    # ::tcltest::constraintsSpecified [array names
+    # ::tcltest::testConstraints] ;# }
+    trace variable constraintsSpecified r \
+	{set ::tcltest::constraintsSpecified [::tcltest::constraints::getlist] ;# }
+
 
     # tests that use threads need to know which is the main thread
     Default mainThread 1
@@ -280,7 +279,7 @@
     # Set the location of the execuatble
     Default tcltest [info nameofexecutable]
     trace variable tcltest w [namespace code {testConstraint stdio \
-	    [eval [ConstraintInitializer stdio]] ;#}]
+	    [eval [constraints::ConstraintInitializer stdio]] ;#}]
 
     # save the platform information so it can be restored later
     Default originalTclPlatform [array get ::tcl_platform]
@@ -487,6 +486,7 @@
 	variable OptionControlledVariables
 	set Usage($option) $usage
 	set Verify($option) $verify
+
 	if {[catch {$verify $value} msg]} {
 	    return -code error $msg
 	} else {
@@ -520,6 +520,7 @@
 
     proc MatchingOption {option} {
 	variable Option
+
 	set match [array names Option $option*]
 	switch -- [llength $match] {
 	    0 {
@@ -576,6 +577,7 @@
 	if {$n == 0} {
 	    return [lsort [array names Option]]
 	}
+
 	if {$n == 1} {
 	    if {[catch {MatchingOption [lindex $args 0]} option]} {
 		return -code error $option
@@ -605,7 +607,7 @@
 	set code [catch {eval Configure $args} msg]
 	return -code $code $msg
     }
-    
+
     proc AcceptVerbose { level } {
 	set level [AcceptList $level]
 	if {[llength $level] == 1} {
@@ -701,9 +703,9 @@
     # Don't run only the "-constraint" specified tests by default
     proc ClearUnselectedConstraints args {
 	variable Option
-	variable testConstraints
+
 	if {!$Option(-limitconstraints)} {return}
-	foreach c [array names testConstraints] {
+	foreach c [constraints::getlist] {
 	    if {[lsearch -exact $Option(-constraints) $c] == -1} {
 		testConstraint $c 0
 	    }
@@ -777,8 +779,9 @@
     trace variable Option(-loadfile) w [namespace code ReadLoadScript]
 
     proc AcceptOutFile { file } {
-	if {[string equal stderr $file]} {return $file}
-	if {[string equal stdout $file]} {return $file}
+	if {[string equal stderr $file] || [string equal stdout $file]} {
+	    return $file
+	}
 	return [file join [temporaryDirectory] $file]
     }
 
@@ -796,6 +799,36 @@
     trace variable Option(-errfile) w \
 	    [namespace code {errorChannel $Option(-errfile) ;#}]
 
+    Option -api 0 {
+	Use tcltest results API to access test results.
+    } AcceptBoolean api
+
+    Option -dump 0 {
+	Dump the results of the tests so that they can be read for use with the results API.
+    } AcceptBoolean dump
+
+    namespace eval files {
+	set filelist [list]
+	tcltest::Default failFiles {} AcceptList
+    }
+
+    namespace eval constraints {
+	# initialize skippedBecause array to keep track of constraints
+	# that kept tests from running; a constraint name of
+	# "userSpecifiedSkip" means that the test appeared on the list
+	# of tests that matched the -skip value given to the flag;
+	# "userSpecifiedNonMatch" means that the test didn't match the
+	# argument given to the -match flag; both of these constraints
+	# are counted only if tcltest::debug is set to true.
+	array set skippedBecause {}
+
+	# initialize the vars namespace to keep track of valid
+	# predefined constraints (see the explanation for the
+	# InitConstraints proc for more details).
+	namespace eval vars {}
+	#array set  testConstraints {}
+    }
+
 }
 
 #####################################################################
@@ -925,21 +958,24 @@
 #	none
 
 proc tcltest::testConstraint {constraint {value ""}} {
-    variable testConstraints
     variable Option
+
     DebugPuts 3 "entering testConstraint $constraint $value"
+
     if {[llength [info level 0]] == 2} {
-	return $testConstraints($constraint)
+	return [constraints::cset $constraint]
+	#	return $testConstraints($constraint)
     }
     # Check for boolean values
     if {[catch {expr {$value && $value}} msg]} {
 	return -code error $msg
     }
-    if {[limitConstraints] 
-	    && [lsearch -exact $Option(-constraints) $constraint] == -1} {
+    if {[limitConstraints] && \
+	    [lsearch -exact $Option(-constraints) $constraint] == -1} {
 	set value 0
     }
-    set testConstraints($constraint) $value
+    constraints::cset $constraint $value
+    #    set testConstraints($constraint) $value
 }
 
 # tcltest::interpreter --
@@ -969,34 +1005,6 @@
 
 #####################################################################
 
-# tcltest::AddToSkippedBecause --
-#
-#	Increments the variable used to track how many tests were
-#       skipped because of a particular constraint.
-#
-# Arguments:
-#	constraint     The name of the constraint to be modified
-#
-# Results:
-#	Modifies tcltest::skippedBecause; sets the variable to 1 if
-#       didn't previously exist - otherwise, it just increments it.
-#
-# Side effects:
-#	None.
-
-proc tcltest::AddToSkippedBecause { constraint {value 1}} {
-    # add the constraint to the list of constraints that kept tests
-    # from running
-    variable skippedBecause
-
-    if {[info exists skippedBecause($constraint)]} {
-	incr skippedBecause($constraint) $value
-    } else {
-	set skippedBecause($constraint) $value
-    }
-    return
-}
-
 # tcltest::PrintError --
 #
 #	Prints errors to tcltest::errorChannel and then flushes that
@@ -1058,274 +1066,7 @@
     return
 }
 
-# tcltest::SafeFetch --
-#
-#	 The following trace procedure makes it so that we can safely
-#        refer to non-existent members of the testConstraints array
-#        without causing an error.  Instead, reading a non-existent
-#        member will return 0. This is necessary because tests are
-#        allowed to use constraint "X" without ensuring that
-#        testConstraints("X") is defined.
-#
-# Arguments:
-#	n1 - name of the array (testConstraints)
-#       n2 - array key value (constraint name)
-#       op - operation performed on testConstraints (generally r)
-#
-# Results:
-#	none
-#
-# Side effects:
-#	sets testConstraints($n2) to 0 if it's referenced but never
-#       before used
-
-proc tcltest::SafeFetch {n1 n2 op} {
-    variable testConstraints
-    DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
-    if {[string equal {} $n2]} {return}
-    if {![info exists testConstraints($n2)]} {
-	if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
-	    testConstraint $n2 0
-	}
-    }
-}
-
-# tcltest::ConstraintInitializer --
-#
-#	Get or set a script that when evaluated in the tcltest namespace
-#	will return a boolean value with which to initialize the
-#	associated constraint.
-#
-# Arguments:
-#	constraint - name of the constraint initialized by the script
-#	script - the initializer script
-#
-# Results
-#	boolean value of the constraint - enabled or disabled
-#
-# Side effects:
-#	Constraint is initialized for future reference by [test]
-proc tcltest::ConstraintInitializer {constraint {script ""}} {
-    variable ConstraintInitializer
-    DebugPuts 3 "entering ConstraintInitializer $constraint $script"
-    if {[llength [info level 0]] == 2} {
-	return $ConstraintInitializer($constraint)
-    }
-    # Check for boolean values
-    if {![info complete $script]} {
-	return -code error "ConstraintInitializer must be complete script"
-    }
-    set ConstraintInitializer($constraint) $script
-}
-
-# tcltest::InitConstraints --
-#
-# Call all registered constraint initializers to force initialization
-# of all known constraints.
-# See the tcltest man page for the list of built-in constraints defined
-# in this procedure.
-#
-# Arguments:
-#	none
-#
-# Results:
-#	The testConstraints array is reset to have an index for each
-#	built-in test constraint.
-#
-# Side Effects:
-#       None.
-#
-
-proc tcltest::InitConstraints {} {
-    variable ConstraintInitializer
-    initConstraintsHook
-    foreach constraint [array names ConstraintInitializer] {
-	testConstraint $constraint
-    }
-}
-
-proc tcltest::DefineConstraintInitializers {} {
-    ConstraintInitializer singleTestInterp {singleProcess}
-
-    # All the 'pc' constraints are here for backward compatibility and
-    # are not documented.  They have been replaced with equivalent 'win'
-    # constraints.
-
-    ConstraintInitializer unixOnly \
-	    {string equal $::tcl_platform(platform) unix}
-    ConstraintInitializer macOnly \
-	    {string equal $::tcl_platform(platform) macintosh}
-    ConstraintInitializer pcOnly \
-	    {string equal $::tcl_platform(platform) windows}
-    ConstraintInitializer winOnly \
-	    {string equal $::tcl_platform(platform) windows}
-
-    ConstraintInitializer unix {testConstraint unixOnly}
-    ConstraintInitializer mac {testConstraint macOnly}
-    ConstraintInitializer pc {testConstraint pcOnly}
-    ConstraintInitializer win {testConstraint winOnly}
-
-    ConstraintInitializer unixOrPc \
-	    {expr {[testConstraint unix] || [testConstraint pc]}}
-    ConstraintInitializer macOrPc \
-	    {expr {[testConstraint mac] || [testConstraint pc]}}
-    ConstraintInitializer unixOrWin \
-	    {expr {[testConstraint unix] || [testConstraint win]}}
-    ConstraintInitializer macOrWin \
-	    {expr {[testConstraint mac] || [testConstraint win]}}
-    ConstraintInitializer macOrUnix \
-	    {expr {[testConstraint mac] || [testConstraint unix]}}
-
-    ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
-    ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
-    ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
-
-    # The following Constraints switches are used to mark tests that
-    # should work, but have been temporarily disabled on certain
-    # platforms because they don't and we haven't gotten around to
-    # fixing the underlying problem.
-
-    ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
-    ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
-    ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
-    ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
-
-    # The following Constraints switches are used to mark tests that
-    # crash on certain platforms, so that they can be reactivated again
-    # when the underlying problem is fixed.
-
-    ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
-    ConstraintInitializer winCrash {expr {![testConstraint win]}}
-    ConstraintInitializer macCrash {expr {![testConstraint mac]}}
-    ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
-
-    # Skip empty tests
 
-    ConstraintInitializer emptyTest {format 0}
-
-    # By default, tests that expose known bugs are skipped.
-
-    ConstraintInitializer knownBug {format 0}
-
-    # By default, non-portable tests are skipped.
-
-    ConstraintInitializer nonPortable {format 0}
-
-    # Some tests require user interaction.
-
-    ConstraintInitializer userInteraction {format 0}
-
-    # Some tests must be skipped if the interpreter is not in
-    # interactive mode
-
-    ConstraintInitializer interactive \
-	    {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
-
-    # Some tests can only be run if the installation came from a CD
-    # image instead of a web image.  Some tests must be skipped if you
-    # are running as root on Unix.  Other tests can only be run if you
-    # are running as root on Unix.
-
-    ConstraintInitializer root {expr \
-	    {[string equal unix $::tcl_platform(platform)]
-	    && ([string equal root $::tcl_platform(user)]
-		|| [string equal "" $::tcl_platform(user)])}}
-    ConstraintInitializer notRoot {expr {![testConstraint root]}}
-
-    # Set nonBlockFiles constraint: 1 means this platform supports
-    # setting files into nonblocking mode.
-
-    ConstraintInitializer nonBlockFiles {
-	    set code [expr {[catch {set f [open defs r]}] 
-		    || [catch {fconfigure $f -blocking off}]}]
-	    catch {close $f}
-	    set code
-    }
-
-    # Set asyncPipeClose constraint: 1 means this platform supports
-    # async flush and async close on a pipe.
-    #
-    # Test for SCO Unix - cannot run async flushing tests because a
-    # potential problem with select is apparently interfering.
-    # (Mark Diekhans).
-
-    ConstraintInitializer asyncPipeClose {expr {
-	    !([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
-    # to the "e" format of floating-point numbers.
-
-    ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
-
-    # Test to see if execed commands such as cat, echo, rm and so forth
-    # are present on this machine.
-
-    ConstraintInitializer unixExecs {
-	set code 1
-        if {[string equal macintosh $::tcl_platform(platform)]} {
-	    set code 0
-        }
-        if {[string equal windows $::tcl_platform(platform)]} {
-	    if {[catch {
-	        set file _tcl_test_remove_me.txt
-	        makeFile {hello} $file
-	    }]} {
-	        set code 0
-	    } elseif {
-	        [catch {exec cat $file}] ||
-	        [catch {exec echo hello}] ||
-	        [catch {exec sh -c echo hello}] ||
-	        [catch {exec wc $file}] ||
-	        [catch {exec sleep 1}] ||
-	        [catch {exec echo abc > $file}] ||
-	        [catch {exec chmod 644 $file}] ||
-	        [catch {exec rm $file}] ||
-	        [llength [auto_execok mkdir]] == 0 ||
-	        [llength [auto_execok fgrep]] == 0 ||
-	        [llength [auto_execok grep]] == 0 ||
-	        [llength [auto_execok ps]] == 0
-	    } {
-	        set code 0
-	    }
-	    removeFile $file
-        }
-	set code
-    }
-
-    ConstraintInitializer stdio {
-	set code 0
-	if {![catch {set f [open "|[list [interpreter]]" w]}]} {
-	    if {![catch {puts $f exit}]} {
-		if {![catch {close $f}]} {
-		    set code 1
-		}
-	    }
-	}
-	set code
-    }
-
-    # Deliberately call socket with the wrong number of arguments.  The
-    # error message you get will indicate whether sockets are available
-    # on this system.
-
-    ConstraintInitializer socket {
-	catch {socket} msg
-	string compare $msg "sockets are not available on this system"
-    }
-
-    # Check for internationalization
-    ConstraintInitializer hasIsoLocale {
-	if {[llength [info commands testlocale]] == 0} {
-	    set code 0
-	} else {
-	    set code [string length [SetIso8859_1_Locale]]
-	    RestoreLocale
-	}
-	set code
-    }
-
-}
 #####################################################################
 
 # Usage and command line arguments processing.
@@ -1483,7 +1224,6 @@
 
 proc tcltest::ProcessCmdLineArgs {} {
     variable originalEnv
-    variable testConstraints
 
     # The "argv" var doesn't exist in some cases, so use {}.
     if {![info exists ::argv]} {
@@ -1511,7 +1251,7 @@
     DebugPuts    2 "Original environment (tcltest::originalEnv):"
     DebugPArray  2 originalEnv
     DebugPuts    2 "Constraints:"
-    DebugPArray  2 testConstraints
+#    DebugPArray  2 testConstraints
 }
 
 #####################################################################
@@ -1836,6 +1576,8 @@
     global tcl_platform
     variable testLevel
     variable coreModTime
+    variable Option
+
     DebugPuts 3 "test $name $args"
     DebugDo 1 {
 	variable TestNames
@@ -1933,8 +1675,17 @@
 	}
     }
 
+    # Save the body in either pass or fail cases.
+    testresults::newresult $name ;# This must be called before the first 'result'.
+    testresults::result testBody $name $body
+    testresults::result testDescription $name $description
+    testresults::result testMatch $name $match
+
     if {[Skipped $name $constraints]} {
 	incr testLevel -1
+	uplevel [list [testcallback] $name]
+#	if { ! $Option(-dump) } {
+#	}
 	return
     }
 
@@ -1952,12 +1703,6 @@
     # Only run the test body if the setup was successful
     if {!$setupFailure} {
 
-	# Verbose notification of $body start
-	if {[IsVerbose start]} {
-	    puts [outputChannel] "---- $name start"
-	    flush [outputChannel]
-	}
-
 	set command [list [namespace origin RunTest] $name $body]
 	if {[info exists output] || [info exists errorOutput]} {
 	    set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
@@ -1988,22 +1733,14 @@
 	    } 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 {[string length $msg] > 0} {
-		    append coreMsg "\nError:\
-			Problem renaming core file: $msg"
-		}
+		append coreMsg [CoreMsg $name]
 	    }
 	}
     }
 
+
     # check if the return code matched the expected return code
     set codeFailure 0
     if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
@@ -2048,51 +1785,45 @@
 	set scriptFailure 1
     }
 
+
     # if we didn't experience any failures, then we passed
     variable numTests
     if {!($setupFailure || $cleanupFailure || $coreFailure
 	    || $outputFailure || $errorFailure || $codeFailure
 	    || $scriptFailure)} {
 	if {$testLevel == 1} {
-	    incr numTests(Passed)
-	    if {[IsVerbose pass]} {
-		puts [outputChannel] "++++ $name PASSED"
-	    }
+	    testresults::incrtotal Passed
 	}
+	testresults::result testPassFail $name pass
 	incr testLevel -1
+	uplevel [list [testcallback] $name]
+#	if { ! $Option(-dump) } {
+#	}
 	return
     }
-
+    testresults::result testPassFail $name fail
     # We know the test failed, tally it...
     if {$testLevel == 1} {
-	incr numTests(Failed)
+	testresults::incrtotal Failed
     }
 
     # ... then report according to the type of failure
     variable currentFailure true
-    if {![IsVerbose body]} {
-	set body ""
-    }	
-    puts [outputChannel] "\n==== $name\
-	    [string trim $description] FAILED"
-    if {[string length $body]} {
-	puts [outputChannel] "==== Contents of test case:"
-	puts [outputChannel] $body
-    }
+
     if {$setupFailure} {
-	puts [outputChannel] "---- Test setup\
-		failed:\n$setupMsg"
+	testresults::result testSetup $name $setupMsg
     }
     if {$scriptFailure} {
+	testresults::result testScriptFailure $name 1
 	if {$scriptCompare} {
-	    puts [outputChannel] "---- Error testing result: $scriptMatch"
+	    testresults::result testScriptMatch $name $scriptMatch
 	} else {
-	    puts [outputChannel] "---- Result was:\n$actualAnswer"
-	    puts [outputChannel] "---- Result should have been\
-		    ($match matching):\n$result"
+	    testresults::result testActualAnswer $name $actualAnswer
+	    testresults::result testResult $name $result
 	}
     }
     if {$codeFailure} {
+	testresults::result testCodeFailure $name 1
 	switch -- $returnCode {
 	    0 { set msg "Test completed normally" }
 	    1 { set msg "Test generated error" }
@@ -2101,47 +1832,158 @@
 	    4 { set msg "Test generated continue exception" }
 	    default { set msg "Test generated exception" }
 	}
-	puts [outputChannel] "---- $msg; Return code was: $returnCode"
-	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"
-	    }
+	testresults::result testMsg $name $msg
+	testresults::result testReturnCode $name $returnCode
+	testresults::result testExpectedReturnCodes $name $returnCodes
+	if {[info exists ::errorInfo]} {
+	    testresults::result testErrorInfo $name $::errorInfo
+	    testresults::result testErrorCode $name $::errorCode
 	}
     }
     if {$outputFailure} {
+	testresults::result testOutputFailure $name 1
 	if {$outputCompare} {
-	    puts [outputChannel] "---- Error testing output: $outputMatch"
+	    testresults::result testOutputMatch $name $outputMatch
 	} else {
-	    puts [outputChannel] "---- Output was:\n$outData"
-	    puts [outputChannel] "---- Output should have been\
-		    ($match matching):\n$output"
+	    testresults::result testOutputData $name $outData
+	    testresults::result testOutput $name $output
 	}
     }
     if {$errorFailure} {
+	testresults::result testErrorFailure $name 1
 	if {$errorCompare} {
-	    puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
+	    testresults::result testErrorMatch $name $errorMatch
 	} else {
-	    puts [outputChannel] "---- Error output was:\n$errData"
-	    puts [outputChannel] "---- Error output should have\
-		    been ($match matching):\n$errorOutput"
+	    testresults::result testErrorData $errData
+	    testresults::result testErrorOutput $errOutput
 	}
     }
     if {$cleanupFailure} {
-	puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
+	testresults::result testCleanupMsg $name $cleanupMsg
     }
+
     if {$coreFailure} {
-	puts [outputChannel] "---- Core file produced while running\
-		test!  $coreMsg"
+	testresults::result testCore $name $coreMsg
     }
-    puts [outputChannel] "==== $name FAILED\n"
 
     incr testLevel -1
+    uplevel [list [testcallback] $name]
+
     return
 }
 
+proc tcltest::printcallback {name} {
+
+    if { [testresults::results exists $name testSkipped] } {
+	if { [IsVerbose skip] } {
+	    puts [outputChannel] \
+		"++++ $name SKIPPED: [testresults::results get $name testSkipped]"
+	}
+	testresults::results clear $name
+	return
+    }
+
+    # Don't run for some other reason - it doesn't match or something
+    # like that.
+    if { [testresults::results exists $name testDontRun] } {
+	testresults::results clear $name
+	return
+    }
+
+    # Verbose notification of $body start
+    if {[IsVerbose start]} {
+	puts [outputChannel] "---- $name start"
+	flush [outputChannel]
+    }
+
+#    puts "DOING $name"
+#    foreach v $::tcltest::testresults::testAPIvars {
+
+#	if { [ array exists ::tcltest::testresults::$v ] } {
+#	    puts "VAR ::tcltest::testresults::$v"
+#	    parray ::tcltest::testresults::$v
+#	}
+#    }
+
+#    puts -nonewline "test $name :"
+#    parray ::tcltest::testresults::testPassFail
+    if { [testresults::results get $name testPassFail] == "pass" } {
+	if {[IsVerbose pass]} {
+	    puts [outputChannel] "++++ $name PASSED"
+	}
+	testresults::results clear $name
+	return
+    }
+
+    if {![IsVerbose body]} {
+	set body ""
+    } else {
+	set body [testresults::results get $name testBody]
+    }
+    set description [testresults::results get $name testDescription]
+    puts [outputChannel] "\n==== $name\
+	    [string trim $description] FAILED"
+    if {[string length $body]} {
+	puts [outputChannel] "==== Contents of test case:"
+	puts [outputChannel] $body
+    }
+    if { [testresults::results exists $name testSetup] } {
+	puts [outputChannel] "---- Test setup\
+		failed:\n[testresults::results get $name testSetup]"
+    }
+    if { [testresults::results exists $name testScriptFailure] } {
+	if { [testresults::results exists $name testScriptMatch] } {
+	    puts [outputChannel] "---- Error testing result: [testresults::results get $name testScriptMatch]"
+	} else {
+	    puts [outputChannel] "---- Result was:\n[testresults::results get $name testActualAnswer]"
+	    puts [outputChannel] "---- Result should have been\
+		    ([testresults::results get $name testMatch] matching):\n[testresults::results get $name testResult]"
+	}
+    }
+    if { [testresults::results exists $name testCodeFailure] } {
+	puts [outputChannel] "---- [testresults::results get $name testMsg]; Return code was: [testresults::results get $name testReturnCode]"
+	puts [outputChannel] "---- Return code should have been\
+		one of: [testresults::results get $name testExpectedReturnCodes]"
+	if {[IsVerbose error]} {
+	    if { [testresults::results exists $name testErrorInfo] } {
+		puts [outputChannel] "---- errorInfo: [testresults::results get $name testErrorInfo]"
+		puts [outputChannel] "---- errorCode: [testresults::results get $name testErrorCode]"
+	    }
+	}
+    }
+
+    if { [testresults::results exists $name testOutputFailure] } {
+	if { [testresults::results exists $name testOutputMatch] } {
+	    puts [outputChannel] "---- Error testing output: [testresults::results get $name testOutputMatch]"
+	} else {
+	    puts [outputChannel] "---- Output was:\n[testresults::results get $name testOutputData]"
+	    puts [outputChannel] "---- Output should have been\
+		    ([testresults::results get $name testMatch] matching):\n$[testresults::results get $name testOutput]"
+	}
+    }
+
+    if { [testresults::results exists $name testErrorFailure] } {
+	if { [testresults::results exists $name testErrorMatch] } {
+	    puts [outputChannel] "---- Error testing errorOutput: [testresults::results exists $name testErrorMatch]"
+	} else {
+	    puts [outputChannel] "---- Error output was:\n[testresults::results exists $name testErrorData]"
+	    puts [outputChannel] "---- Error output should have\
+		    been ([testresults::results exists $name testMatch] matching):\n[testresults::results exists $name testErrorOutput]"
+	}
+    }
+
+    if { [testresults::results exists $name testCleanupMsg] } {
+	puts [outputChannel] "---- Test cleanup failed:\n[testresults::results get $name testCleanupMsg]"
+    }
+    if { [testresults::results exists $name testCore] } {
+	puts [outputChannel] "---- Core file produced while running\
+		test![testresults::results get $name testCore]"
+    }
+
+    puts [outputChannel] "==== $name FAILED\n"
+    testresults::results clear $name
+}
+
 # Skipped --
 #
 # Given a test name and it constraints, returns a boolean indicating
@@ -2152,18 +1994,18 @@
 proc tcltest::Skipped {name constraints} {
     variable testLevel
     variable numTests
-    variable testConstraints
 
     if {$testLevel == 1} {
-	incr numTests(Total)
+	testresults::incrtotal Total
     }
     # skip the test if it's name matches an element of skip
     foreach pattern [skip] {
 	if {[string match $pattern $name]} {
 	    if {$testLevel == 1} {
-		incr numTests(Skipped)
-		DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
+		testresults::incrtotal Skipped
+		DebugDo 1 {constraints::incrskippedbecause userSpecifiedSkip}
 	    }
+	    testresults::result testDontRun $name 1
 	    return 1
 	}
     }
@@ -2177,61 +2019,37 @@
     }
     if {!$ok} {
 	if {$testLevel == 1} {
-	    incr numTests(Skipped)
-	    DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
+	    testresults::incrtotal Skipped
+	    DebugDo 1 {constraints::incrskippedbecause userSpecifiedNonMatch}
 	}
+	testresults::result testDontRun $name 1
 	return 1
     }
     if {[string equal {} $constraints]} {
 	# If we're limited to the listed constraints and there aren't
 	# any listed, then we shouldn't run the test.
 	if {[limitConstraints]} {
-	    AddToSkippedBecause userSpecifiedLimitConstraint
+	    constraints::incrskippedbecause userSpecifiedLimitConstraint
 	    if {$testLevel == 1} {
-		incr numTests(Skipped)
+		testresults::incrtotal Skipped
 	    }
+	    testresults::result testDontRun $name 1
 	    return 1
 	}
     } else {
 	# "constraints" argument exists;
 	# make sure that the constraints are satisfied.
 
-	set doTest 0
-	if {[string match {*[$\[]*} $constraints] != 0} {
-	    # full expression, e.g. {$foo > [info tclversion]}
-	    catch {set doTest [uplevel #0 expr $constraints]}
-	} elseif {[regexp {[^.a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
-	    # something like {a || b} should be turned into
-	    # $testConstraints(a) || $testConstraints(b).
-	    regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
-	    catch {set doTest [eval expr $c]}
-	} elseif {![catch {llength $constraints}]} {
-	    # just simple constraints such as {unixOnly fonts}.
-	    set doTest 1
-	    foreach constraint $constraints {
-		if {(![info exists testConstraints($constraint)]) \
-			|| (!$testConstraints($constraint))} {
-		    set doTest 0
-
-		    # store the constraint that kept the test from
-		    # running
-		    set constraints $constraint
-		    break
-		}
-	    }
-	}
-	
-	if {$doTest == 0} {
-	    if {[IsVerbose skip]} {
-		puts [outputChannel] "++++ $name SKIPPED: $constraints"
-	    }
+	set retval [constraints::checktest $name constraints]
+	if {$retval == 1} {
+	    tcltest::testresults::result testSkipped $name $constraints
 
 	    if {$testLevel == 1} {
-		incr numTests(Skipped)
-		AddToSkippedBecause $constraints
+		tcltest::testresults::incrtotal Skipped
+		constraints::incrskippedbecause $constraints
 	    }
-	    return 1
 	}
+	return $retval
     }
     return 0
 }
@@ -2299,16 +2117,16 @@
 proc tcltest::cleanupTests {{calledFromAllFile 0}} {
     variable filesMade
     variable filesExisted
-    variable createdNewFiles
     variable testSingleFile
     variable numTests
-    variable numTestFiles
+    #variable numTestFiles
     variable failFiles
     variable skippedBecause
     variable currentFailure
     variable originalEnv
     variable originalTclPlatform
     variable coreModTime
+    variable Option
 
     FillFilesExisted
     set testFileName [file tail [info script]]
@@ -2341,60 +2159,15 @@
 	}
 	set filesExisted $currentFiles
 	if {[llength $newFiles] > 0} {
-	    set createdNewFiles($testFileName) $newFiles
+	    files::setcreated $testFileName $newFiles
 	}
     }
 
     if {$calledFromAllFile || $testSingleFile} {
-
-	# print stats
-
-	puts -nonewline [outputChannel] "$testFileName:"
-	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
-	    puts -nonewline [outputChannel] \
-		    "\t$index\t$numTests($index)"
-	}
-	puts [outputChannel] ""
-
-	# print number test files sourced
-	# print names of files that ran tests which failed
-
-	if {$calledFromAllFile} {
-	    puts [outputChannel] \
-		    "Sourced $numTestFiles Test Files."
-	    set numTestFiles 0
-	    if {[llength $failFiles] > 0} {
-		puts [outputChannel] \
-			"Files with failing tests: $failFiles"
-		set failFiles {}
-	    }
-	}
-
-	# if any tests were skipped, print the constraints that kept
-	# them from running.
-
-	set constraintList [array names skippedBecause]
-	if {[llength $constraintList] > 0} {
-	    puts [outputChannel] \
-		    "Number of tests skipped for each constraint:"
-	    foreach constraint [lsort $constraintList] {
-		puts [outputChannel] \
-			"\t$skippedBecause($constraint)\t$constraint"
-		unset skippedBecause($constraint)
-	    }
-	}
-
-	# report the names of test files in createdNewFiles, and reset
-	# the array to be empty.
-
-	set testFilesThatTurded [lsort [array names createdNewFiles]]
-	if {[llength $testFilesThatTurded] > 0} {
-	    puts [outputChannel] "Warning: files left behind:"
-	    foreach testFile $testFilesThatTurded {
-		puts [outputChannel] \
-			"\t$testFile:\t$createdNewFiles($testFile)"
-		unset createdNewFiles($testFile)
-	    }
+	if { $Option(-dump) } {
+	    tcltest::DumpStats
+	} else {
+	    uplevel [printstatscallback] $calledFromAllFile
 	}
 
 	# reset filesMade, filesExisted, and numTests
@@ -2409,100 +2182,24 @@
 	# loop is running, which is the real issue.
 	# Actually, this doesn't belong here at all.  A package
 	# really has no business [exit]-ing an application.
-	if {![catch {package present Tk}] && ![testConstraint interactive]} {
-	    exit
-	}
+	#if {![catch {package present Tk}] && ![testConstraint interactive]} {
+	#    exit
+	#}
     } else {
 
 	# if we're deferring stat-reporting until all files are sourced,
 	# then add current file to failFile list if any tests in this
 	# file failed
 
-	incr numTestFiles
-	if {$currentFailure \
-		&& ([lsearch -exact $failFiles $testFileName] == -1)} {
-	    lappend failFiles $testFileName
+	if { $currentFailure } {
+	    files::failed $testFileName
 	}
 	set currentFailure false
 
-	# restore the environment to the state it was in before this package
-	# was loaded
-
-	set newEnv {}
-	set changedEnv {}
-	set removedEnv {}
-	foreach index [array names ::env] {
-	    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)
-	    }
-	}
-	if {[llength $newEnv] > 0} {
-	    puts [outputChannel] \
-		    "env array elements created:\t$newEnv"
-	}
-	if {[llength $changedEnv] > 0} {
-	    puts [outputChannel] \
-		    "env array elements changed:\t$changedEnv"
-	}
-	if {[llength $removedEnv] > 0} {
-	    puts [outputChannel] \
-		    "env array elements removed:\t$removedEnv"
-	}
-
-	set changedTclPlatform {}
-	foreach index [array names originalTclPlatform] {
-	    if {$::tcl_platform($index) \
-		    != $originalTclPlatform($index)} {
-		lappend changedTclPlatform $index
-		set ::tcl_platform($index) $originalTclPlatform($index)
-	    }
-	}
-	if {[llength $changedTclPlatform] > 0} {
-	    puts [outputChannel] "tcl_platform array elements\
-		    changed:\t$changedTclPlatform"
-	}
-
-	if {[file exists [file join [workingDirectory] core]]} {
-	    if {[preserveCore] > 1} {
-		puts "rename core file (> 1)"
-		puts [outputChannel] "produced core file! \
-			Moving file to: \
-			[file join [temporaryDirectory] core-$testFileName]"
-		catch {file rename -force \
-			[file join [workingDirectory] core] \
-			[file join [temporaryDirectory] core-$testFileName]
-		} msg
-		if {[string length $msg] > 0} {
-		    PrintError "Problem renaming file: $msg"
-		}
-	    } else {
-		# Print a message 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]]} {
-			puts [outputChannel] "A core file was created!"
-		    }
-		} else {
-		    puts [outputChannel] "A core file was created!"
-		}
-	    }
-	}
+	files::add $testFileName
+	uplevel 1 [restorecallback]
     }
+    # FIXME These don't really belong here any more.
     flush [outputChannel]
     flush [errorChannel]
     return
@@ -2645,7 +2342,7 @@
 
 proc tcltest::runAllTests { {shell ""} } {
     variable testSingleFile
-    variable numTestFiles
+    #variable numTestFiles
     variable numTests
     variable failFiles
 
@@ -2703,7 +2400,8 @@
 	flush [outputChannel]
 
 	if {[singleProcess]} {
-	    incr numTestFiles
+	    files::add $file
+	    # incr numTestFiles
 	    uplevel 1 [list ::source $file]
 	} else {
 	    # Pass along our configuration to the child processes.
@@ -2711,47 +2409,33 @@
 	    # needs to read and process output of children.
 	    set childargv [list]
 	    foreach opt [Configure] {
-		if {[string equal $opt -outfile]} {continue}
-		lappend childargv $opt [Configure $opt]
+		if { ! [string equal $opt -outfile] && ! [string equal $opt -dump] } {
+		    lappend childargv $opt [Configure $opt]
+		}
 	    }
+	    lappend childargv -dump 1
 	    set cmd [linsert $childargv 0 | $shell $file]
+
 	    if {[catch {
-		incr numTestFiles
+		files::add $file
 		set pipeFd [open $cmd "r"]
+		# ----------------
 		while {[gets $pipeFd line] >= 0} {
-		    if {[regexp [join {
-			    {^([^:]+):\t}
-			    {Total\t([0-9]+)\t}
-			    {Passed\t([0-9]+)\t}
-			    {Skipped\t([0-9]+)\t}
-			    {Failed\t([0-9]+)}
-			    } ""] $line null testFile \
-			    Total Passed Skipped Failed]} {
-			foreach index {Total Passed Skipped Failed} {
-			    incr numTests($index) [set $index]
-			}
-			if {$Failed > 0} {
-			    lappend failFiles $testFile
-			}
-		    } elseif {[regexp [join {
-			    {^Number of tests skipped }
-			    {for each constraint:}
-			    {|^\t(\d+)\t(.+)$}
-			    } ""] $line match skipped constraint]} {
-			if {[string match \t* $match]} {
-			    AddToSkippedBecause $constraint $skipped
-			}
-		    } else {
-			puts [outputChannel] $line
-		    }
+		    puts [outputChannel] $line
 		}
 		close $pipeFd
+
 	    } msg]} {
 		puts [outputChannel] "Test file error: $msg"
 		# append the name of the test to a list to be reported
 		# later
 		lappend testFileFailures $file
 	    }
+	    # FIXME - we probably ought to do something more elaborate
+	    # with this.
+	    catch {
+		source [file join [ResultsFile]]
+	    }
 	}
     }
 
@@ -2770,9 +2454,9 @@
 	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] ""
@@ -3253,12 +2937,7 @@
 # Initialize the constraints and set up command line arguments
 namespace eval tcltest {
     # Define initializers for all the built-in contraint definitions
-    DefineConstraintInitializers
-
-    # Set up the constraints in the testConstraints array to be lazily
-    # initialized by a registered initializer, or by "false" if no
-    # initializer is registered.
-    trace variable testConstraints r [namespace code SafeFetch]
+    constraints::DefineConstraintInitializers
 
     # Only initialize constraints at package load time if an
     # [initConstraintsHook] has been pre-defined.  This is only
@@ -3267,7 +2946,7 @@
     # straight away, without all this "hook" nonsense.
     if {[string equal [namespace current] \
 	    [namespace qualifiers [namespace which initConstraintsHook]]]} {
-	InitConstraints
+	#InitConstraints
     } else {
 	proc initConstraintsHook {} {}
     }
