Tcl Source Code

'\"
'\" Copyright (c) 1990-1994 The Regents of the University of California
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" RCS: @(#) $Id: tcltest.n,v 1.2 1999/06/29 20:14:10 jenn Exp $
'\" 
.so man.macros
.TH "Tcltest" n 8.1 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
Tcltest \- Test harness support code and utilities
.SH SYNOPSIS
\fBpackage require tcltest ?1.0?\fP
.sp
\fB::tcltest::test \fIname desc ?constraint? script expectedAnswer\fR
.sp
\fB::tcltest::cleanupTests \fI?runningMultipleTests?\fR
.sp
\fB::tcltest::getMatchingTestFiles
.sp
\fB::tcltest::dotests \fIfile pattern\fR
.sp
\fB::tcltest::makeFile \fIcontents name\fR
.sp
\fB::tcltest::removeFile \fIname\fR
.sp

This command should be called at the end of a test file.  It prints
statistics about the tests run and removes files that were created by
\fB::tcltest::makeDirectory\fR and \fB::tcltest::makeFile\fR.  Names
of files created without the \fB::tcltest::makeFile\fR command are
printed.  This command also restores the original shell
environment. The default value for \fIcalledFromAll\fR is false.
.TP
\fB::tcltest::getMatchingTestFiles\fP
This command is used when you want to run multiple test files.  It returns
the list of tests that should be sourced in an 'all.tcl' file.  See the
section \fI"Running test files"\fR for more information.
.TP
\fB::tcltest::dotests\fP \fIfile pattern\fR
Source a test file and run tests of the specified pattern.
.TP
\fB::tcltest::makeFile\fP \fIcontents name\fR
Create a file that will be automatically be removed by
\fB::tcltest::cleanupTests\fR at the end of a test run.
.TP

the fly using the ::tcltest::makeFile procedure.  Files created by the
::tcltest::makeFile procedure will automatically be removed by the
::tcltest::cleanupTests call at the end of each test file.
.PP
The <expectedAnswer> argument will be compared against the result of
evaluating the <script> argument.  If they match, the test passes,
otherwise the test fails.
.SH "TCLTEST NAMEPSACE VARIABLES"
The following variables are also defined in the \fBtcltest\fR namespace and
can be used by tests:
.TP
\fB::tcltest::outputChannel\fR
output file ID - defaults to stdout and can be specified using -outfile
.TP
\fB::tcltest::errorChannel\fR
error file ID - defaults to stderr and can be specified using -errfile
.TP
\fB::tcltest::mainThread\fR
main thread ID - defaults to 1
.TP
\fB::tcltest::originalEnv\fR
values of environment variables at the beginning of the test run (::env)
.TP
\fB::tcltest::workingDirectory\fR
the current working directory ([pwd])
.TP
\fB::tcltest::temporaryDirectory\fR
the output directory - defaults to the current working directory and can be
specified using -tmpdir
.TP
\fB::tcltest::testsDirectory\fR
where the tests reside - defaults to [pwd] and can be affected by use of
-relateddir and -asidefromdir
.TP
\fB::tcltest::isoLocale\fR
used for internationalization support - default language is French; default
value is fr_FR.ISO_8859-1 for FreeBSD, fr_FR.iso88591 for HP-UX, fr for
Linux and IRIX, iso_8859_1 for other UNIX systems, and French for Windows.
.TP
\fB::tcltest::tcltest\fR
the name of the tcltest executable ([info nameofexecutable])
.SH "TEST CONSTRAINTS"
Constraints are used to determine whether a test should be skipped.
Each constraint is stored as an index in the array
::tcltest::testConstraints.  For example, the unixOnly constraint is
defined as the following:
.PP
.DS

.TP
\fInt\fR
test can only be run on any Windows NT platform
.TP
\fI95\fR
test can only be run on any Windows 95 platform
.TP
\fI98\fR
test can only be run on any Windows 98 platform
.TP
\fImac\fR
test can only be run on any Mac platform
.TP
\fIunixOrPc\fR
test can only be run on a UNIX or PC platform
.TP
\fImacOrPc\fR

