path: root/library/tcltest/tcltest.tcl

# tcltest.tcl --
#
#	This file contains support code for the Tcl test suite.  It 
#       defines the ::tcltest namespace and finds and defines the output
#       directory, constraints available, output and error channels, etc. used
#       by Tcl tests.  See the tcltest man page for more details.
#       
#       This design was based on the 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.19 1999/11/04 18:20:12 jenn Exp $

package provide tcltest 1.0

# create the "tcltest" namespace for all testing variables and procedures

namespace eval tcltest { 

    # Export the public tcltest procs
    set procList [list test cleanupTests saveState restoreState \
	    normalizeMsg makeFile removeFile makeDirectory removeDirectory \
	    viewFile bytestring safeFetch threadReap getMatchingFiles \
	    loadTestedCommands]
    foreach proc $procList {
	namespace export $proc
    }

    # ::tcltest::verbose defaults to "b"
    if {![info exists verbose]} {
	variable verbose "b"
    }

    # Match and skip patterns default to the empty list, except for
    # matchFiles, which defaults to all .test files in the testsDirectory

    if {![info exists match]} {
	variable match {}
    }
    if {![info exists skip]} {
	variable skip {}
    }
    if {![info exists matchFiles]} {
	variable matchFiles {*.test}
    }
    if {![info exists skipFiles]} {
	variable skipFiles {}
    }

    # By default, don't save core files
    if {![info exists preserveCore]} {
	variable preserveCore 0
    }

    # output goes to stdout by default
    if {![info exists outputChannel]} {
	variable outputChannel stdout
    }

    # errors go to stderr by default
    if {![info exists errorChannel]} {
	variable errorChannel stderr
    }

    # debug output doesn't get printed by default; debug level 1 spits
    # up only the tests that were skipped because they didn't match or were 
    # specifically skipped.  A debug level of 2 would spit up the tcltest
    # variables and flags provided; a debug level of 3 causes some additional
    # output regarding operations of the test harness.  The tcltest package
    # currently implements only up to debug level 3.
    if {![info exists debug]} {
	variable debug 0
    }

    # Save any arguments that we might want to pass through to other programs. 
    # This is used by the -args flag.
    if {![info exists parameters]} {
	variable parameters {}
    }

    # 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.

