--- tcl-8.4.13/tcl8.4.13/library/tcltest/constraints.tcl.tst	2007-02-16 09:45:27.000000000 +0100
+++ tcl-8.4.13/tcl8.4.13/library/tcltest/constraints.tcl	2004-10-30 04:52:16.000000000 +0200
@@ -0,0 +1,451 @@
+# constraints.tcl --
+
+# Interface for constraints.
+
+# $Id$
+
+# tcltest::constraints::exists --
+#
+#	Check to see whether a given constraint exists.
+#
+# Arguments:
+#	constraint.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	1 if constraint exists, 0 if it does not.
+
+proc tcltest::constraints::exists {constraint} {
+    return [info exists vars::$constraint]
+}
+
+
+# tcltest::constraints::cset --
+#
+#	Set constraint or check its value.
+#
+# Arguments:
+#	constraint - constraint to set or check.
+#	value - optional argument.
+#
+# Side Effects:
+#	Sets constraint if value is given.
+#
+# Results:
+#	None.
+
+proc tcltest::constraints::cset {args} {
+    set constraint [lindex $args 0]
+    if { [llength $args] == 1 } {
+	if { ! [info exists vars::$constraint] } {
+	    return 0
+	} else {
+	    return [set vars::$constraint]
+	}
+    } else {
+	set vars::$constraint [lindex $args 1]
+    }
+}
+
+
+proc tcltest::constraints::initconst {constraint} {
+    set retval 0
+    if { [catch {
+	set retval [tcltest::testConstraint $constraint \
+			[eval [ConstraintInitializer $constraint]]]
+    } err] } {
+	puts "DIO CAGNOLINO $err"
+    }
+
+    return $retval
+}
+
+
+# tcltest::constraints::getlist --
+#
+#	Gets a list of all constraints.
+#
+# Arguments:
+#	None.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	List of all constraints.
+
+proc tcltest::constraints::getlist {} {
+    set reslist {}
+    foreach v [info vars vars::*] {
+	lappend reslist [namespace tail $v]
+    }
+    return $reslist
+}
+
+
+# tcltest::constraints::incrskippedbecause --
+#
+#	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::constraints::incrskippedbecause { constraint {value 1} } {
+    variable skippedBecause
+
+    if {[info exists skippedBecause($constraint)]} {
+	incr skippedBecause($constraint) $value
+    } else {
+	set skippedBecause($constraint) $value
+    }
+    return
+}
+
+
+# tcltest::constraints::skippedlist --
+#
+#	Get list of all constraints that kept tests from running..
+#
+# Arguments:
+#	None.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	A list of constraints.
+
+proc tcltest::constraints::skippedlist {} {
+    variable skippedBecause
+    return [array names skippedBecause]
+}
+
+
+# tcltest::constraints::getskipped --
+#
+#	Gets number of tests skipped because of a particular
+#	constraint.
+#
+# Arguments:
+#	constraint - constraint.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	Integer number of tests skipped.
+
+proc tcltest::constraints::getskipped { constraint } {
+    variable skippedBecause
+    return $skippedBecause($constraint)
+}
+
+
+# tcltest::constraints::clearskippedlist --
+#
+#	Clears the list of skipped constraints.
+#
+# Arguments:
+#	None.
+#
+# Side Effects:
+#	Resets the list of skipped constraints.
+#
+# Results:
+#	None.
+
+proc tcltest::constraints::clearskippedlist {} {
+    variable skippedBecause
+    array unset skippedBecause
+    array set skippedBecause {}
+}
+
+
+# tcltest::constraints::checktest --
+#
+#	Check test to see if the constraints are satisfied.  Note that
+#	'constraintsvar' has to use upvar to reference the real
+#	variable, because these checks actually change the
+#	constraints.  Something to fix in the future if possible.
+#
+# Arguments:
+#	name - test name.
+#	constraintsvar - constraint to check against.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	None.
+
+proc tcltest::constraints::checktest {name constraintsvar} {
+    upvar $constraintsvar constraints
+    set doTest 0
+
+    # I don't agree with this.  I think that a constraint should
+    # either be an artificial construct such as unix || pc, OR it
+    # should be a plain old Tcl expression, possibly to be evaluated
+    # in its own namespace.  FIXME at some later date when we can toss
+    # this stuff out. -davidw
+
+    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 {$&} c
+	catch {set doTest [namespace eval vars [list expr $c]]}
+    } elseif {![catch {llength $constraints}]} {
+	# just simple constraints such as {unixOnly fonts}.
+	set doTest 1
+	foreach constraint $constraints {
+	    if { ! [cset $constraint] } {
+		set doTest 0
+		# store the constraint that kept the test from
+		# running
+		set constraints $constraint
+		break
+	    }
+	}
+    }
+
+    # Return the opposite of doTest
+    return [expr {$doTest ? 0 : 1}]
+}
+
+
+# tcltest::constraints::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::constraints::ConstraintInitializer {constraint {script ""}} {
+    variable ConstraintInitializer
+
+    # Check for boolean values
+    if {![info complete $script]} {
+	return -code error "ConstraintInitializer must be complete script"
+    }
+    set retval [namespace eval ::tcltest $script]
+    cset $constraint $retval
+
+}
+
+# tcltest::constraints::DefineConstraintInitializers --
+#
+#	Set up the initial constraints (such as unix, pc, and so on).
+#
+# Arguments:
+#	None.
+#
+# Side Effects:
+#	Creates a number of constraints.
+#
+# Results:
+#	None.
+
+proc tcltest::constraints::DefineConstraintInitializers {} {
+    ConstraintInitializer singleTestInterp {tcltest::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 {tcltest::testConstraint unixOnly}
+    ConstraintInitializer mac {tcltest::testConstraint macOnly}
+    ConstraintInitializer pc {tcltest::testConstraint pcOnly}
+    ConstraintInitializer win {tcltest::testConstraint winOnly}
+
+    ConstraintInitializer unixOrPc \
+	    {expr {[tcltest::testConstraint unix] || [tcltest::testConstraint pc]}}
+    ConstraintInitializer macOrPc \
+	    {expr {[tcltest::testConstraint mac] || [tcltest::testConstraint pc]}}
+    ConstraintInitializer unixOrWin \
+	    {expr {[tcltest::testConstraint unix] || [tcltest::testConstraint win]}}
+    ConstraintInitializer macOrWin \
+	    {expr {[tcltest::testConstraint mac] || [tcltest::testConstraint win]}}
+    ConstraintInitializer macOrUnix \
+	    {expr {[tcltest::testConstraint mac] || [tcltest::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 {![tcltest::testConstraint pc]}}
+    ConstraintInitializer tempNotWin {expr {![tcltest::testConstraint win]}}
+    ConstraintInitializer tempNotMac {expr {![tcltest::testConstraint mac]}}
+    ConstraintInitializer tempNotUnix {expr {![tcltest::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 {![tcltest::testConstraint pc]}}
+    ConstraintInitializer winCrash {expr {![tcltest::testConstraint win]}}
+    ConstraintInitializer macCrash {expr {![tcltest::testConstraint mac]}}
+    ConstraintInitializer unixCrash {expr {![tcltest::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 {![tcltest::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
+    }
+
+}
--- tcl-8.4.13/tcl8.4.13/library/tcltest/testresults.tcl.tst	2007-02-16 09:45:41.000000000 +0100
+++ tcl-8.4.13/tcl8.4.13/library/tcltest/testresults.tcl	2004-10-30 04:52:27.000000000 +0200
@@ -0,0 +1,230 @@
+namespace eval tcltest::testresults {
+
+    # The 'TestNames' variable doesn't work for us because it's an
+    # array.
+    set testNames [list]
+
+    array set ResID {}
+
+    # Since this is a pretty long list, we keep it in one place
+    # here, and loop through it when needed.
+    set testAPIvars {
+	testDescription
+	testPassFail
+	testBody
+	testDontRun
+
+	testSkipped
+
+	testSetup
+	testScriptFailure
+	testScriptMatch
+	testActualAnswer
+	testMatch
+	testResult
+	testMsg
+	testReturnCode
+	testExpectedReturnCodes
+	testErrorInfo
+	testErrorCode
+
+	testCodeFailure
+	testOutputFailure
+	testErrorFailure
+
+	testOutputMatch
+	testOutData
+	testOutput
+
+	testErrorMatch
+	testErrorData
+	testErrorOutput
+
+	testCleanupMsg
+	testCore
+    }
+    foreach var $testAPIvars {
+	array set $var {}
+    }
+
+    # initialize numTests array to keep track of the number of tests
+    # that pass, fail, and are skipped.
+    array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
+}
+
+# tcltest::testresults::newresult --
+#
+#	Start recording information about a new result.  Must be
+#	called prior to tcltest::result.
+#
+# Arguments:
+#	name - test name.
+#
+# Side Effects:
+#	Sets the ResID variable, which acts as a unique ID for each
+#	result.
+#
+# Results:
+#	None.
+
+proc tcltest::testresults::newresult {name} {
+    variable testNames
+    variable ResID
+
+    lappend testNames $name
+    set ResID($name) [expr {[llength $testNames] - 1}]
+}
+
+# tcltest::testresults::result --
+#
+#	Store information about a particular test.
+#
+# Arguments:
+#	var - variable name to set.
+#	name - test name.
+#	data - data to store.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	None.
+
+proc tcltest::testresults::result {var name data} {
+    variable testAPIvars
+    variable ResID
+
+    foreach tstvar $testAPIvars {
+	variable $tstvar
+    }
+
+    set [set var]($ResID($name)) $data
+}
+
+
+# tcltest::testresults::results --
+#
+#	Takes a subcommand as the first argument, and based on that,
+#	returns some information about test results.
+#
+# Arguments:
+#	cmd - one of tests vars, exists, get or clear
+#	args - additional arguments, such as the test name, the
+#	variable to query, and so on.  See the tcltest man page.
+#
+# Side Effects:
+#	The 'clear' command eliminates the results of the specified test.
+#
+# Results:
+#	tests - returns information on all tests.
+#	vars - returns the variables available for a given test.
+#	exists - reports whether a variable exists for a given test.
+#	get - fetches the information about a variable for a given test.
+#	clear - clears all information about a given test, and removes
+#	it from the list of tests.
+
+proc tcltest::testresults::results {cmd args} {
+    variable testNames
+    variable testAPIvars
+    variable numTests
+
+    foreach var $testAPIvars {
+	variable $var
+    }
+
+    if { $cmd == "tests" } {
+	return $testNames
+    }
+
+    set res {}
+    set testname [lindex $args 0]
+    # Fetch the list index of the test name.
+    set id [lsearch -all $testNames $testname]
+    # If there was more than one result, either one is specified or we
+    # error out.
+
+    if { [llength $id] > 1 } {
+	set num [lindex $args 1]
+	if { ![string is int $num] || $num == "" } {
+	    error "Multiple tests correspond - please specify one: 0-[expr [llength $id] - 1]"
+	}
+	set id [lindex $id $num]
+    } elseif {$id < 0} {
+	error "No $testname test recorded"
+    }
+
+    switch -exact $cmd {
+	vars {
+	    foreach var $testAPIvars {
+		if { [info exists [set var]($id)] } {
+		    lappend res $var
+		}
+	    }
+	    return $res
+	}
+
+	exists {
+	    set varname [lindex $args end]
+	    return [info exists [set varname]($id)]
+	}
+
+	get {
+	    set varname [lindex $args end]
+	    return [set [set varname]($id)]
+	}
+
+	clear {
+	    foreach var $testAPIvars {
+		if { [info exists [set var]($id)] } {
+		    unset [set var]($id)
+		}
+	    }
+	    set testNames [lreplace $testNames $id $id]
+	    return
+	}
+
+	default {
+	    error "bad option \"$cmd\": must be tests, vars, exists, get, or clear"
+	}
+    }
+}
+
+
+# tcltest::testresults::tally --
+#
+#	Return information about the number of tests that have passed,
+#	failed, been skipped, and the total.
+#
+# Arguments:
+#	type - type of tally to return: passed, failed, skipped, total.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	A number corresponding to the type of information sought.
+
+proc tcltest::testresults::tally {type} {
+    variable numTests
+    return $numTests([string totitle $type])
+}
+
+
+# tcltest::testresults::incrtotal --
+#
+#	Increase the count for the number of tests that have either
+#	Passed, Failed, Skipped, or the Total number of tests.
+#
+# Arguments:
+#	None.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	None.
+
+proc tcltest::testresults::incrtotal {type {num 1}} {
+    variable numTests
+    incr numTests($type) $num
+}
\ No newline at end of file
--- tcl-8.4.13/tcl8.4.13/library/tcltest/files.tcl.tst	2007-02-16 09:45:36.000000000 +0100
+++ tcl-8.4.13/tcl8.4.13/library/tcltest/files.tcl	2004-10-30 04:52:17.000000000 +0200
@@ -0,0 +1,126 @@
+# files.tcl -- manage test suite files.
+
+# $Id$
+
+namespace eval tcltest::files {
+    array set failFiles {}
+}
+
+# tcltest::files::add --
+#
+#	Add a file to the list of files that have been processed by
+#	the test suite.
+#
+# Arguments:
+#	filename - name of file to add to list.
+#
+# Side Effects:
+#	File name list includes filename.
+#
+# Results:
+#	None.
+
+proc tcltest::files::add {filename} {
+    variable filelist
+    lappend filelist $filename
+}
+
+# tcltest::files::getlist --
+#
+#	Get list of files the test suite has been through.
+#
+# Arguments:
+#	None.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	List of files.
+
+proc tcltest::files::getlist {} {
+    variable filelist
+    return $filelist
+}
+
+
+# tcltest::files::failed --
+#
+#	Indicate that a particular file has failed tests.
+#
+# Arguments:
+#	filename.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	None.
+
+proc tcltest::files::failed {filename} {
+    variable failFiles
+    set failFiles($filename) 1
+}
+
+
+# tcltest::files::setcreated --
+#
+#	This is used to indicate that the particular test file has
+#	created some files.
+#
+# Arguments:
+#	None.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	None.
+
+proc tcltest::files::setcreated { filename {files ""} } {
+    variable createdNewFiles
+    if { [llength $files] == 0 } {
+	return $createdNewFiles($filename)
+    }
+    set createdNewFiles($filename) $files
+}
+
+
+# tcltest::files::allcreated --
+#
+#	Returns a list of all the files that have been created.
+#
+# Arguments:
+#	None.
+#
+# Side Effects:
+#	None.
+#
+# Results:
+#	List of files.
+
+proc tcltest::files::allcreated {} {
+    variable createdNewFiles
+    return [array names createdNewFiles]
+}
+
+
+# tcltest::files::clearcreated --
+#
+#	Clear list of created files.
+#
+# Arguments:
+#	None.
+#
+# Side Effects:
+#	List of created files is set to empty list.
+#
+# Results:
+#	None.
+
+proc tcltest::files::clearcreated {} {
+    variable createdNewFiles
+    array unset createdNewFiles
+    array set createdNewFiles {}
+}
+