\fIunixExecs\fR
test can only be run if this machine has commands such as 'cat', 'echo',
etc. available.  
.TP
\fIhasIsoLocale\fR
test can only be run if can switch to an ISO locale
.TP



\fIroot\fR
test can only run if Unix user is root
.TP
\fInotRoot\fR
test can only run if Unix user is not root
.TP
\fIeformat\fR

.DS
<shell> <testFile> ?<option> <value>? ...
.DE
Command line options include (variables that correspond to each flag
are listed at the end of each flag description in parenthesis):
.RS
.TP
\fB-help\fR
display usage information.
.TP
\fB-verbose <level>\fR
set the level of verbosity to a substring of "bps".  See the "Test
output" section for an explanation of this option.       
.TP
\fB-match <matchList>\fR
only run tests that match one or more of the glob patterns in
<matchList> 
.TP
\fB-skip <skipList>\fR
do not run tests that match one or more of the glob patterns in
<skipList> 
.TP
\fB-file <globPatternList>\fR
only source test files that match any of the items in
<globPatternList> (relative to ::tcltest::testsDirectory).
.TP
\fB-notfile <globPatternList>\fR
source files except for those that match any of the items in
<globPatternList> (relative to ::tcltest::testsDirectory).  
.TP
\fB-relateddir <globPattern>\fR
only run tests in the directories that match <globPattern> (relative to the
current directory).
.TP
\fB-asidefromdir <globPattern>\fR
use all specified directories except those that match <globPattern> (relative
to the current directory).
.TP
\fB-constraints <list>\fR
tests with any constraints in <list> will not be skipped.  Note that
elements of <list> must exactly match the existing constraints.
.TP
\fB-limitconstraints <bool>\fR
If the argument to this flag is 1, the test harness limits test runs
to those tests that match the constraints listed by the -constraints
flag. Use of this flag requires use of the -constraints flag.  The
default value for this flag is 0 (false).
.TP
\fB-tmpdir <directoryName>\fR
put any temporary files (created with ::tcltest::makeFile and
::tcltest::makeDirectory) into the named directory.  The default
location is your current working directory.
.TP
\fB-preservecore <bool>\fR
If the argument to this flag is 1 (true), the test harness saves any
core files produced at the end of a test run in
::tcltest::temporaryDirectory. The default value for this flag is 0
(false).
.TP
\fB-debug <debugLevel>\fR
print out debug information.  This is used to debug code in the test
harness.  The default debug level is 1.  Levels are defined as:
.RS
.IP 1
Display information regarding whether a test is skipped because it
doesn't match any of the tests that were specified using -match or
::tcltest::match (userSpecifiedNonMatch) or matches any of the tests
specified by -skip or ::tcltest::skip (userSpecifiedSkip).  
.IP 2
Display the flag array parssed by the command line processor, the
contents of the env array, and all user-defined variables that exist
in the current namespace as they are used.
.IP 3
Display information regarding what individual procs in the test
harness are doing.
.RE

\fB-outfile <filename>\fR 
send normal output to the named file.  This defaults to stdout.  Note
that debug output always goes to stdout, regardless of this flag's
setting. 
.TP
\fB-errfile <filename>\fR
send errors to the named file.  This defaults to stderr.  Note

::tcltest::skip 
.IP -verbose
::tcltest::verbose 
.IP -outfile
::tcltest::outputChannel 
.IP -errfile
::tcltest::errorChannel 
.IP -preservecore
::tcltest::preserveCore
.IP -debug
::tcltest::debug, ::tcltest::debugLevel 
.IP -tmpdir
::tcltest::temporaryDirectory 
.IP -constraints
::tcltest::testConstraints(\fIconstraintName\fR) 
.IP -limitconstraints
::tcltest::limitConstraints
.RE
.PP
See the \fI"Test Constraints"\fR for all available constraint names
that can be used in the \fB::tcltest::testConstraints\fR array. 
See \fI"Tcltest namespace variables"\fR for details on other variables
defined in the \fBtcltest\fR namespace.