    if {![info exists numTestFiles]} {
	variable numTestFiles 0
    }
    if {![info exists testSingleFile]} {
	variable testSingleFile true
    }
    if {![info exists currentFailure]} {
	variable currentFailure false
    }
    if {![info exists failFiles]} {
	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.

    if {![info exists filesMade]} {
	variable filesMade {}
    }
    if {![info exists filesExisted]} {
	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.

    if {![info exists createdNewFiles]} {
	variable createdNewFiles
	array set ::tcltest::createdNewFiles {}
    }

    # initialize ::tcltest::numTests array to keep track fo the number of
    # tests that pass, fail, and are skipped.

    if {![info exists numTests]} {
	variable numTests
	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. 

    if {![info exists skippedBecause]} {
	variable skippedBecause
	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).

    if {![info exists testConstraints]} {
	variable testConstraints
	array set ::tcltest::testConstraints {}
    }

    # Don't run only the constrained tests by default

    if {![info exists limitConstraints]} {
	variable limitConstraints false
    }

    # A test application has to know how to load the tested commands into
    # the interpreter.

    if {![info exists loadScript]} {
	variable loadScript {}
    }

    # tests that use threads need to know which is the main thread

    if {![info exists mainThread]} {
	variable mainThread 1
	if {[info commands testthread] != {}} {
	    set mainThread [testthread names]
	}
    }

    # save the original environment so that it can be restored later
    
    if {![info exists originalEnv]} {
	variable originalEnv
	array set ::tcltest::originalEnv [array get ::env]
    }

    # Set ::tcltest::workingDirectory to [pwd]. The default output directory
    # for Tcl tests is the working directory.

    if {![info exists workingDirectory]} {
	variable workingDirectory [pwd]
    }
    if {![info exists temporaryDirectory]} {
	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.

    if {![info exists testsDirectory]} {
	set oldpwd [pwd]
	catch {cd [file join [file dirname [info script]] .. .. tests]}
	variable testsDirectory [pwd]
	cd $oldpwd
	unset oldpwd
    }

    # the variables and procs that existed when ::tcltest::saveState was
    # called are stored in a variable of the same name
    if {![info exists saveState]} {
	variable saveState {}
    }

    # Internationalization support
    if {![info exists 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
    if {![info exists tcltest]} {
	variable tcltest [info nameofexecutable]
    }

    # save the platform information so it can be restored later
    if {![info exists originalTclPlatform]} {
	variable originalTclPlatform [array get tcl_platform]
    }

    # If a core file exists, save its modification time.
    if {![info exists coreModificationTime]} {
	if {[file exists [file join $::tcltest::workingDirectory core]]} {
	    variable coreModificationTime [file mtime [file join \
		    $::tcltest::workingDirectory core]]
	}
    }

    # Tcl version numbers
    if {![info exists version]} {
	variable version 8.3
    }
    if {![info exists patchLevel]} {
	variable patchLevel 8.3.0
    }
}   

# ::tcltest::Debug* --
#
#     Internal helper procedures to write out debug information
#     dependent on the chosen level. A test shell may overide
#     them, f.e. to redirect the output into a different
#     channel, or even into a GUI.

# ::tcltest::DebugPuts --
#
#     Prints the specified string if the current debug level is
#     higher than the provided level argument.
#
# Arguments:
#     level   The lowest debug level triggering the output
#     string  The string to print out.
#
# Results:
#     Prints the string. Nothing else is allowed.
#

proc ::tcltest::DebugPuts {level string} {
    variable debug
    if {$debug >= $level} {
	puts $string
    }
}

# ::tcltest::DebugPArray --
#
#     Prints the contents of the specified array if the current
#       debug level is higher than the provided level argument
#
# Arguments:
#     level           The lowest debug level triggering the output
#     arrayvar        The name of the array to print out.
#
# Results:
#     Prints the contents of the array. Nothing else is allowed.
#

proc ::tcltest::DebugPArray {level arrayvar} {
    variable debug

    if {$debug >= $level} {
	catch {upvar  $arrayvar $arrayvar}
	parray $arrayvar
    }
}

# ::tcltest::DebugDo --
#
#     Executes the script if the current debug level is greater than
#       the provided level argument
#
# Arguments:
#     level   The lowest debug level triggering the execution.
#     script  The tcl script executed upon a debug level high enough.
#
# Results:
#     Arbitrary side effects, dependent on the executed script.
#

proc ::tcltest::DebugDo {level script} {
    variable debug

    if {$debug >= $level} {
	uplevel $script
    }
}

# ::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.

proc ::tcltest::AddToSkippedBecause { constraint } {
    # add the constraint to the list of constraints that 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, making sure that all messages are < 80 characters per line.
#
# 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

    # Keep track of where the end of the string is.
    set endingIndex [string length $errorMsg]

    if {$endingIndex < 80} {
	puts $::tcltest::errorChannel $errorMsg
    } else {
	# Print up to 80 characters on the first line, including the
	# InitialMessage. 
	set beginningIndex [string last " " [string range $errorMsg 0 \
		[expr {80 - $InitialMsgLen}]]]
	puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]

	while {$beginningIndex != "end"} {
	    puts -nonewline $::tcltest::errorChannel \
		    [string repeat " " $InitialMsgLen]  
	    if {[expr {$endingIndex - $beginningIndex}] < 72} {
		puts $::tcltest::errorChannel [string trim \
			[string range $errorMsg $beginningIndex end]]
		set beginningIndex end
	    } else {
		set newEndingIndex [expr [string last " " [string range \
			$errorMsg $beginningIndex \
			[expr {$beginningIndex + 72}]]] + $beginningIndex]
		if {($newEndingIndex <= 0) \
			|| ($newEndingIndex <= $beginningIndex)} {
		    set newEndingIndex end
		}
		puts $::tcltest::errorChannel [string trim \
			[string range $errorMsg \
			$beginningIndex $newEndingIndex]]
		set beginningIndex $newEndingIndex
	    }
	}
    }
    flush $::tcltest::errorChannel
    return
}

if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} {
    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 tcltest man page 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

    # 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(98) [string equal $tcl_platform(os) \
	    "Windows 98"]
    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
    
    if {[info exists tcl_interactive]} {
	set ::tcltest::testConstraints(interactive) $::tcl_interactive
    } else {
	set ::tcltest::testConstraints(interactive) 0
    }

    # 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 equal "[format %g 5e-5]" "5e-05"]} {
	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
    }
}   

# ::tcltest::PrintUsageInfoHook
#
#       Hook used for customization of display of usage information.
#

if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} {
    proc ::tcltest::PrintUsageInfoHook {} {}
}

# ::tcltest::PrintUsageInfo
#
#	Prints out the usage information for package tcltest.  This can be
#       customized with the redefinition of ::tcltest::PrintUsageInfoHook.
#
# Arguments:
#	none
#

proc ::tcltest::PrintUsageInfo {} {
    puts [format "Usage: [file tail [info nameofexecutable]] \
	    script ?-help? ?flag value? ... \n\
	    Available flags (and valid input values) are: \n\
	    -help          \t Display this usage information. \n\
	    -verbose level \t Takes any combination of the values \n\
	    \t                 'p', 's' and 'b'.  Test suite will \n\
	    \t                 display all passed tests if 'p' is \n\
	    \t                 specified, all skipped tests if 's' \n\
	    \t                 is specified, and the bodies of \n\
	    \t                 failed tests if 'b' is specified. \n\
	    \t                 The default value is 'b'. \n\
	    -constraints list\t Do not skip the listed constraints\n\
	    -limitconstraints bool\t Only run tests with the constraints\n\
	    \t                 listed in -constraints.\n\
	    -match pattern \t Run all tests within the specified \n\
	    \t                 files that match the glob pattern \n\
	    \t                 given. \n\
	    -skip pattern  \t Skip all tests within the set of \n\
	    \t                 specified tests (via -match) and \n\
	    \t                 files that match the glob pattern \n\
	    \t                 given. \n\
	    -file pattern  \t Run tests in all test files that \n\
	    \t                 match the glob pattern given. \n\
	    -notfile pattern\t Skip all test files that match the \n\
	    \t                 glob pattern given. \n\
	    -preservecore level \t If 2, save any core files produced \n\
	    \t                 during testing in the directory \n\
	    \t                 specified by -tmpdir. If 1, notify the\n\
	    \t                 user if core files are created. The default \n\
	    \t                 is $::tcltest::preserveCore. \n\
	    -tmpdir directory\t Save temporary files in the specified\n\
	    \t                 directory.  The default value is \n\
	    \t                 $::tcltest::temporaryDirectory. \n\
	    -testdir directories\t Search tests in the specified\n\
	    \t                 directories.  The default value is \n\
	    \t                 $::tcltest::testsDirectory. \n\
	    -outfile file    \t Send output from test runs to the \n\
	    \t                 specified file.  The default is \n\
	    \t                 stdout. \n\
	    -errfile file    \t Send errors from test runs to the \n\
	    \t                 specified file.  The default is \n\
	    \t                 stderr. \n\
	    -loadfile file   \t Read the script to load the tested \n\
	    \t                 commands from the specified file. \n\
	    -load script     \t Specifies the script to load the tested \n\
	    \t                 commands. \n\
	    -debug level     \t Internal debug flag."]
    ::tcltest::PrintUsageInfoHook
    return
}

# ::tcltest::CheckDirectory --
#
#     This procedure checks whether the specified path is a readable
#     and/or writable directory. If one of the conditions is not
#     satisfied an error is printed and the application aborted. The
#     procedure assumes that the caller already checked the existence
#     of the path.
#
# Arguments
#     rw      Information what attributes to check. Allowed values:
#             r, w, rw, wr. If 'r' is part of the value the directory
#             must be readable. 'w' associates to 'writable'.
#     dir     The directory to check.
#     errMsg  The string to prepend to the actual error message before
#             printing it.
#
# Results
#     none
#

proc ::tcltest::CheckDirectory {rw dir errMsg} {
    # Allowed values for 'rw': r, w, rw, wr

    if {![file isdir $dir]} { 
	::tcltest::PrintError "$errMsg \"$dir\" is not a directory"
	exit 1
    } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
	::tcltest::PrintError "$errMsg \"$dir\" is not writeable"
	exit 1
    } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
	::tcltest::PrintError "$errMsg \"$dir\" is not readable"
	exit 1
    }
}

