Adding package tcltest; this replaces the original defs.tcl file

that was a part of the test suite.

2 files changed, 1248 insertions, 0 deletions

diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
new file mode 100644
index 0000000..f9e2d30
--- /dev/null
+++ b/library/tcltest/pkgIndex.tcl
@@ -0,0 +1,11 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script.  It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands.  When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg ::tcltest::removeDirectory ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory tcltest:grep}}}]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
new file mode 100644
index 0000000..3375718
--- /dev/null
+++ b/library/tcltest/tcltest.tcl
@@ -0,0 +1,1237 @@
+# tcltest.tcl --
+#
+#	This file contains support code for the Tcl test suite.  It defines the
+#       defines the ::tcltest namespace and finds and defines the output
+#       directory, constraints available, output and error channels, etc. used
+#       by Tcl tests.  See the README file for more details.
+#       
+#       This design was based on the original Tcl testing approach designed and
+#       initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. 
+#
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+# 
+# RCS: @(#) $Id: tcltest.tcl,v 1.1 1999/06/26 03:53:45 jenn Exp $
+
+package provide tcltest 1.0
+
+# Ensure that we have a minimal auto_path so we don't pick up extra junk.
+set auto_path [list [info library]]
+
+# create the "tcltest" namespace for all testing variables and procedures
+
+namespace eval tcltest {
+
+    # Export the public tcltest procs
+    set procList [list test cleanupTests dotests saveState restoreState \
+	    normalizeMsg makeFile removeFile makeDirectory removeDirectory \
+	    viewFile grep bytestring set_iso8859_1_locale restore_locale \
+	    safeFetch threadReap]
+    foreach proc $procList {
+	namespace export $proc
+    }
+
+    # ::tcltest::verbose defaults to "b"
+
+    variable verbose "b"
+
+    # match defaults to the empty list
+
+    variable match {}
+
+    # skip defaults to the empty list
+
+    variable skip {}
+
+    # output goes to stdout by default
+
+    variable outputChannel stdout
+
+    # errors go to stderr by default
+
+    variable errorChannel stderr
+
+    # debug output doesn't get printed by default; default debugLevel (1) spits
+    # up only the tets that were skipped because they didn't match or were 
+    # specifically skipped.  A debugLevel of 2 would spit up the tcltest
+    # variables and flags provided; a debugLevel of 3 causes some additional
+    # output regarding operations of the test harness.  The tcltest package
+    # currently implements only up to debugLevel 3.
+
+    variable debug false
+    variable debugLevel 1
+
+    # Count the number of files tested (0 if all.tcl wasn't called).
+    # The all.tcl file will set testSingleFile to false, so stats will
+    # not be printed until all.tcl calls the cleanupTests proc.
+    # 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.
+
+    variable numTestFiles 0
+    variable testSingleFile true
+    variable currentFailure false
+    variable failFiles {}
+
+    # Tests should remove all files they create.  The test suite will
+    # check the current working dir for files created by the tests.
+    # ::tcltest::filesMade keeps track of such files created using the
+    # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
+    # ::tcltest::filesExisted stores the names of pre-existing files.
+
+    variable filesMade {}
+    variable filesExisted {}
+
+    # ::tcltest::numTests will store test files as indices and the list
+    # of files (that should not have been) left behind by the test files.
+
+    array set ::tcltest::createdNewFiles {}
+
+    # initialize ::tcltest::numTests array to keep track fo the number of
+    # tests that pass, fial, and are skipped.
+
+    array set ::tcltest::numTests [list Total 0 Passed 0 Skipped 0 Failed 0] 
+
+    # initialize ::tcltest::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 ::tcltest::skippedBecause {}
+
+    # initialize the ::tcltest::testConstraints array to keep track of valid
+    # predefined constraints (see the explanation for the ::tcltest::initConstraints
+    # proc for more details).
+
+    array set ::tcltest::testConstraints {}
+
+    # tests that use thread need to know which is the main thread
+
+    variable mainThread 1
+    if {[info commands testthread] != {}} {
+	set mainThread [testthread names]
+    }
+
+    # save the original environement so that it can be restored later
+    
+    array set ::tcltest::originalEnv [array get ::env]
+
+    # TclPro has other variables that need to be set, including the locations
+    # of various directories.
+    
+    # Set ::tcltest::workingDirectory to [pwd]. The default output directory
+    # for Tcl tests is the working directory.
+
+    variable workingDirectory [pwd]
+    variable temporaryDirectory $workingDirectory
+
+    # Tests should not rely on the current working directory.
+    # Files that are part of the test suite should be accessed relative to 
+    # ::tcltest::testsDirectory.
+
+    variable testsDirectory [pwd]
+
+    variable saveState {}
+
+    # Internationalization support
+    if {![info exists ::tcltest::isoLocale]} {
+	variable isoLocale fr
+        switch $tcl_platform(platform) {
+	    "unix" {
+
+		# Try some 'known' values for some platforms:
+
+		switch -exact -- $tcl_platform(os) {
+		    "FreeBSD" {
+			set ::tcltest::isoLocale fr_FR.ISO_8859-1
+		    }
+		    HP-UX {
+			set ::tcltest::isoLocale fr_FR.iso88591
+		    }
+		    Linux -
+		    IRIX {
+			set ::tcltest::isoLocale fr
+		    }
+		    default {
+
+			# Works on SunOS 4 and Solaris, and maybe others...
+			# define it to something else on your system
+			#if you want to test those.
+
+			set ::tcltest::isoLocale iso_8859_1
+		    }
+		}
+	    }
+	    "windows" {
+		set ::tcltest::isoLocale French
+	    }
+	}
+    }
+
+    # Set the location of the execuatble
+    variable tcltest [info nameofexecutable]
+
+    # If there is no "memory" command (because memory debugging isn't
+    # enabled), generate a dummy command that does nothing.
+    
+    if {[info commands memory] == {}} {
+	namespace eval :: {
+	    proc memory args {}
+	}
+    }
+}   
+
+
+proc ::tcltest::AddToSkippedBecause { constraint } {
+    # add the constraint to the list of constraints the kept tests
+    # from running
+
+    if {[info exists ::tcltest::skippedBecause($constraint)]} {
+	incr ::tcltest::skippedBecause($constraint)
+    } else {
+	set ::tcltest::skippedBecause($constraint) 1
+    }
+    return
+}
+
+# ::tcltest::PrintError --
+#
+#	Prints errors to ::tcltest::errorChannel and then flushes that
+#       channel.  
+#
+# Arguments:
+#	errorMsg     String containing the error to be printed
+#
+
+proc ::tcltest::PrintError {errorMsg} {
+    set InitialMessage "Error:  "
+    set InitialMsgLen  [string length $InitialMessage]
+    puts -nonewline $::tcltest::errorChannel $InitialMessage
+    set beginningIndex [string wordend $errorMsg 72]
+    puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]
+    set endingIndex [string length $errorMsg]
+    while {$beginningIndex < $endingIndex} {
+	set newEndingIndex [string wordend $errorMsg \
+		[expr {$beginningIndex + 72}]]
+	puts -nonewline $::tcltest::errorChannel \
+		[string repeat " " $InitialMsgLen]  
+	puts $::tcltest::errorChannel [string trim \
+		[string range $errorMsg $beginningIndex $newEndingIndex]]
+	set beginningIndex $newEndingIndex
+    }
+    return
+}
+
+proc ::tcltest::initConstraintsHook {} {}
+
+# ::tcltest::initConstraints --
+#
+# Check Constraintsuration information that will determine which tests
+# to run.  To do this, create an array ::tcltest::testConstraints.  Each
+# element has a 0 or 1 value.  If the element is "true" then tests
+# with that constraint will be run, otherwise tests with that constraint
+# will be skipped.  See the README file for the list of built-in
+# constraints defined in this procedure.
+#
+# Arguments:
+#	none
+#
+# Results:
+#	The ::tcltest::testConstraints array is reset to have an index for
+#	each built-in test constraint.
+
+proc ::tcltest::initConstraints {} {
+    global tcl_platform tcl_interactive tk_version
+
+    catch {unset ::tcltest::testConstraints}
+
+    # The following trace procedure makes it so that we can safely refer to
+    # non-existent members of the ::tcltest::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 ::tcltest::testConstraints("X") is defined.
+
+    trace variable ::tcltest::testConstraints r ::tcltest::safeFetch
+
+    proc ::tcltest::safeFetch {n1 n2 op} {
+	if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} {
+	    set ::tcltest::testConstraints($n2) 0
+	}
+    }
+
+    ::tcltest::initConstraintsHook
+
+    set ::tcltest::testConstraints(unixOnly) \
+	    [string equal $tcl_platform(platform) "unix"]
+    set ::tcltest::testConstraints(macOnly) \
+	    [string equal $tcl_platform(platform) "macintosh"]
+    set ::tcltest::testConstraints(pcOnly) \
+	    [string equal $tcl_platform(platform) "windows"]
+
+    set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly)
+    set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly)
+    set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly)
+
+    set ::tcltest::testConstraints(unixOrPc) \
+	    [expr {$::tcltest::testConstraints(unix) || $::tcltest::testConstraints(pc)}]
+    set ::tcltest::testConstraints(macOrPc) \
+	    [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(pc)}]
+    set ::tcltest::testConstraints(macOrUnix) \
+	    [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(unix)}]
+
+    set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) "Windows NT"]
+    set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) "Windows 95"]
+    set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) "Win32s"]
+
+    # 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.
+
+    set ::tcltest::testConstraints(tempNotPc) [expr {!$::tcltest::testConstraints(pc)}]
+    set ::tcltest::testConstraints(tempNotMac) [expr {!$::tcltest::testConstraints(mac)}]
+    set ::tcltest::testConstraints(tempNotUnix) [expr {!$::tcltest::testConstraints(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.
+
+    set ::tcltest::testConstraints(pcCrash) [expr {!$::tcltest::testConstraints(pc)}]
+    set ::tcltest::testConstraints(win32sCrash) [expr {!$::tcltest::testConstraints(win32s)}]
+    set ::tcltest::testConstraints(macCrash) [expr {!$::tcltest::testConstraints(mac)}]
+    set ::tcltest::testConstraints(unixCrash) [expr {!$::tcltest::testConstraints(unix)}]
+
+    # Skip empty tests
+
+    set ::tcltest::testConstraints(emptyTest) 0
+
+    # By default, tests that expose known bugs are skipped.
+
+    set ::tcltest::testConstraints(knownBug) 0
+
+    # By default, non-portable tests are skipped.
+
+    set ::tcltest::testConstraints(nonPortable) 0
+
+    # Some tests require user interaction.
+
+    set ::tcltest::testConstraints(userInteraction) 0
+
+    # Some tests must be skipped if the interpreter is not in interactive mode
+
+    set ::tcltest::testConstraints(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.
+
+    set ::tcltest::testConstraints(root) 0
+    set ::tcltest::testConstraints(notRoot) 1
+    set user {}
+    if {[string equal $tcl_platform(platform) "unix"]} {
+	catch {set user [exec whoami]}
+	if {[string equal $user ""]} {
+	    catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
+	}
+	if {([string equal $user "root"]) || ([string equal $user ""])} {
+	    set ::tcltest::testConstraints(root) 1
+	    set ::tcltest::testConstraints(notRoot) 0
+	}
+    }
+
+    # Set nonBlockFiles constraint: 1 means this platform supports
+    # setting files into nonblocking mode.
+
+    if {[catch {set f [open defs r]}]} {
+	set ::tcltest::testConstraints(nonBlockFiles) 1
+    } else {
+	if {[catch {fconfigure $f -blocking off}] == 0} {
+	    set ::tcltest::testConstraints(nonBlockFiles) 1
+	} else {
+	    set ::tcltest::testConstraints(nonBlockFiles) 0
+	}
+	close $f
+    }
+
+    # 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).
+
+    if {[string equal $tcl_platform(platform) "unix"]} {
+	if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
+	    set ::tcltest::testConstraints(asyncPipeClose) 0
+	} else {
+	    set ::tcltest::testConstraints(asyncPipeClose) 1
+	}
+    } else {
+	set ::tcltest::testConstraints(asyncPipeClose) 1
+    }
+
+    # Test to see if we have a broken version of sprintf with respect
+    # to the "e" format of floating-point numbers.
+
+    set ::tcltest::testConstraints(eformat) 1
+    if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
+	set ::tcltest::testConstraints(eformat) 0
+    }
+
+    # Test to see if execed commands such as cat, echo, rm and so forth are
+    # present on this machine.
+
+    set ::tcltest::testConstraints(unixExecs) 1
+    if {[string equal $tcl_platform(platform) "macintosh"]} {
+	set ::tcltest::testConstraints(unixExecs) 0
+    }
+    if {($::tcltest::testConstraints(unixExecs) == 1) && \
+	    ([string equal $tcl_platform(platform) "windows"])} {
+	if {[catch {exec cat defs}] == 1} {
+	    set ::tcltest::testConstraints(unixExecs) 0
+	}
+	if {($::tcltest::testConstraints(unixExecs) == 1) && \
+		([catch {exec echo hello}] == 1)} {
+	    set ::tcltest::testConstraints(unixExecs) 0
+	}
+	if {($::tcltest::testConstraints(unixExecs) == 1) && \
+		([catch {exec sh -c echo hello}] == 1)} {
+	    set ::tcltest::testConstraints(unixExecs) 0
+	}
+	if {($::tcltest::testConstraints(unixExecs) == 1) && \
+		([catch {exec wc defs}] == 1)} {
+	    set ::tcltest::testConstraints(unixExecs) 0
+	}
+	if {$::tcltest::testConstraints(unixExecs) == 1} {
+	    exec echo hello > removeMe
+	    if {[catch {exec rm removeMe}] == 1} {
+		set ::tcltest::testConstraints(unixExecs) 0
+	    }
+	}
+	if {($::tcltest::testConstraints(unixExecs) == 1) && \
+		([catch {exec sleep 1}] == 1)} {
+	    set ::tcltest::testConstraints(unixExecs) 0
+	}
+	if {($::tcltest::testConstraints(unixExecs) == 1) && \
+		([catch {exec fgrep unixExecs defs}] == 1)} {
+	    set ::tcltest::testConstraints(unixExecs) 0
+	}
+	if {($::tcltest::testConstraints(unixExecs) == 1) && \
+		([catch {exec ps}] == 1)} {
+	    set ::tcltest::testConstraints(unixExecs) 0
+	}
+	if {($::tcltest::testConstraints(unixExecs) == 1) && \
+		([catch {exec echo abc > removeMe}] == 0) && \
+		([catch {exec chmod 644 removeMe}] == 1) && \
+		([catch {exec rm removeMe}] == 0)} {
+	    set ::tcltest::testConstraints(unixExecs) 0
+	} else {
+	    catch {exec rm -f removeMe}
+	}
+	if {($::tcltest::testConstraints(unixExecs) == 1) && \
+		([catch {exec mkdir removeMe}] == 1)} {
+	    set ::tcltest::testConstraints(unixExecs) 0
+	} else {
+	    catch {exec rm -r removeMe}
+	}
+    }
+
+    # Locate tcltest executable
+
+    if {![info exists tk_version]} {
+	set tcltest [info nameofexecutable]
+
+	if {$tcltest == "{}"} {
+	    set tcltest {}
+	}
+    }
+
+    set ::tcltest::testConstraints(stdio) 0
+    catch {
+	catch {file delete -force tmp}
+	set f [open tmp w]
+	puts $f {
+	    exit
+	}
+	close $f
+
+	set f [open "|[list $tcltest tmp]" r]
+	close $f
+	
+	set ::tcltest::testConstraints(stdio) 1
+    }
+    catch {file delete -force tmp}
+
+    # Deliberately call socket with the wrong number of arguments.  The error
+    # message you get will indicate whether sockets are available on this system.
+
+    catch {socket} msg
+    set ::tcltest::testConstraints(socket) \
+	    [expr {$msg != "sockets are not available on this system"}]
+    
+    # Check for internationalization
+
+    if {[info commands testlocale] == ""} {
+	# No testlocale command, no tests...
+	set ::tcltest::testConstraints(hasIsoLocale) 0
+    } else {
+	set ::tcltest::testConstraints(hasIsoLocale) \
+	    [string length [::tcltest::set_iso8859_1_locale]]
+	::tcltest::restore_locale
+    }
+}   
+
+proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
+
+proc ::tcltest::processCmdLineArgsHook {flag} {}
+
+# ::tcltest::processCmdLineArgs --
+#
+#	Use command line args to set the verbose, skip, and
+#	match, outputChannel, errorChannel, debug, and temporaryDirectory
+#       variables.   
+#
+#       This procedure must be run after constraints are initialized, because
+#       some constraints can be overridden.
+#
+# Arguments:
+#	none
+#
+# Results:
+#	Sets the above-named variables in the tcltest namespace.
+
+proc ::tcltest::processCmdLineArgs {} {
+    global argv
+
+    # The "argv" var doesn't exist in some cases, so use {}.
+
+    if {(![info exists argv]) || ([llength $argv] < 2)} {
+	set flagArray {}
+    } else {
+	set flagArray $argv
+    }
+    
+    # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
+    # Note that -verbose cannot be abbreviated to -v in wish because it
+    # conflicts with the wish option -visual.
+
+    if {[catch {array set flag $flagArray}]} {
+	::tcltest::PrintError "odd number of arguments specified on command line: \ 
+		$argv"
+	exit
+    }
+    
+    lappend defaultFlags {-verbose -match -skip -constraints \
+	    -outfile -errfile -debug -tmpdir}
+    lappend defaultFlags [ ::tcltest::processCmdLineArgsAddFlagsHook ]
+
+    foreach arg $defaultFlags {
+	set abbrev [string range $arg 0 1]
+	if {([info exists flag($abbrev)]) && \
+		([lsearch -exact $flagArray $arg] < \
+		[lsearch -exact $flagArray $abbrev])} {
+	    set flag($arg) $flag($abbrev)
+	}
+    }
+
+    # Set ::tcltest::verbose to the arg of the -verbose flag, if given
+
+    if {[info exists flag(-verbose)]} {
+	set ::tcltest::verbose $flag(-verbose)
+    }
+
+    # Set ::tcltest::match to the arg of the -match flag, if given.  
+
+    if {[info exists flag(-match)]} {
+	set ::tcltest::match $flag(-match)
+    } 
+
+    # Set ::tcltest::skip to the arg of the -skip flag, if given
+
+    if {[info exists flag(-skip)]} {
+	set ::tcltest::skip $flag(-skip)
+    }
+
+    # Use the -constraints flag, if given, to turn on constraints that are
+    # turned off by default: userInteractive knownBug nonPortable.  This
+    # code fragment must be run after constraints are initialized.
+
+    if {[info exists flag(-constraints)]} {
+	foreach elt $flag(-constraints) {
+	    set ::tcltest::testConstraints($elt) 1
+	}
+    }
+
+    # If an alternate error or output files are specified, change the
+    # default channels.
+
+    if {[info exists flag(-outfile)]} {
+	set tmp $flag(-outfile)
+	if {[string compare [file pathtype $tmp] "absolute"] != 0} {
+	    set tmp [file join $::tcltest::temporaryDirectory $tmp]
+	}
+	set ::tcltest::outputChannel [open $tmp w]
+    } 
+
+    if {[info exists flag(-errfile)]} {
+	set tmp $flag(-errfile)
+	if {[string compare [file pathtype $tmp] "absolute"] != 0} {
+	    set tmp [file join $::tcltest::temporaryDirectory $tmp]
+	}
+	set ::tcltest::errorChannel [open $tmp w]
+    }
+
+    # If the user specifies debug testing, print out extra information during
+    # the run.
+    if {[info exists flag(-debug)]} {
+	set ::tcltest::debug true
+	if {$flag(-debug) != {}} {
+	    set ::tcltest::debugLevel $flag(-debug)
+	}
+    }
+
+    # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if
+    # given.
+    # 
+    # If the path is relative, make it absolute.  If the file exists but
+    # is not a dir, then return an error.
+    #
+    # If ::tcltest::temporaryDirectory does not already exist, create it.
+    # If you cannot create it, then return an error.
+
+    set tmpDirError ""
+    if {[info exists flag(-tmpdir)]} {
+	set ::tcltest::temporaryDirectory $flag(-tmpdir)
+
+	if {[string compare \
+		[file pathtype $::tcltest::temporaryDirectory] \
+		"absolute"] != 0} { 
+	    set ::tcltest::temporaryDirectory [file join [pwd] \
+		    $::tcltest::temporaryDirectory] 
+	}
+	set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
+    }
+    if {[file exists $::tcltest::temporaryDirectory]} {
+	if {![file isdir $::tcltest::temporaryDirectory]} { 
+	    ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
+		    is not a directory"
+	    exit
+	} elseif {![file writable $::tcltest::temporaryDirectory]} {
+	    ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
+		    is not writeable" 
+	    exit
+	} elseif {![file readable $::tcltest::temporaryDirectory]} {
+	    ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
+		    is not readable" 
+	    exit
+	}
+    } else {
+	file mkdir $::tcltest::temporaryDirectory
+    }
+
+    # Save the names of files that already exist in
+    # the output directory.
+    foreach file [glob -nocomplain \
+	    [file join $::tcltest::temporaryDirectory *]] {
+	lappend ::tcltest::filesExisted [file tail $file]
+    }
+
+    ::tcltest::processCmdLineArgsHook [array get flag]
+
+    # Spit out everything you know if ::tcltest::debug is set.
+    if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} {
+	puts "Flags passed into tcltest:"
+	parray flag
+	puts "::tcltest::debug = $::tcltest::debug"
+	puts "::tcltest::debugLevel = $::tcltest::debugLevel"
+	puts "::tcltest::testsDirectory = $::tcltest::testsDirectory"
+	puts "::tcltest::workingDirectory = $::tcltest::workingDirectory"
+	puts "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
+	puts "::tcltest::outputChannel = $::tcltest::outputChannel"
+	puts "::tcltest::errorChannel = $::tcltest::errorChannel"
+	puts "Original environment (::tcltest::originalEnv):"
+	parray ::tcltest::originalEnv
+    }
+}
+
+# ::tcltest::cleanupTests --
+#
+# Remove files and dirs created using the makeFile and makeDirectory
+# commands since the last time this proc was invoked.
+#
+# Print the names of the files created without the makeFile command
+# since the tests were invoked.
+#
+# Print the number tests (total, passed, failed, and skipped) since the
+# tests were invoked.
+# 
+# Restore original environment (as reported by special variable env).
+
+proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
+
+    set testFileName [file tail [info script]]
+
+    # Call the cleanup hook
+    ::tcltest::cleanupTestsHook 
+
+    # Remove files and directories created by the :tcltest::makeFile and
+    # ::tcltest::makeDirectory procedures.
+    # Record the names of files in ::tcltest::workingDirectory that were not
+    # pre-existing, and associate them with the test file that created them.
+
+    if {!$calledFromAllFile} {
+	foreach file $::tcltest::filesMade {
+	    if {[file exists $file]} {
+		catch {file delete -force $file}
+	    }
+	}
+	set currentFiles {}
+	foreach file [glob -nocomplain \
+		[file join $::tcltest::temporaryDirectory *]] {
+	    lappend currentFiles [file tail $file]
+	}
+	set newFiles {}
+	foreach file $currentFiles {
+	    if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
+		lappend newFiles $file
+	    }
+	}
+	set ::tcltest::filesExisted $currentFiles
+	if {[llength $newFiles] > 0} {
+	    set ::tcltest::createdNewFiles($testFileName) $newFiles
+	}
+    }
+
+    if {$calledFromAllFile || $::tcltest::testSingleFile} {
+
+	# print stats
+
+	puts -nonewline $::tcltest::outputChannel "$testFileName:"
+	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+	    puts -nonewline $::tcltest::outputChannel \
+		    "\t$index\t$::tcltest::numTests($index)"
+	}
+	puts $::tcltest::outputChannel ""
+
+	# print number test files sourced
+	# print names of files that ran tests which failed
+
+	if {$calledFromAllFile} {
+	    puts $::tcltest::outputChannel \
+		    "Sourced $::tcltest::numTestFiles Test Files."
+	    set ::tcltest::numTestFiles 0
+	    if {[llength $::tcltest::failFiles] > 0} {
+		puts $::tcltest::outputChannel \
+			"Files with failing tests: $::tcltest::failFiles"
+		set ::tcltest::failFiles {}
+	    }
+	}
+
+	# if any tests were skipped, print the constraints that kept them
+	# from running.
+
+	set constraintList [array names ::tcltest::skippedBecause]
+	if {[llength $constraintList] > 0} {
+	    puts $::tcltest::outputChannel \
+		    "Number of tests skipped for each constraint:"
+	    foreach constraint [lsort $constraintList] {
+		puts $::tcltest::outputChannel \
+			"\t$::tcltest::skippedBecause($constraint)\t$constraint"
+		unset ::tcltest::skippedBecause($constraint)
+	    }
+	}
+
+	# report the names of test files in ::tcltest::createdNewFiles, and
+	# reset the array to be empty.
+
+	set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
+	if {[llength $testFilesThatTurded] > 0} {
+	    puts $::tcltest::outputChannel "Warning: files left behind:"
+	    foreach testFile $testFilesThatTurded {
+		puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
+		unset ::tcltest::createdNewFiles($testFile)
+	    }
+	}
+
+	# reset filesMade, filesExisted, and numTests
+
+	set ::tcltest::filesMade {}
+	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+	    set ::tcltest::numTests($index) 0
+	}
+
+	# 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 ::tcltest::originalEnv($index)]} {
+		lappend newEnv $index
+		unset env($index)
+	    } else {
+		if {$env($index) != $::tcltest::originalEnv($index)} {
+		    lappend changedEnv $index
+		    set env($index) $::tcltest::originalEnv($index)
+		}
+	    }
+	}
+	foreach index [array names ::tcltest::originalEnv] {
+	    if {![info exists ::env($index)]} {
+		lappend removedEnv $index
+		set env($index) $::tcltest::originalEnv($index)
+	    }
+	}
+	if {[llength $newEnv] > 0} {
+	    puts $::tcltest::outputChannel \
+		    "\t\tenv array elements created:\t$newEnv"
+	}
+	if {[llength $changedEnv] > 0} {
+	    puts $::tcltest::outputChannel \
+		    "\t\tenv array elements changed:\t$changedEnv"
+	}
+	if {[llength $removedEnv] > 0} {
+	    puts $::tcltest::outputChannel \
+		    "\t\tenv array elements removed:\t$removedEnv"
+	}
+
+	# exit only if running Tk in non-interactive mode
+
+	global tk_version tcl_interactive
+	if {[info exists tk_version] && !$tcl_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 ::tcltest::numTestFiles
+	if {($::tcltest::currentFailure) && \
+		([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} {
+	    lappend ::tcltest::failFiles $testFileName
+	}
+	set ::tcltest::currentFailure false
+    }
+}
+
+proc ::tcltest::cleanupTestsHook {} {}
+
+# test --
+#
+# This procedure runs a test and prints an error message if the test fails.
+# If ::tcltest::verbose has been set, it also prints a message even if the
+# test succeeds.  The test will be skipped if it doesn't match the
+# ::tcltest::match variable, if it matches an element in
+# ::tcltest::skip, or if one of the elements of "constraints" turns
+# out not to be true.
+#
+# Arguments:
+# name -		Name of test, in the form foo-1.2.
+# description -		Short textual description of the test, to
+#			help humans understand what it does.
+# constraints -		A list of one or more keywords, each of
+#			which must be the name of an element in
+#			the array "::tcltest::testConstraints".  If any of these
+#			elements is zero, the test is skipped.
+#			This argument may be omitted.
+# script -		Script to run to carry out the test.  It must
+#			return a result that can be checked for
+#			correctness.
+# expectedAnswer -	Expected result from script.
+
+proc ::tcltest::test {name description script expectedAnswer args} {
+    incr ::tcltest::numTests(Total)
+
+    # skip the test if it's name matches an element of skip
+
+    foreach pattern $::tcltest::skip {
+	if {[string match $pattern $name]} {
+	    incr ::tcltest::numTests(Skipped)
+	    if {$::tcltest::debug} {
+		::tcltest::AddToSkippedBecause userSpecifiedSkip
+	    }
+	    return
+	}
+    }
+
+    # skip the test if it's name doesn't match any element of match
+
+    if {[llength $::tcltest::match] > 0} {
+	set ok 0
+	foreach pattern $::tcltest::match {
+	    if {[string match $pattern $name]} {
+		set ok 1
+		break
+	    }
+        }
+	if {!$ok} {
+	    incr ::tcltest::numTests(Skipped)
+	    if {$::tcltest::debug} {
+		::tcltest::AddToSkippedBecause userSpecifiedNonMatch
+	    }
+	    return
+	}
+    }
+    set i [llength $args]
+    if {$i == 0} {
+	set constraints {}
+    } elseif {$i == 1} {
+
+	# "constraints" argument exists;  shuffle arguments down, then
+	# make sure that the constraints are satisfied.
+
+	set constraints $script
+	set script $expectedAnswer
+	set expectedAnswer [lindex $args 0]
+	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 ]+} $constraints] != 0} {
+
+	    # something like {a || b} should be turned into 
+	    # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b).
+
+ 	    regsub -all {[.a-zA-Z0-9]+} $constraints \
+		    {$::tcltest::testConstraints(&)} c
+	    catch {set doTest [eval expr $c]}
+	} else {
+
+	    # just simple constraints such as {unixOnly fonts}.
+
+	    set doTest 1
+	    foreach constraint $constraints {
+		if {![info exists ::tcltest::testConstraints($constraint)]
+		|| !$::tcltest::testConstraints($constraint)} {
+		    set doTest 0
+
+		    # store the constraint that kept the test from running
+
+		    set constraints $constraint
+		    break
+		}
+	    }
+	}
+	if {$doTest == 0} {
+	    incr ::tcltest::numTests(Skipped)
+	    if {[string first s $::tcltest::verbose] != -1} {
+		puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
+	    }
+
+	    ::tcltest::AddToSkippedBecause $constraints
+	    return	
+	}
+    } else {
+	error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
+    }   
+    memory tag $name
+    set code [catch {uplevel $script} actualAnswer]
+    if {([string compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} {
+	incr ::tcltest::numTests(Passed)
+	if {[string first p $::tcltest::verbose] != -1} {
+	    puts $::tcltest::outputChannel "++++ $name PASSED"
+	}
+    } else {
+	incr ::tcltest::numTests(Failed)
+	set ::tcltest::currentFailure true
+	if {[string first b $::tcltest::verbose] == -1} {
+	    set script ""
+	}
+	puts $::tcltest::outputChannel "\n==== $name $description FAILED"
+	if {$script != ""} {
+	    puts $::tcltest::outputChannel "==== Contents of test case:"
+	    puts $::tcltest::outputChannel $script
+	}
+	if {$code != 0} {
+	    if {$code == 1} {
+		puts $::tcltest::outputChannel "==== Test generated error:"
+		puts $::tcltest::outputChannel $actualAnswer
+	    } elseif {$code == 2} {
+		puts $::tcltest::outputChannel "==== Test generated return exception;  result was:"
+		puts $::tcltest::outputChannel $actualAnswer
+	    } elseif {$code == 3} {
+		puts $::tcltest::outputChannel "==== Test generated break exception"
+	    } elseif {$code == 4} {
+		puts $::tcltest::outputChannel "==== Test generated continue exception"
+	    } else {
+		puts $::tcltest::outputChannel "==== Test generated exception $code;  message was:"
+		puts $::tcltest::outputChannel $actualAnswer
+	    }
+	} else {
+	    puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
+	}
+	puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
+	puts $::tcltest::outputChannel "==== $name FAILED\n"
+    }
+}
+
+# ::tcltest::dotests --
+#
+#	takes two arguments--the name of the test file (such
+#	as "parse.test"), and a pattern selecting the tests you want to
+#	execute.  It sets ::tcltest::match to the second argument, calls
+#	"source" on the file specified in the first argument, and restores
+#	::tcltest::match to its pre-call value at the end.
+#
+# Arguments:
+#	file    name of tests file to source
+#	args    pattern selecting the tests you want to execute
+#
+# Results:
+#	none
+
+proc ::tcltest::dotests {file args} {
+    set savedTests $::tcltest::match
+    set ::tcltest::match $args
+    source $file
+    set ::tcltest::match $savedTests
+}
+
+proc ::tcltest::openfiles {} {
+    if {[catch {testchannel open} result]} {
+	return {}
+    }
+    return $result
+}
+
+proc ::tcltest::leakfiles {old} {
+    if {[catch {testchannel open} new]} {
+        return {}
+    }
+    set leak {}
+    foreach p $new {
+    	if {[lsearch $old $p] < 0} {
+	    lappend leak $p
+	}
+    }
+    return $leak
+}
+
+proc ::tcltest::saveState {} {
+    uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
+    if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} {
+	puts "::tcltest::saveState: $::tcltest::saveState"
+    }
+}
+
+proc ::tcltest::restoreState {} {
+    foreach p [info procs] {
+	if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
+		(![string equal ::tcltest::$p [namespace origin $p]])} {
+	    if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+		puts "::tcltest::restoreState: Removing proc $p"
+	    }
+	    rename $p {}
+	}
+    }
+    foreach p [uplevel #0 {info vars}] {
+	if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
+	    if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+		puts "::tcltest::restoreState: Removing variable $p"
+	    }
+	    uplevel #0 "unset $p"
+	}
+    }
+}
+
+proc ::tcltest::normalizeMsg {msg} {
+    regsub "\n$" [string tolower $msg] "" msg
+    regsub -all "\n\n" $msg "\n" msg
+    regsub -all "\n\}" $msg "\}" msg
+    return $msg
+}
+
+# makeFile --
+#
+# Create a new file with the name <name>, and write <contents> to it.
+#
+# If this file hasn't been created via makeFile since the last time
+# cleanupTests was called, add it to the $filesMade list, so it will
+# be removed by the next call to cleanupTests.
+#
+proc ::tcltest::makeFile {contents name} {
+    global tcl_platform
+    
+    if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+	puts "::tcltest::makeFile: putting $contents into $name"
+    }
+    set fd [open $name w]
+
+    # Doing the translation breaks TclPro Checker tests
+    # under Windows 
+    if {[string equal $tcl_platform(platform) "unix"]} {
+	fconfigure $fd -translation lf
+    }
+
+    if {[string equal \
+	    [string index $contents [expr {[string length $contents] - 1}]] \
+	    "\n"]} {
+	puts -nonewline $fd $contents
+    } else {
+	puts $fd $contents
+    }
+    close $fd
+
+    set fullName [file join [pwd] $name]
+    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
+	lappend ::tcltest::filesMade $fullName
+    }
+}
+
+proc ::tcltest::removeFile {name} {
+    if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+	puts "::tcltest::removeFile: removing $name"
+    }
+    file delete $name
+}
+
+# makeDirectory --
+#
+# Create a new dir with the name <name>.
+#
+# If this dir hasn't been created via makeDirectory since the last time
+# cleanupTests was called, add it to the $directoriesMade list, so it will
+# be removed by the next call to cleanupTests.
+#
+proc ::tcltest::makeDirectory {name} {
+    file mkdir $name
+
+    set fullName [file join [pwd] $name]
+    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
+	lappend ::tcltest::filesMade $fullName
+    }
+}
+
+proc ::tcltest::removeDirectory {name} {
+    file delete -force $name
+}
+
+proc ::tcltest::viewFile {name} {
+    global tcl_platform
+    if {([string equal $tcl_platform(platform) "macintosh"]) || \
+	    ($::tcltest::testConstraints(unixExecs) == 0)} {
+	set f [open $name]
+	set data [read -nonewline $f]
+	close $f
+	return $data
+    } else {
+	exec cat $name
+    }
+}
+
+# grep --
+#
+# Evaluate a given expression against each element of a list and return all
+# elements for which the expression evaluates to true.  For the purposes of
+# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the
+# value of the current element within the expression.  This is equivalent to
+# the perl grep command where CURRENT_ELEMENT would be the name for the special
+# variable $_.
+#
+# Examples of usage would be:
+#   set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers]
+#   set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings]
+#
+# Use of the CURRENT_ELEMENT keyword is optional.  If it is left out, it is
+# assumed to be the final argument to the expression provided.
+# 
+# Example:
+#   grep {regexp a} $someList   
+#
+proc ::tcltest:grep { expression searchList } {
+    foreach element $searchList {
+	if {[regsub -all CURRENT_ELEMENT $expression $element \
+		newExpression] == 0} { 
+	    set newExpression "$expression {$element}"
+	}
+	if {[eval $newExpression] == 1} {
+	    lappend returnList $element
+	}
+    }
+    if {[info exists returnList]} {
+	return $returnList
+    }
+    return
+}
+
+#
+# Construct a string that consists of the requested sequence of bytes,
+# as opposed to a string of properly formed UTF-8 characters.  
+# This allows the tester to 
+# 1. Create denormalized or improperly formed strings to pass to C procedures 
+#    that are supposed to accept strings with embedded NULL bytes.
+# 2. Confirm that a string result has a certain pattern of bytes, for instance
+#    to confirm that "\xe0\0" in a Tcl script is stored internally in 
+#    UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
+#
+# Generally, it's a bad idea to examine the bytes in a Tcl string or to
+# construct improperly formed strings in this manner, because it involves
+# exposing that Tcl uses UTF-8 internally.
+
+proc ::tcltest::bytestring {string} {
+    encoding convertfrom identity $string
+}
+
+#
+# Internationalization / ISO support procs     -- dl
+#
+proc ::tcltest::set_iso8859_1_locale {} {
+    if {[info commands testlocale] != ""} {
+	set ::tcltest::previousLocale [testlocale ctype]
+	testlocale ctype $::tcltest::isoLocale
+    }
+    return
+}
+
+proc ::tcltest::restore_locale {} {
+    if {[info commands testlocale] != ""} {
+	testlocale ctype $::tcltest::previousLocale
+    }
+    return
+}
+
+# threadReap --
+#
+#	Kill all threads except for the main thread.
+#	Do nothing if testthread is not defined.
+#
+# Arguments:
+#	none.
+#
+# Results:
+#	Returns the number of existing threads.
+proc ::tcltest::threadReap {} {
+    if {[info commands testthread] != {}} {
+	testthread errorproc ThreadNullError
+	while {[llength [testthread names]] > 1} {
+	    foreach tid [testthread names] {
+		if {$tid != $::tcltest::mainThread} {
+		    catch {testthread send -async $tid {testthread exit}}
+		    update
+		}
+	    }
+	}
+	testthread errorproc ThreadError
+	return [llength [testthread names]]
+    } else {
+	return 1
+    }
+}
+
+# Initialize the constraints and set up command line arguments 
+namespace eval tcltest {
+    ::tcltest::initConstraints
+    ::tcltest::processCmdLineArgs
+}
+
+return