.PP
A final way to run tests would be to specify which test files to run
within an \fIall.tcl\fR (or otherwise named) file.  This is the
approach used by the Tcl test suite.  An extremely simple all.tcl file
would simply source all files with a .test extension within the
current directory.  A more elaborate one might do some pre- and
post-processing before sourcing each .test file, use separate
interpreters for each file, or handle complex directory structures.
.PP
In all cases, no output will be generated if all goes well, except for
a listing of the test files and a statistical summary.  If there are
errors, then additional messages will appear in the format described
below.  Note that some tests will be skipped if you run as superuser.
.SH "TEST OUTPUT"
After all specified test files are run, the number of tests
passed, skipped, and failed is printed to
\fB::tcltest::outputChannel\fR.  Aside from this 
statistical information, output can be controlled on a per-test basis
by the \fB::tcltest::verbose\fR variable.
.PP
\fB::tcltest::verbose\fR can be set to any substring or permutation 
of "bps". In the string "bps", the 'b' stands for a test's "body", 
the 'p' stands for "passed" tests, and the 's' stands for "skipped" 
tests. The default value of \fB::tcltest::verbose\fR is "b".  If 'b'

argument \fB-verbose\fR, for example:
.DS
tclsh socket.test -verbose bps
.DE
.SH "CONTENTS OF A TEST FILE"
Test files should begin by loading the \fBtcltest\fR package:
.DS

package require tcltest
namespace import ::tcltest::*

.DE
Test files should end by cleaning up after themselves and calling
\fB::tcltest::cleanupTests\fR.  The \fB::tcltest::cleanupTests\fR
procedure prints statistics about the number of tests that passed,
skipped, and failed, and removes all files that were created using the
\fB::tcltest::makeFile\fR and \fB::tcltest::makeDirectory\fR procedures.
.DS

.CS
tclsh all.tcl -constraints "knownBug nonPortable"
.CE
.PP
See the \fI"Constraints"\fR package for information about using
built-in constraints and adding new ones.
.SH "HOW TO CUSTOMIZE THE TEST HARNESS"
To create your own custom test harness, create a .tcl file that contains your
namespace.  Within this file, require package \fBtcltest\fR.  To add new
constraints, define your own version of \fB::tcltest::initConstraintsHook\fR.
Within your proc, you can add to the \fB::tcltest::testConstraints\fR array.
For example:
.DS
proc ::tcltest::initConstraintsHook {} {
    set ::tcltest::testConstraints(win95Or98) \\
            [expr {$::tcltest::testConstraints(95) || \\
            $::tcltest::testConstraints(98)}]
}
.DE
.PP
To add new flags to your customized test harness, redefine
\fB::tcltest::processCmdLineArgsAddFlagHook\fR to define additional flags to be
parsed and \fB::tcltest::processCmdLineArgsHook\fR to actually process them.
For example:
.DS
proc ::tcltest::processCmdLineArgsAddFlagHook {} {
    return [list -flag1 -flag2]
}

proc ::tcltest::processCmdLineArgsHook {flagArray} {
    array set flag $flagArray

    if {[info exists flag(-flag1)]} {
        # Handle flag1
    }

    if {[info exists flag(-flag2)]} {
        # Handle flag2
    }

    return
}
.DE
.PP
Finally, if you want to add additional cleanup code to your harness
you can define your own \fB::tcltest::cleanupTestsHook\fR.  For example:
.DS
proc ::tcltest::cleanupTestsHook {} {
    # Add your cleanup code here
}
.DE
.SH EXAMPLES
.IP [1] 
A simple test file (foo.test)
.DS
package require tcltest
import namespace ::tcltest::*
test foo-1.1 {save 1 in variable name foo} {} {
    set foo 1
} {1}
cleanupTests
return
.DE
.IP [2] 
A simple all.tcl
.DS
package require tcltest
import namespace ::tcltest::*
set ::tcltest::testSingleFile 0
set ::tcltest::testsDirectory [file dir [info script]]
foreach file [::tcltest::getMatchingTestFiles] {
    if {[catch {source $file} msg]} {
        puts stdout $msg
    }
}
::tclttest::cleanupTests 1
return
.DE
.IP [3] 
Running a single test
.DS
tclsh foo.test
.DE
.IP [4] 
Running multiple tests
.DS
tclsh all.tcl -file 'foo*.test' -notfile 'foo2.test'
.DE
.SH "SEE ALSO"
tktest(n)
.SH KEYWORDS
test, test harness, test suite