# ::tcltest::NormalizePath --
#
#     This procedure resolves any symlinks in the path thus creating a
#     path without internal redirection. It assumes that the incoming
#     path is absolute.
#
# Arguments
#     pathVar contains the name of the variable containing the path to modify.
#
# Results
#     The path is modified in place.
#

proc ::tcltest::NormalizePath {pathVar} {
    upvar $pathVar path

    set oldpwd [pwd]
    catch {cd $path}
    set path [pwd]
    cd $oldpwd
}

# ::tcltest::MakeAbsolutePath --
#
#     This procedure checks whether the incoming path is absolute or not.
#     Makes it absolute if it was not.
#
# Arguments
#     pathVar contains the name of the variable containing the path to modify.
#     prefix  is optional, contains the path to use to make the other an
#             absolute one. The current working directory is used if it was
#             not specified.
#
# Results
#     The path is modified in place.
#

proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
    upvar $pathVar path

    if {![string equal [file pathtype $path] "absolute"]} { 
	if {$prefix == {}} {
	    set prefix [pwd]
	}

	set path [file join $prefix $path] 
    }
}

# ::tcltest::processCmdLineArgsFlagsHook --
#
#	This hook is used to add to the list of command line arguments that are
#       processed by ::tcltest::processCmdLineArgs. 
#

if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
    proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
}

# ::tcltest::processCmdLineArgsHook --
#
#	This hook is used to actually process the flags added by
#       ::tcltest::processCmdLineArgsAddFlagsHook.
#
# Arguments:
#	flags      The flags that have been pulled out of argv
#

if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} {
    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] < 1)} {
	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.

    # Process -help first
    if {([lsearch -exact $flagArray {-help}] != -1) || \
	    ([lsearch -exact $flagArray {-h}] != -1)} {
	::tcltest::PrintUsageInfo
	exit 1
    }

    if {[catch {array set flag $flagArray}]} {
	::tcltest::PrintError "odd number of arguments specified on command line: \ 
	$argv"
	::tcltest::PrintUsageInfo
	exit 1
    }

    # -help is not listed since it has already been processed
    lappend defaultFlags -verbose -match -skip -constraints \
	    -outfile -errfile -debug -tmpdir -file -notfile \
	    -preservecore -limitconstraints -args -testdir \
	    -load -loadfile
    set defaultFlags [concat $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::parameters to the arg of the -args flag, if given
    if {[info exists flag(-args)]} {
	set ::tcltest::parameters $flag(-args)
    }

    # 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)
    }

    # Handle the -file and -notfile flags
    if {[info exists flag(-file)]} {
	set ::tcltest::matchFiles $flag(-file)
    }
    if {[info exists flag(-notfile)]} {
	set ::tcltest::skipFiles $flag(-notfile)
    }

    # 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
	}
    }

    # Use the -limitconstraints flag, if given, to tell the harness to limit
    # tests run to those that were specified using the -constraints flag.  If
    # the -constraints flag was not specified, print out an error and exit.
    if {[info exists flag(-limitconstraints)]} {
	if {![info exists flag(-constraints)]} {
	    puts "You can only use the -limitconstraints flag with \
		    -constraints"
	    exit 1
	}
	set ::tcltest::limitConstraints $flag(-limitconstraints)
	foreach elt [array names ::tcltest::testConstraints] {
	    if {[lsearch -exact $flag(-constraints) $elt] == -1} {
		set ::tcltest::testConstraints($elt) 0
	    }
	}
    }

    # 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)
	
	MakeAbsolutePath ::tcltest::temporaryDirectory
	set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
    }
    if {[file exists $::tcltest::temporaryDirectory]} {
	::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError
    } else {
	file mkdir $::tcltest::temporaryDirectory
    }

    NormalizePath ::tcltest::temporaryDirectory

    # Set the ::tcltest::testsDirectory to the arg of -testdir, 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 return an error.
    
    set testDirError ""
    if {[info exists flag(-testdir)]} {
	set ::tcltest::testsDirectory $flag(-testdir)
	
	MakeAbsolutePath ::tcltest::testsDirectory
	set testDirError "bad argument \"$flag(-testdir)\" to -testdir: "
    }
    if {[file exists $::tcltest::testsDirectory]} {
	::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError
    } else {
	::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \
		does not exist"
	exit 1
    }
    
    NormalizePath ::tcltest::testsDirectory
    
    # 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]
    }

    # If an alternate error or output files are specified, change the
    # default channels.

    if {[info exists flag(-outfile)]} {
	set tmp $flag(-outfile)
	MakeAbsolutePath tmp $::tcltest::temporaryDirectory
	set ::tcltest::outputChannel [open $tmp w]
    } 

    if {[info exists flag(-errfile)]} {
	set tmp $flag(-errfile)
	MakeAbsolutePath tmp $::tcltest::temporaryDirectory
	set ::tcltest::errorChannel [open $tmp w]
    }

    # If a load script was specified, either directly or through
    # a file, remember it for later usage.
    
    if {[info exists flag(-load)] &&  \
	    ([lsearch -exact $flagArray -load] > \
	    [lsearch -exact $flagArray -loadfile])} {
	    set ::tcltest::loadScript $flag(-load)
    }
    
    if {[info exists flag(-loadfile)] && \
	    ([lsearch -exact $flagArray -loadfile] > \
	    [lsearch -exact $flagArray -load]) } {
	set tmp $flag(-loadfile)
	MakeAbsolutePath tmp $::tcltest::temporaryDirectory
	set tmp [open $tmp r]
	set ::tcltest::loadScript [read $tmp]
	close $tmp
    }

    # If the user specifies debug testing, print out extra information during
    # the run.
    if {[info exists flag(-debug)]} {
	set ::tcltest::debug $flag(-debug)
    }

    # Handle -preservecore
    if {[info exists flag(-preservecore)]} {
	set ::tcltest::preserveCore $flag(-preservecore)
    }

    # Call the hook
    ::tcltest::processCmdLineArgsHook [array get flag]

    # Spit out everything you know if we're at a debug level 2 or greater

    DebugPuts    2 "Flags passed into tcltest:"
    DebugPArray  2 flag
    DebugPuts    2 "::tcltest::debug              = $::tcltest::debug"
    DebugPuts    2 "::tcltest::testsDirectory     = $::tcltest::testsDirectory"
    DebugPuts    2 "::tcltest::workingDirectory   = $::tcltest::workingDirectory"
    DebugPuts    2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
    DebugPuts    2 "::tcltest::outputChannel      = $::tcltest::outputChannel"
    DebugPuts    2 "::tcltest::errorChannel       = $::tcltest::errorChannel"
    DebugPuts    2 "Original environment (::tcltest::originalEnv):"
    DebugPArray  2 ::tcltest::originalEnv
    DebugPuts    2 "Constraints:"
    DebugPArray  2 ::tcltest::testConstraints
}