# 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 ::tcltest::getMatchingTestFiles }}}]

# 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 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.2 1999/06/29 20:14:15 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 getMatchingTestFiles]
    foreach proc $procList {
	namespace export $proc
    }

    # ::tcltest::verbose defaults to "b"

    variable verbose "b"

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

    variable match {}
    variable skip {}

    variable matchFiles {*.test}
    variable skipFiles {}

    variable matchDirectories {}
    variable skipDirectories {}

    # By default, don't save core files
    variable preserveCore false

    # output goes to stdout by default

    variable outputChannel stdout

    # errors go to stderr by default

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

    # Don't run only the constrained tests by default
    variable limitConstraints false

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




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

    # the variables and procs that existed when ::tcltest::saveState was
    # called are stored in a variable of the same name
    variable saveState {}

    # Internationalization support
    if {![info exists ::tcltest::isoLocale]} {
	variable isoLocale fr
        switch $tcl_platform(platform) {
	    "unix" {

		set ::tcltest::isoLocale French
	    }
	}
    }

    # Set the location of the execuatble
    variable tcltest [info nameofexecutable]
}   

# ::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 the kept tests
    # from running

    if {[info exists ::tcltest::skippedBecause($constraint)]} {
	incr ::tcltest::skippedBecause($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
	}

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

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

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\
		-relateddir pattern\t Run tests in directories that match \n\
		\t                 the glob pattern given. \n\
                -asidefromdir pattern\t Skip tests in directories that match \n\
		\t                 the glob pattern given. \n\
		-preservecore bool \t If true, save any core files produced \n\
		\t                 during testing in the directory \n\
		\t                 specified by -tmpdir. 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\
		-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\
		-debug level     \t Internal debug flag."]
    ::tcltest::PrintUsageInfoHook
    return
}

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

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
#

proc ::tcltest::processCmdLineArgsHook {flag} {}

# ::tcltest::processCmdLineArgs --
#
#	Use command line args to set the verbose, skip, and
#	match, outputChannel, errorChannel, debug, and temporaryDirectory

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

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

    # -help is not listed since it has already been processed
    lappend defaultFlags {-verbose -match -skip -constraints \
	    -outfile -errfile -debug -tmpdir -file -notfile -relateddir \
	    -asidefromdir -preservecore -limitconstraints}
    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 ::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)
    }

    # Handle -relateddir and -asidefromdir flags
    if {[info exists flag(-relateddir)]} {
	set ::tcltest::matchDirectories $flag(-relateddir)
    }
    if {[info exists flag(-asidefromdir)]} {
	set ::tcltest::skipDirectories $flag(-asidefromdir)
    }

    # 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
	}
	set ::tcltest::limitConstraints $flag(-limitconstraints)
	foreach elt [array names ::tcltest::testConstraints] {
	    if {[lsearch -exact $flag(-constraints) $elt] == -1} {
		set ::tcltest::testConstraints($elt) 0
	    }
	}
    }

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

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

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

    # Find the matching directories and then remove the ones that are 
    # specified in the skip pattern; if no match pattern is specified, use
    # the default value specified for ::tcltest::testsDirectory - ignore the
    # value of ::tcltest::skipDirectories if the default value is being used.
    if {$::tcltest::matchDirectories != {}} {
	set matchDir {}
	set skipDir {}
	if {$::tcltest::skipDirectories != {}} {
	    set skipDir [glob -nocomplain $::tcltest::skipDirectories]
	}
	foreach dir [glob -nocomplain $::tcltest::matchDirectories] {
	    if {[lsearch -exact $skipDir $dir] == -1} {
		lappend matchDir $dir
	    }
	}
	
	# Only reset ::tcltest::testsDirectory if anything actually matched
	# after removing the skip patterns.
	if {[llength $matchDir] > 0} {
	    set ::tcltest::testsDirectory $matchDir
	}
    }

    # Call the hook
    ::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
	puts "Constraints:"
	parray ::tcltest::testConstraints
    }
}