# ::tcltest::loadTestedCommands --
#
#     Uses the specified script to load the commands to test. Allowed to
#     be empty, as the tested commands could have been compiled into the
#     interpreter.
#
# Arguments
#     none
#
# Results
#     none

proc ::tcltest::loadTestedCommands {} {
    if {$::tcltest::loadScript == {}} {
	return
    }
    
    uplevel #0 $::tcltest::loadScript
}

# ::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
	}

	# exit only if running Tk in non-interactive mode

	global tk_version tcl_interactive
	if {[info exists tk_version] && ![info exists 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

	# 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 \
		    "env array elements created:\t$newEnv"
	}
	if {[llength $changedEnv] > 0} {
	    puts $::tcltest::outputChannel \
		    "env array elements changed:\t$changedEnv"
	}
	if {[llength $removedEnv] > 0} {
	    puts $::tcltest::outputChannel \
		    "env array elements removed:\t$removedEnv"
	}

	set changedTclPlatform {}
	foreach index [array names ::tcltest::originalTclPlatform] {
	    if {$::tcl_platform($index) != \
		    $::tcltest::originalTclPlatform($index)} { 
		lappend changedTclPlatform $index
		set ::tcl_platform($index) \
			$::tcltest::originalTclPlatform($index) 
	    }
	}
	if {[llength $changedTclPlatform] > 0} {
	    puts $::tcltest::outputChannel \
		    "tcl_platform array elements changed:\t$changedTclPlatform"
	} 

	if {[file exists [file join $::tcltest::workingDirectory core]]} {
	    if {$::tcltest::preserveCore > 1} {
		puts $::tcltest::outputChannel "produced core file! \
			Moving file to: \
			[file join $::tcltest::temporaryDirectory core-$name]"
		flush $::tcltest::outputChannel
		catch {file rename -force \
			[file join $::tcltest::workingDirectory core] \
			[file join $::tcltest::temporaryDirectory \
			core-$name]} msg
		if {[string length $msg] > 0} {
		    ::tcltest::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 ::tcltest::coreModificationTime]} {
		    if {$::tcltest::coreModificationTime != [file mtime \
			    [file join $::tcltest::workingDirectory core]]} {
			puts $::tcltest::outputChannel "A core file was created!"
		    }
		} else {
		    puts $::tcltest::outputChannel "A core file was created!"
		} 
	    }
	}
    }
}