# ::tcltest::cleanupTests --
#
# Remove files and dirs created using the makeFile and makeDirectory
# commands since the last time this proc was invoked.

	# 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] && !$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"
	}

    }
}

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

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

	    }
	    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 {[.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} {

	    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\""
    }   

    # 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 compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} {
	incr ::tcltest::numTests(Passed)
	if {[string first p $::tcltest::verbose] != -1} {
	    puts $::tcltest::outputChannel "++++ $name PASSED"
	}
    } else {

	    }
	} else {
	    puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
	}
	puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
	puts $::tcltest::outputChannel "==== $name FAILED\n"
    }
    if {[file exists [file join $::tcltest::workingDirectory core]]} {
	if {$::tcltest::preserveCore} {
	    file rename -force [file join $::tcltest::workingDirectory core] \
		    [file join $::tcltest::temporaryDirectory core-$name]
	    
	    puts $::tcltest::outputChannel "==== $name produced core file! \
		    Moved file to: \
		    [file join $::tcltest::temporaryDirectory core-$name]"
	} else {
	    puts $::tcltest::outputChannel "==== $name produced core file!"
	}
    }
}

# ::tcltest::getMatchingTestFiles
#
#       Looks at the patterns given to match and skip directories and 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 {} {
    set matchingFiles {}
    # Find the matching files in the list of directories and then remove the
    # ones that match the skip pattern
    foreach directory $::tcltest::testsDirectory {
	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
}

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

proc ::tcltest::dotests {file args} {
    set savedTests $::tcltest::match
    set ::tcltest::match $args
    source $file
    set ::tcltest::match $savedTests
}


# 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]]}
    if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} {
	puts "::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]])} {
	    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"
	}
    }
}

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

    close $fd

    set fullName [file join [pwd] $name]
    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
	lappend ::tcltest::filesMade $fullName
    }
}

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

proc ::tcltest::removeFile {name} {
    if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
	puts "::tcltest::removeFile: removing $name"
    }
    file delete $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

# 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 ::tcltest::getMatchingTestFiles }}}]

# 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 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.2 1999/06/29 20:14:15 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 getMatchingTestFiles]
    foreach proc $procList {
	namespace export $proc
    }

    # ::tcltest::verbose defaults to "b"

    variable verbose "b"

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

    variable match {}
    variable skip {}

    variable matchFiles {*.test}
    variable skipFiles {}

    variable matchDirectories {}
    variable skipDirectories {}

    # By default, don't save core files
    variable preserveCore false

    # output goes to stdout by default

    variable outputChannel stdout

    # errors go to stderr by default

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

    # Don't run only the constrained tests by default
    variable limitConstraints false

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




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

    # the variables and procs that existed when ::tcltest::saveState was
    # called are stored in a variable of the same name
    variable saveState {}

    # Internationalization support
    if {![info exists ::tcltest::isoLocale]} {
	variable isoLocale fr
        switch $tcl_platform(platform) {
	    "unix" {

		set ::tcltest::isoLocale French
	    }
	}
    }

    # Set the location of the execuatble
    variable tcltest [info nameofexecutable]
}   

# ::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 the kept tests
    # from running

    if {[info exists ::tcltest::skippedBecause($constraint)]} {
	incr ::tcltest::skippedBecause($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
	}

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

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

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\
		-relateddir pattern\t Run tests in directories that match \n\
		\t                 the glob pattern given. \n\
                -asidefromdir pattern\t Skip tests in directories that match \n\
		\t                 the glob pattern given. \n\
		-preservecore bool \t If true, save any core files produced \n\
		\t                 during testing in the directory \n\
		\t                 specified by -tmpdir. 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\
		-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\
		-debug level     \t Internal debug flag."]
    ::tcltest::PrintUsageInfoHook
    return
}

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

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
#

proc ::tcltest::processCmdLineArgsHook {flag} {}