# ::tcltest::cleanupTestsHook --
#
#	This hook allows a harness that builds upon tcltest to specify
#       additional things that should be done at cleanup.
#

if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
    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} {

    DebugPuts 3 "Running $name ($description)"

    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)
	    DebugDo 1 {::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)
	    DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
	    return
	}
    }

    set i [llength $args]
    if {$i == 0} {
	set constraints {}
	# If we're limited to the listed constraints and there aren't any
	# listed, then we shouldn't run the test.
	if {$::tcltest::limitConstraints} {
	    ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint
	    incr ::tcltest::numTests(Skipped)
	    return
	}
    } 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 {[.\w]+} $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} {
	    if {[string first s $::tcltest::verbose] != -1} {
		puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
	    }

	    incr ::tcltest::numTests(Skipped)
	    ::tcltest::AddToSkippedBecause $constraints
	    return	
	}
    } else {
	error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
    }   

    # Save information about the core file.  You need to restore the original
    # tcl_platform environment because some of the tests mess with tcl_platform.

    if {$::tcltest::preserveCore} {
	set currentTclPlatform [array get tcl_platform]
	array set tcl_platform $::tcltest::originalTclPlatform
	if {[file exists [file join $::tcltest::workingDirectory core]]} {
	    set coreModTime [file mtime [file join \
		    $::tcltest::workingDirectory core]]
	}
	array set tcl_platform $currentTclPlatform
    }

    # If there is no "memory" command (because memory debugging isn't
    # enabled), then don't attempt to use the command.
    
    if {[info commands memory] != {}} {
	memory tag $name
    }

    set code [catch {uplevel $script} actualAnswer]
    if {([string equal $actualAnswer $expectedAnswer]) && ($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"
    }
    if {$::tcltest::preserveCore} {
	set currentTclPlatform [array get tcl_platform]
	if {[file exists [file join $::tcltest::workingDirectory core]]} {
	    if {$::tcltest::preserveCore > 1} {
		puts $::tcltest::outputChannel "==== $name produced core file! \
			Moving file to: \
			[file join $::tcltest::temporaryDirectory core-$name]"
		catch {file rename -force \
			[file join $::tcltest::workingDirectory core] \
			[file join $::tcltest::temporaryDirectory \
			core-$name]} msg
		if {[string length $msg] > 0} {
		    ::tcltest::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 $::tcltest::workingDirectory core]]} {
			puts $::tcltest::outputChannel "==== $name produced core file!"
		    }
		} else {
		    puts $::tcltest::outputChannel "==== $name produced core file!"
		} 
	    }
	}
	array set tcl_platform $currentTclPlatform
    }
}

# ::tcltest::getMatchingFiles
#
#       Looks at the patterns given to match and skip files
#       and uses them to put together a list of the tests that will be run.
#
# Arguments:
#       none
#
# Results:
#       The constructed list is returned to the user.  This will primarily
#       be used in 'all.tcl' files.