# ::tcltest::processCmdLineArgs --
#
#	Use command line args to set the verbose, skip, and
#	match, outputChannel, errorChannel, debug, and temporaryDirectory

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

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

    # -help is not listed since it has already been processed
    lappend defaultFlags {-verbose -match -skip -constraints \
	    -outfile -errfile -debug -tmpdir -file -notfile -relateddir \
	    -asidefromdir -preservecore -limitconstraints}
    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 ::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)
    }

    # Handle -relateddir and -asidefromdir flags
    if {[info exists flag(-relateddir)]} {
	set ::tcltest::matchDirectories $flag(-relateddir)
    }
    if {[info exists flag(-asidefromdir)]} {
	set ::tcltest::skipDirectories $flag(-asidefromdir)
    }

    # 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
	}
	set ::tcltest::limitConstraints $flag(-limitconstraints)
	foreach elt [array names ::tcltest::testConstraints] {
	    if {[lsearch -exact $flag(-constraints) $elt] == -1} {
		set ::tcltest::testConstraints($elt) 0
	    }
	}
    }

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

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

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

    # Find the matching directories and then remove the ones that are 
    # specified in the skip pattern; if no match pattern is specified, use
    # the default value specified for ::tcltest::testsDirectory - ignore the
    # value of ::tcltest::skipDirectories if the default value is being used.
    if {$::tcltest::matchDirectories != {}} {
	set matchDir {}
	set skipDir {}
	if {$::tcltest::skipDirectories != {}} {
	    set skipDir [glob -nocomplain $::tcltest::skipDirectories]
	}
	foreach dir [glob -nocomplain $::tcltest::matchDirectories] {
	    if {[lsearch -exact $skipDir $dir] == -1} {
		lappend matchDir $dir
	    }
	}
	
	# Only reset ::tcltest::testsDirectory if anything actually matched
	# after removing the skip patterns.
	if {[llength $matchDir] > 0} {
	    set ::tcltest::testsDirectory $matchDir
	}
    }

    # Call the hook
    ::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
	puts "Constraints:"
	parray ::tcltest::testConstraints
    }
}

# ::tcltest::cleanupTests --
#
# Remove files and dirs created using the makeFile and makeDirectory
# commands since the last time this proc was invoked.

	# 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] && !$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"
	}

    }
}

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

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

	    }
	    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 {[.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} {

	    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\""
    }   

    # 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 compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} {
	incr ::tcltest::numTests(Passed)
	if {[string first p $::tcltest::verbose] != -1} {
	    puts $::tcltest::outputChannel "++++ $name PASSED"
	}
    } else {

	    }
	} else {
	    puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
	}
	puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
	puts $::tcltest::outputChannel "==== $name FAILED\n"
    }
    if {[file exists [file join $::tcltest::workingDirectory core]]} {
	if {$::tcltest::preserveCore} {
	    file rename -force [file join $::tcltest::workingDirectory core] \
		    [file join $::tcltest::temporaryDirectory core-$name]
	    
	    puts $::tcltest::outputChannel "==== $name produced core file! \
		    Moved file to: \
		    [file join $::tcltest::temporaryDirectory core-$name]"
	} else {
	    puts $::tcltest::outputChannel "==== $name produced core file!"
	}
    }
}

# ::tcltest::getMatchingTestFiles
#
#       Looks at the patterns given to match and skip directories and 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 {} {
    set matchingFiles {}
    # Find the matching files in the list of directories and then remove the
    # ones that match the skip pattern
    foreach directory $::tcltest::testsDirectory {
	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
}

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

proc ::tcltest::dotests {file args} {
    set savedTests $::tcltest::match
    set ::tcltest::match $args
    source $file
    set ::tcltest::match $savedTests
}


# 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]]}
    if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} {
	puts "::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]])} {
	    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"
	}
    }
}

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

    close $fd

    set fullName [file join [pwd] $name]
    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
	lappend ::tcltest::filesMade $fullName
    }
}

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

proc ::tcltest::removeFile {name} {
    if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
	puts "::tcltest::removeFile: removing $name"
    }
    file delete $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

# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests.  Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: all.tcl,v 1.7 1999/06/29 20:14:17 jenn Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

set ::tcltest::testSingleFile false
set ::tcltest::testsDirectory [file dir [info script]]

puts stdout "Tcl $tcl_patchLevel tests running in interp:  [info nameofexecutable]"
puts stdout "Tests running in working dir:  $::tcltest::testsDirectory"
if {[llength $::tcltest::skip] > 0} {
    puts stdout "Skipping tests that match:  $::tcltest::skip"
}
if {[llength $::tcltest::match] > 0} {
    puts stdout "Only running tests that match:  $::tcltest::match"
}

if {[llength $::tcltest::skipFiles] > 0} {



    puts stdout "Skipping test files that match:  $::tcltest::skipFiles"




}

if {[llength $::tcltest::matchFiles] > 0} {
    puts stdout "Only sourcing test files that match:  $::tcltest::matchFiles"


}





set timeCmd {clock format [clock seconds]}
puts stdout "Tests began at [eval $timeCmd]"

# source each of the specified tests
foreach file [lsort [::tcltest::getMatchingFiles]] {
    set tail [file tail $file]




    puts stdout $tail
    if {[catch {source $file} msg]} {
	puts stdout $msg
    }
}

# cleanup
puts stdout "\nTests ended at [eval $timeCmd]"
::tcltest::cleanupTests 1
return

#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winPipe.test,v 1.10 1999/06/29 20:14:17 jenn Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

set bindir [file join [pwd] [file dirname [info nameofexecutable]]]

catch {set env_tmp $env(TMP)}
catch {set env_temp $env(TEMP)}

set env(TMP) c:/
set env(TEMP) c:/

test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {pcOnly stdio} {
    set x {}
    set existing [glob -nocomplain c:/tcl*.tmp]
    exec $::tcltest::tcltest < nothing 
    foreach p [glob -nocomplain c:/tcl*.tmp] {
	if {[lsearch $existing $p] == -1} {
	    lappend x $p
	}
    }
    set x
} {}
test winpipe-5.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly stdio} {
    set tmp $env(TMP)
    set temp $env(TEMP)
    unset env(TMP)
    unset env(TEMP)
    exec $::tcltest::tcltest < nothing
    set env(TMP) $tmp
    set env(TEMP) $temp
    set x {}
} {}
test winpipe-5.3 {TclpCreateTempFile: TMP specifies non-existent directory} \
	{pcOnly stdio} {
    set tmp $env(TMP)
    set env(TMP) snarky
    exec $::tcltest::tcltest < nothing
    set env(TMP) $tmp
    set x {}
} {}
test winpipe-5.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \
	{pcOnly stdio} {
    set tmp $env(TMP)
    set temp $env(TEMP)
    unset env(TMP)
    set env(TEMP) snarky
    exec $::tcltest::tcltest < nothing
    set env(TMP) $tmp
    set env(TEMP) $temp
    set x {}
} {}

test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \
	{pcOnly stdio cat32} {
    set f [open "|$cat32" r+]
    fconfigure $f -blocking 0
    fileevent $f writable { set x writable }
    set x {}
    vwait x
    fileevent $f writable {}
    fileevent $f readable { lappend x readable }
    after 100 { lappend x timeout }
    vwait x
    puts $f foobar
    flush $f
    vwait x
    lappend x [read $f]
    after 100 { lappend x timeout }
    vwait x
    lappend x [catch {close $f} msg] $msg
} {writable timeout readable {foobar
} timeout 1 stderr32}
test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \
	{pcOnly stdio cat32} {
    set f [open "|$cat32" r+]
    fconfigure $f -blocking 0
    fileevent $f writable { set x writable }
    set x {}
    vwait x
    puts -nonewline $f $big$big$big$big
    flush $f
    after 100 { lappend x timeout }
    vwait x
    lappend x [catch {close $f} msg] $msg
} {writable timeout 0 {}}

makeFile {
    puts "[list $argv0 $argv]"
} echoArgs.tcl

test winpipe-7.1 {BuildCommandLine: null arguments} {pcOnly stdio} {
    exec $::tcltest::tcltest echoArgs.tcl foo "" bar
} {echoArgs.tcl {foo {} bar}}
test winpipe-7.2 {BuildCommandLine: null arguments} {pcOnly stdio} {
    exec $::tcltest::tcltest echoArgs.tcl foo \" bar
} {echoArgs.tcl {foo {"} bar}}

# restore old values for env(TMP) and env(TEMP)

if {[catch {set env(TMP) $env_tmp}]} {
    unset env(TMP)