proc ::tcltest::getMatchingFiles {args} {
    set matchingFiles {}
    if {[llength $args] > 0} {
	set searchDirectory $args
    } else {
	set searchDirectory $::tcltest::testsDirectory
    }
    # Find the matching files in the list of directories and then remove the
    # ones that match the skip pattern
    foreach directory $searchDirectory {
	set matchFileList {}
	foreach match $::tcltest::matchFiles {
	    set matchFileList [concat $matchFileList \
		    [glob -nocomplain [file join $directory $match]]]
	}
	if {$::tcltest::skipFiles != {}} {
	    set skipFileList {}
	    foreach skip $::tcltest::skipFiles {
		set skipFileList [concat $skipFileList \
			[glob -nocomplain [file join $directory $skip]]]
	    }
	    foreach file $matchFileList {
		# Only include files that don't match the skip pattern and
		# aren't SCCS lock files.
		if {([lsearch -exact $skipFileList $file] == -1) && \
			(![string match l.*.test [file tail $file]])} {
		    lappend matchingFiles $file
		}
	    }   
	} else {
	    set matchingFiles [concat $matchingFiles $matchFileList]
	}
    }
    if {$matchingFiles == {}} {
	::tcltest::PrintError "No test files remain after applying \
		your match and skip patterns!"
    }
    return $matchingFiles
}

# The following two procs are used in the io tests.

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
}

# ::tcltest::saveState --
#
#	Save information regarding what procs and variables exist.
#
# Arguments:
#	none
#
# Results:
#	Modifies the variable ::tcltest::saveState

proc ::tcltest::saveState {} {
    uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
    DebugPuts  2 "::tcltest::saveState: $::tcltest::saveState"
}

# ::tcltest::restoreState --
#
#	Remove procs and variables that didn't exist before the call to
#       ::tcltest::saveState.
#
# Arguments:
#	none
#
# Results:
#	Removes procs and variables from your environment if they don't exist
#       in the ::tcltest::saveState variable.

proc ::tcltest::restoreState {} {
    foreach p [info procs] {
	if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
		(![string equal ::tcltest::$p [namespace origin $p]])} {
	    
	    DebugPuts 3 "::tcltest::restoreState: Removing proc $p"
	    rename $p {}
	}
    }
    foreach p [uplevel #0 {info vars}] {
	if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
	    DebugPuts 3 "::tcltest::restoreState: Removing variable $p"
	    uplevel #0 "catch {unset $p}"
	}
    }
}

# ::tcltest::normalizeMsg --
#
#	Removes "extra" newlines from a string.
#
# Arguments:
#	msg        String to be modified
#

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
    
    DebugPuts 3 "::tcltest::makeFile: putting $contents into $name"

    set fullName [file join $::tcltest::temporaryDirectory $name]
    set fd [open $fullName w]

    fconfigure $fd -translation lf

    if {[string equal [string index $contents end] "\n"]} {
	puts -nonewline $fd $contents
    } else {
	puts $fd $contents
    }
    close $fd

    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
	lappend ::tcltest::filesMade $fullName
    }
    return $fullName
}

# ::tcltest::removeFile --
#
#	Removes the named file from the filesystem
#
# Arguments:
#	name     file to be removed
#

proc ::tcltest::removeFile {name} {
    DebugPuts 3 "::tcltest::removeFile: removing $name"
    file delete [file join $::tcltest::temporaryDirectory $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
    }
}

# ::tcltest::removeDirectory --
#
#	Removes a named directory from the file system.
#
# Arguments:
#	name    Name of the directory to remove
#

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 [file join $::tcltest::temporaryDirectory $name]]
	set data [read -nonewline $f]
	close $f
	return $data
    } else {
	exec cat [file join $::tcltest::temporaryDirectory $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}}
		}
	    }
	    ## Enter a bit a sleep to give the threads enough breathing
	    ## room to kill themselves off, otherwise the end up with a
	    ## massive queue of repeated events
	    after 1
	}
	testthread errorproc ThreadError
	return [llength [testthread names]]
    } else {
	return 1
    }
}

# Initialize the constraints and set up command line arguments 
namespace eval tcltest {
    # Ensure that we have a minimal auto_path so we don't pick up extra junk.
    set ::auto_path [list [info library]]

    ::tcltest::initConstraints
    if {[namespace children ::tcltest] == {}} {
	::tcltest::processCmdLineArgs
    }
}