source list TEXT $res] {
			    if {$y eq "pkgIndex"} {source -rsrc pkgIndex}
			}
			catch {resource close $res}
		    }
		}
		set procdDirs($dir) 1
	    }
	}
	set use_path [lrange $use_path 0 end-1]
	if {$old_path ne $auto_path} {
	    foreach dir $auto_path {
		lappend use_path $dir
	    }
	    set old_path $auto_path
	}
    }
}

# ::pkg::create --
#
#	Given a package specification generate a "package ifneeded" statement
#	for the package, suitable for inclusion in a pkgIndex.tcl file.
#
# Arguments:
#	args		arguments used by the create function:
#			-name		packageName
#			-version	packageVersion
#			-load		{filename ?{procs}?}
#			...
#			-source		{filename ?{procs}?}
#			...
#
#			Any number of -load and -source parameters may be
#			specified, so long as there is at least one -load or
#			-source parameter.  If the procs component of a 
#			module specifier is left off, that module will be
#			set up for direct loading; otherwise, it will be
#			set up for lazy loading.  If both -source and -load
#			are specified, the -load'ed files will be loaded 
#			first, followed by the -source'd files.
#
# Results:
#	An appropriate "package ifneeded" statement for the package.

proc ::pkg::create {args} {
    append err(usage) "[lindex [info level 0] 0] "
    append err(usage) "-name packageName -version packageVersion"
    append err(usage) "?-load {filename ?{procs}?}? ... "
    append err(usage) "?-source {filename ?{procs}?}? ..."

    set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
    set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
    set err(unknownOpt)   "unknown option \"%s\": should be \"$err(usage)\""
    set err(noLoadOrSource) "at least one of -load and -source must be given"

    # process arguments
    set len [llength $args]
    if { $len < 6 } {
	error $err(wrongNumArgs)
    }
    
    # Initialize parameters
    set opts(-name)		{}
    set opts(-version)		{}
    set opts(-source)		{}
    set opts(-load)		{}

    # process parameters
    for {set i 0} {$i < $len} {incr i} {
	set flag [lindex $args $i]
	incr i
	switch -glob -- $flag {
	    "-name"		-
	    "-version"		{
		if { $i >= $len } {
		    error [format $err(valueMissing) $flag]
		}
		set opts($flag) [lindex $args $i]
	    }
	    "-source"		-
	    "-load"		{
		if { $i >= $len } {
		    error [format $err(valueMissing) $flag]
		}
		lappend opts($flag) [lindex $args $i]
	    }
	    default {
		error [format $err(unknownOpt) [lindex $args $i]]
	    }
	}
    }

    # Validate the parameters
    if { [llength $opts(-name)] == 0 } {
	error [format $err(valueMissing) "-name"]
    }
    if { [llength $opts(-version)] == 0 } {
	error [format $err(valueMissing) "-version"]
    }
    
    if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
	error $err(noLoadOrSource)
    }

    # OK, now everything is good.  Generate the package ifneeded statment.
    set cmdline "package ifneeded $opts(-name) $opts(-version) "
    
    set cmdList {}
    set lazyFileList {}

    # Handle -load and -source specs
    foreach key {load source} {
	foreach filespec $opts(-$key) {
	    foreach {filename proclist} {{} {}} {
		break
	    }
	    foreach {filename proclist} $filespec {
		break
	    }
	    
	    if { [llength $proclist] == 0 } {
		set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
		lappend cmdList $cmd
	    } else {
		lappend lazyFileList [list $filename $key $proclist]
	    }
	}
    }

    if { [llength $lazyFileList] > 0 } {
	lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
		$opts(-version) [list $lazyFileList]\]"
    }
    append cmdline [join $cmdList "\\n"]
    return $cmdline
}

                                                                                                                                                                                                                                                                                                                                                                                                                               ˙$   .   á   ..   %   tcltest.tcl %  ÔpkgIndex.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.
# Copyright (c) 2000 by Ajuba Solutions
# Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.tcl,v 1.78.2.14 2007/09/11 21:18:42 dgp Exp $

package require Tcl 8.3		;# uses [glob -directory]
namespace eval tcltest {

    # When the version number changes, be sure to update the pkgIndex.tcl file,
    # and the install directory in the Makefiles.  When the minor version
    # changes (new feature) be sure to update the man page as well.
    variable Version 2.2.9

    # Compatibility support for dumb variables defined in tcltest 1
    # Do not use these.  Call [package provide Tcl] and [info patchlevel]
    # yourself.  You don't need tcltest to wrap it for you.
    variable version [package provide Tcl]
    variable patchLevel [info patchlevel]

##### Export the public tcltest procs; several categories
    #
    # Export the main functional commands that do useful things
    namespace export cleanupTests loadTestedCommands makeDirectory \
	makeFile removeDirectory removeFile runAllTests test

    # Export configuration commands that control the functional commands
    namespace export configure customMatch errorChannel interpreter \
	    outputChannel testConstraint

    # Export commands that are duplication (candidates for deprecation)
    namespace export bytestring		;# dups [encoding convertfrom identity]
    namespace export debug		;#	[configure -debug]
    namespace export errorFile		;#	[configure -errfile]
    namespace export limitConstraints	;#	[configure -limitconstraints]
    namespace export loadFile		;#	[configure -loadfile]
    namespace export loadScript		;#	[configure -load]
    namespace export match		;#	[configure -match]
    namespace export matchFiles		;#	[configure -file]
    namespace export matchDirectories	;#	[configure -relateddir]
    namespace export normalizeMsg	;#	application of [customMatch]
    namespace export normalizePath	;#	[file normalize] (8.4)
    namespace export outputFile		;#	[configure -outfile]
    namespace export preserveCore	;#	[configure -preservecore]
    namespace export singleProcess	;#	[configure -singleproc]
    namespace export skip		;#	[configure -skip]
    namespace export skipFiles		;#	[configure -notfile]
    namespace export skipDirectories	;#	[configure -asidefromdir]
    namespace export temporaryDirectory	;#	[configure -tmpdir]
    namespace export testsDirectory	;#	[configure -testdir]
    namespace export verbose		;#	[configure -verbose]
    namespace export viewFile		;#	binary encoding [read]
    namespace export workingDirectory	;#	[cd] [pwd]

    # Export deprecated commands for tcltest 1 compatibility
    namespace export getMatchingFiles mainThread restoreState saveState \
	    threadReap

    # 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 - name of variable containing path to modify.
    #
    # Results
    #     The path is modified in place.
    #
    # Side Effects:
    #     None.
    #
    proc normalizePath {pathVar} {
	upvar $pathVar path
	set oldpwd [pwd]
	catch {cd $path}
	set path [pwd]
	cd $oldpwd
	return $path
    }

##### Verification commands used to test values of variables and options
    #
    # Verification command that accepts everything
    proc AcceptAll {value} {
	return $value
    }

    # Verification command that accepts valid Tcl lists
    proc AcceptList { list } {
	return [lrange $list 0 end]
    }

    # Verification command that accepts a glob pattern
    proc AcceptPattern { pattern } {
	return [AcceptAll $pattern]
    }

    # Verification command that accepts integers
    proc AcceptInteger { level } {
	return [incr level 0]
    }

    # Verification command that accepts boolean values
    proc AcceptBoolean { boolean } {
	return [expr {$boolean && $boolean}]
    }

    # Verification command that accepts (syntactically) valid Tcl scripts
    proc AcceptScript { script } {
	if {![info complete $script]} {
	    return -code error "invalid Tcl script: $script"
	}
	return $script
    }

    # Verification command that accepts (converts to) absolute pathnames
    proc AcceptAbsolutePath { path } {
	return [file join [pwd] $path]
    }

    # Verification command that accepts existing readable directories
    proc AcceptReadable { path } {
	if {![file readable $path]} {
	    return -code error "\"$path\" is not readable"
	}
	return $path
    }
    proc AcceptDirectory { directory } {
	set directory [AcceptAbsolutePath $directory]
	if {![file exists $directory]} {
	    return -code error "\"$directory\" does not exist"
	}
	if {![file isdir $directory]} {
	    return -code error "\"$directory\" is not a directory"
	}
	return [AcceptReadable $directory]
    }

##### Initialize internal arrays of tcltest, but only if the caller
    # has not already pre-initialized them.  This is done to support
    # compatibility with older tests that directly access internals
    # rather than go through command interfaces.
    #
    proc ArrayDefault {varName value} {
	variable $varName
	if {[array exists $varName]} {
	    return
	}
	if {[info exists $varName]} {
	    # Pre-initialized value is a scalar: destroy it!
	    unset $varName
	}
	array set $varName $value
    }

    # save the original environment so that it can be restored later
    ArrayDefault originalEnv [array get ::env]

    # initialize numTests array to keep track of the number of tests
    # that pass, fail, and are skipped.
    ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]

    # createdNewFiles will store test files as indices and the list of
    # files (that should not have been) left behind by the test files
    # as values.
    ArrayDefault createdNewFiles {}

    # initialize skippedBecause array to keep track of constraints that
    # kept tests from running; a constraint name of "userSpecifiedSkip"
    # means that the test appeared on the list of tests that matched the
    # -skip value given to the flag; "userSpecifiedNonMatch" means that
    # the test didn't match the argument given to the -match flag; both
    # of these constraints are counted only if tcltest::debug is set to
    # true.
    ArrayDefault skippedBecause {}

    # initialize the testConstraints array to keep track of valid
    # predefined constraints (see the explanation for the
    # InitConstraints proc for more details).
    ArrayDefault testConstraints {}

##### Initialize internal variables of tcltest, but only if the caller
    # has not already pre-initialized them.  This is done to support
    # compatibility with older tests that directly access internals
    # rather than go through command interfaces.
    #
    proc Default {varName value {verify AcceptAll}} {
	variable $varName
	if {![info exists $varName]} {
	    variable $varName [$verify $value]
	} else {
	    variable $varName [$verify [set $varName]]
	}
    }

    # Save any arguments that we might want to pass through to other
    # programs.  This is used by the -args flag.
    # FINDUSER
    Default parameters {}

    # Count the number of files tested (0 if runAllTests wasn't called).
    # runAllTests will set testSingleFile to false, so stats will
    # not be printed until runAllTests 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.
    Default numTestFiles 0 AcceptInteger
    Default testSingleFile true AcceptBoolean
    Default currentFailure false AcceptBoolean
    Default failFiles {} AcceptList

    # Tests should remove all files they create.  The test suite will
    # check the current working dir for files created by the tests.
    # filesMade keeps track of such files created using the makeFile and
    # makeDirectory procedures.  filesExisted stores the names of
    # pre-existing files.
    #
    # Note that $filesExisted lists only those files that exist in
    # the original [temporaryDirectory].
    Default filesMade {} AcceptList
    Default filesExisted {} AcceptList
    proc FillFilesExisted {} {
	variable filesExisted

	# Save the names of files that already exist in the scratch directory.
	foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
	    lappend filesExisted [file tail $file]
	}

	# After successful filling, turn this into a no-op.
	proc FillFilesExisted args {}
    }

    # Kept only for compatibility
    Default constraintsSpecified {} AcceptList
    trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
		[array names ::tcltest::testConstraints] ;# }

    # tests that use threads need to know which is the main thread
    Default mainThread 1
    variable mainThread
    if {[info commands thread::id] != {}} {
	set mainThread [thread::id]
    } elseif {[info commands testthread] != {}} {
	set mainThread [testthread id]
    }

    # Set workingDirectory to [pwd]. The default output directory for
    # Tcl tests is the working directory.  Whenever this value changes
    # change to that directory.
    variable workingDirectory
    trace variable workingDirectory w \
	    [namespace code {cd $workingDirectory ;#}]

    Default workingDirectory [pwd] AcceptAbsolutePath
    proc workingDirectory { {dir ""} } {
	variable workingDirectory
	if {[llength [info level 0]] == 1} {
	    return $workingDirectory
	}
	set workingDirectory [AcceptAbsolutePath $dir]
    }

    # Set the location of the execuatble
    Default tcltest [info nameofexecutable]
    trace variable tcltest w [namespace code {testConstraint stdio \
	    [eval [ConstraintInitializer stdio]] ;#}]

    # save the platform information so it can be restored later
    Default originalTclPlatform [array get ::tcl_platform]

    # If a core file exists, save its modification time.
    if {[file exists [file join [workingDirectory] core]]} {
	Default coreModTime \
		[file mtime [file join [workingDirectory] core]]
    }

    # stdout and stderr buffers for use when we want to store them
    Default outData {}
    Default errData {}

    # keep track of test level for nested test commands
    variable testLevel 0

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

    # Internationalization support -- used in [SetIso8859_1_Locale] and
    # [RestoreLocale]. Those commands are used in cmdIL.test.

    if {![info exists [namespace current]::isoLocale]} {
	variable isoLocale fr
	switch -- $::tcl_platform(platform) {
	    "unix" {

		# Try some 'known' values for some platforms:

		switch -exact -- $::tcl_platform(os) {
		    "FreeBSD" {
			set isoLocale fr_FR.ISO_8859-1
		    }
		    HP-UX {
			set isoLocale fr_FR.iso88591
		    }
		    Linux -
		    IRIX {
			set 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 isoLocale iso_8859_1
		    }
		}
	    }
	    "windows" {
		set isoLocale French
	    }
	}
    }

    variable ChannelsWeOpened; array set ChannelsWeOpened {}
    # output goes to stdout by default
    Default outputChannel stdout
    proc outputChannel { {filename ""} } {
	variable outputChannel
	variable ChannelsWeOpened

	# This is very subtle and tricky, so let me try to explain.
	# (Hopefully this longer comment will be clear when I come
	# back in a few months, unlike its predecessor :) )
	# 
	# The [outputChannel]Ľ  Ľ  Ľ  Ľ  Ľ  Ľ  Ľ  Ľ  Ľ  Ľ  Ľ  Ľ  Ľ  Ľ   Ľ  !Ľ  "Ľ  #Ľ  $Ľ  %Ľ  &Ľ  'Ľ  (Ľ  )Ľ  *Ľ  +Ľ  ,Ľ  -Ľ  .Ľ  /Ľ  0Ľ  1Ľ  2Ľ  3Ľ  4Ľ  5Ľ  6Ľ  7Ľ  8Ľ  9Ľ  :Ľ  ;Ľ  <Ľ  =Ľ  >Ľ  ?Ľ  @Ľ  AĽ  BĽ  CĽ  DĽ  EĽ  FĽ  GĽ  HĽ  IĽ  JĽ  KĽ  LĽ  MĽ  NĽ  OĽ  PĽ  QĽ  RĽ  SĽ  TĽ  UĽ  VĽ  WĽ  XĽ  YĽ  ZĽ  [Ľ  \Ľ  ]Ľ  ^Ľ  _Ľ  `Ľ  aĽ  bĽ  cĽ  dĽ  eĽ  fĽ                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               command (and underlying variable) have to
	# be kept in sync with the [configure -outfile] configuration
	# option ( and underlying variable Option(-outfile) ).  This is
	# accomplished with a write trace on Option(-outfile) that will
	# update [outputChannel] whenver a new value is written.  That
	# much is easy.
	#
	# The trick is that in order to maintain compatibility with
	# version 1 of tcltest, we must allow every configuration option
	# to get its inital value from command line arguments.  This is
	# accomplished by setting initial read traces on all the
	# configuration options to parse the command line option the first
	# time they are read.  These traces are cancelled whenever the
	# program itself calls [configure].
	# 
	# OK, then so to support tcltest 1 compatibility, it seems we want
	# to get the return from [outputFile] to trigger the read traces,
	# just in case.
	#
	# BUT!  A little known feature of Tcl variable traces is that 
	# traces are disabled during the handling of other traces.  So,
	# if we trigger read traces on Option(-outfile) and that triggers
	# command line parsing which turns around and sets an initial
	# value for Option(-outfile) -- <whew!> -- the write trace that
	# would keep [outputChannel] in sync with that new initial value
	# would not fire!
	#
	# SO, finally, as a workaround, instead of triggering read traces
	# by invoking [outputFile], we instead trigger the same set of
	# read traces by invoking [debug].  Any command that reads a
	# configuration option would do.  [debug] is just a handy one.
	# The end result is that we support tcltest 1 compatibility and
	# keep outputChannel and -outfile in sync in all cases.
	debug

	if {[llength [info level 0]] == 1} {
	    return $outputChannel
	}
	if {[info exists ChannelsWeOpened($outputChannel)]} {
	    close $outputChannel
	    unset ChannelsWeOpened($outputChannel)
	}
	switch -exact -- $filename {
	    stderr -
	    stdout {
		set outputChannel $filename
	    }
	    default {
		set outputChannel [open $filename a]
		set ChannelsWeOpened($outputChannel) 1

		# If we created the file in [temporaryDirectory], then
		# [cleanupTests] will delete it, unless we claim it was
		# already there.
		set outdir [normalizePath [file dirname \
			[file join [pwd] $filename]]]
		if {[string equal $outdir [temporaryDirectory]]} {
		    variable filesExisted
		    FillFilesExisted
		    set filename [file tail $filename]
		    if {[lsearch -exact $filesExisted $filename] == -1} {
			lappend filesExisted $filename
		    }
		}
	    }
	}
	return $outputChannel
    }

    # errors go to stderr by default
    Default errorChannel stderr
    proc errorChannel { {filename ""} } {
	variable errorChannel
	variable ChannelsWeOpened

	# This is subtle and tricky.  See the comment above in
	# [outputChannel] for a detailed explanation.
	debug

	if {[llength [info level 0]] == 1} {
	    return $errorChannel
	}
	if {[info exists ChannelsWeOpened($errorChannel)]} {
	    close $errorChannel
	    unset ChannelsWeOpened($errorChannel)
	}
	switch -exact -- $filename {
	    stderr -
	    stdout {
		set errorChannel $filename
	    }
	    default {
		set errorChannel [open $filename a]
		set ChannelsWeOpened($errorChannel) 1

		# If we created the file in [temporaryDirectory], then
		# [cleanupTests] will delete it, unless we claim it was
		# already there.
		set outdir [normalizePath [file dirname \
			[file join [pwd] $filename]]]
		if {[string equal $outdir [temporaryDirectory]]} {
		    variable filesExisted
		    FillFilesExisted
		    set filename [file tail $filename]
		    if {[lsearch -exact $filesExisted $filename] == -1} {
			lappend filesExisted $filename
		    }
		}
	    }
	}
	return $errorChannel
    }

##### Set up the configurable options
    #
    # The configurable options of the package
    variable Option; array set Option {}

    # Usage strings for those options
    variable Usage; array set Usage {}

    # Verification commands for those options
    variable Verify; array set Verify {}

    # Initialize the default values of the configurable options that are
    # historically associated with an exported variable.  If that variable
    # is already set, support compatibility by accepting its pre-set value.
    # Use [trace] to establish ongoing connection between the deprecated
    # exported variable and the modern option kept as a true internal var.
    # Also set up usage string and value testing for the option.
    proc Option {option value usage {verify AcceptAll} {varName {}}} {
	variable Option
	variable Verify
	variable Usage
	variable OptionControlledVariables
	set Usage($option) $usage
	set Verify($option) $verify
	if {[catch {$verify $value} msg]} {
	    return -code error $msg
	} else {
	    set Option($option) $msg
	}
	if {[string length $varName]} {
	    variable $varName
	    if {[info exists $varName]} {
		if {[catch {$verify [set $varName]} msg]} {
		    return -code error $msg
		} else {
		    set Option($option) $msg
		}
		unset $varName
	    }
	    namespace eval [namespace current] \
	    	    [list upvar 0 Option($option) $varName]
	    # Workaround for Bug (now Feature Request) 572889.  Grrrr....
	    # Track all the variables tied to options
	    lappend OptionControlledVariables $varName
	    # Later, set auto-configure read traces on all
	    # of them, since a single trace on Option does not work.
	    proc $varName {{value {}}} [subst -nocommands {
		if {[llength [info level 0]] == 2} {
		    Configure $option [set value]
		}
		return [Configure $option]
	    }]
	}
    }

    proc MatchingOption {option} {
	variable Option
	set match [array names Option $option*]
	switch -- [llength $match] {
	    0 {
		set sorted [lsort [array names Option]]
		set values [join [lrange $sorted 0 end-1] ", "]
		append values ", or [lindex $sorted end]"
		return -code error "unknown option $option: should be\
			one of $values"
	    }
	    1 {
		return [lindex $match 0]
	    }
	    default {
		# Exact match trumps ambiguity
		if {[lsearch -exact $match $option] >= 0} {
		    return $option
		}
		set values [join [lrange $match 0 end-1] ", "]
		append values ", or [lindex $match end]"
		return -code error "ambiguous option $option:\
			could match $values"
	    }
	}
    }

    proc EstablishAutoConfigureTraces {} {
	variable OptionControlledVariables
	foreach varName [concat $OptionControlledVariables Option] {
	    variable $varName
	    trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
	}
    }

    proc RemoveAutoConfigureTraces {} {
	variable OptionControlledVariables
	foreach varName [concat $OptionControlledVariables Option] {
	    variable $varName
	    foreach pair [trace vinfo $varName] {
		foreach {op cmd} $pair break
		if {[string equal r $op]
			&& [string match *ProcessCmdLineArgs* $cmd]} {
		    trace vdelete $varName $op $cmd
		}
	    }
	}
	# Once the traces are removed, this can become a no-op
	proc RemoveAutoConfigureTraces {} {}
    }

    proc Configure args {
	variable Option
	variable Verify
	set n [llength $args]
	if {$n == 0} {
	    return [lsort [array names Option]]
	}
	if {$n == 1} {
	    if {[catch {MatchingOption [lindex $args 0]} option]} {
		return -code error $option
	    }
	    return $Option($option)
	}
	while {[llength $args] > 1} {
	    if {[catch {MatchingOption [lindex $args 0]} option]} {
		return -code error $option
	    }
	    if {[catch {$Verify($option) [lindex $args 1]} value]} {
		return -code error "invalid $option\
			value \"[lindex $args 1]\": $value"
	    }
	    set Option($option) $value
	    set args [lrange $args 2 end]
	}
	if {[llength $args]} {
	    if {[catch {MatchingOption [lindex $args 0]} option]} {
		return -code error $option
	    }
	    return -code error "missing value for option $option"
	}
    }
    proc configure args {
	RemoveAutoConfigureTraces
	set code [catch {eval Configure $args} msg]
	return -code $code $msg
    }
    
    proc AcceptVerbose { level } {
	set level [AcceptList $level]
	if {[llength $level] == 1} {
	    if {![regexp {^(pass|body|skip|start|error)$} $level]} {
		# translate single characters abbreviations to expanded list
		set level [string map {p pass b body s skip t start e error} \
			[split $level {}]]
	    }
	}
	set valid [list]
	foreach v $level {
	    if {[regexp {^(pass|body|skip|start|error)$} $v]} {
		lappend valid $v
	    }
	}
	return $valid
    }

    proc IsVerbose {level} {
	variable Option
	return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
    }

    # Default verbosity is to show bodies of failed tests
    Option -verbose {body error} {
	Takes any combination of the values 'p', 's', 'b', 't' and 'e'.
	Test suite will display all passed tests if 'p' is specified, all
	skipped tests if 's' is specified, the bodies of failed tests if
	'b' is specified, and when tests start if 't' is specified.
	ErrorInfo is displayed if 'e' is specified.
    } AcceptVerbose verbose

    # Match and skip patterns default to the empty list, except for
    # matchFiles, which defaults to all .test files in the
    # testsDirectory and matchDirectories, which defaults to all
    # directories.
    Option -match * {
	Run all tests within the specified files that match one of the
	list of glob patterns given.
    } AcceptList match

    Option -skip {} {
	Skip all tests within the specified tests (via -match) and files
	that match one of the list of glob patterns given.
    } AcceptList skip

    Option -file *.test {
	Run tests in all test files that match the glob pattern given.
    } AcceptPattern matchFiles

    # By default, skip files that appear to be SCCS lock files.
    Option -notfile l.*.test {
	Skip all test files that match the glob pattern given.
    } AcceptPattern skipFiles

    Option -relateddir * {
	Run tests in directories that match the glob pattern given.
    } AcceptPattern matchDirectories

    Option -asidefromdir {} {
	Skip tests in directories that match the glob pattern given.
    } AcceptPattern skipDirectories

    # By default, don't save core files
    Option -preservecore 0 {
	If 2, save any core files produced during testing in the directory
	specified by -tmpdir. If 1, notify the user if core files are
	created.
    } AcceptInteger preserveCore

    # 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.
    Option -debug 0 {
	Internal debug level 
    } AcceptInteger debug

    proc SetSelectedConstraints args {
	variable Option
	foreach c $Option(-constraints) {
	    testConstraint $c 1
	}
    }
    Option -constraints {} {
	Do not skip the listed constraints listed in -constraints.
    } AcceptList
    trace variable Option(-constraints) w \
	    [namespace code {SetSelectedConstraints ;#}]

    # Don't run only the "-constraint" specified tests by default
    proc ClearUnselectedConstraints args {
	variable Option
	variable testConstraints
	if {!$Option(-limitconstraints)} {return}
	foreach c [array names testConstraints] {
	    if {[lsearch -exact $Option(-constraints) $c] == -1} {
		testConstraint $c 0
	    }
	}
    }
    Option -limitconstraints false {
	whether to run only tests with the constraints
    } AcceptBoolean limitConstraints 
    trace variable Option(-limitconstraints) w \
	    [namespace code {ClearUnselectedConstraints ;#}]

    # A test application has to know how to load the tested commands
    # into the interpreter.
    Option -load {} {
	Specifies the script to load the tested commands.
    } AcceptScript loadScript

    # Default is to run each test file in a separate process
    Option -singleproc 0 {
	whether to run all tests in one process
    } AcceptBoolean singleProcess 

    proc AcceptTemporaryDirectory { directory } {
	set directory [AcceptAbsolutePath $directory]
	if {![file exists $directory]} {
	    file mkdir $directory
	}
	set directory [AcceptDirectory $directory]
	if {![file writable $directory]} {
	    if {[string equal [workingDirectory] $directory]} {
		# Special exception: accept the default value
		# even if the directory is not writable
		return $directory
	    }
	    return -code error "\"$directory\" is not writeable"
	}
	return $directory
    }

    # Directory where files should be created
    Option -tmpdir [workingDirectory] {
	Save temporary files in the specified directory.
    } AcceptTemporaryDirectory temporaryDirectory
    trace variable Option(-tmpdir) w \
	    [namespace code {normalizePath Option(-tmpdir) ;#}]

    # Tests should not rely on the current working directory.
    # Files that are part of the test suite should be accessed relative
    # to [testsDirectory]
    Option -testdir [workingDirectory] {
	Search tests in the specified directory.
    } AcceptDirectory testsDirectory
    trace variable Option(-testdir) w \
	    [namespace code {normalizePath Option(-testdir) ;#}]

    proc AcceptLoadFile { file } {
	if {[string equal "" $file]} {return $file}
	set file [file join [temporaryDirectory] $file]
	return [AcceptReadable $file]
    }
    proc ReadLoadScript {args} {
	variable Option
	if {[string equal "" $Option(-loadfile)]} {return}
	set tmp [open $Option(-loadfile) r]
	loadScript [read $tmp]
	close $tmp
    }
    Option -loadfile {} {
	Read the script to load the tested commands from the specified file.
    } AcceptLoadFile loadFile
    trace variable Option(-loadfile) w [namespace code ReadLoadScript]

    proc AcceptOutFile { file } {
	if {[string equal stderr $file]} {return $file}
	if {[string equal stdout $file]} {return $file}
	return [file join [temporaryDirectory] $file]
    }

    # output goes to stdout by default
    Option -outfile stdout {
	Send output from test runs to the specified file.
    } AcceptOutFile outputFile
    trace variable Option(-outfile) w \
	    [namespace code {outputChannel $Option(-outfile) ;#}]

    # errors go to stderr by default
    Option -errfile stderr {
	Send errors from test runs to the specified file.
    } AcceptOutFile errorFile
    trace variable Option(-errfile) w \
	    [namespace code {errorChannel $Option(-errfile) ;#}]

}

#####################################################################

# 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.
#
# Side Effects:
#     None.
#

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

# 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.
#
# Side Effects:
#     None.
#

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

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

# Define our own [parray] in ::tcltest that will inherit use of the [puts]
# defined in ::tcltest.  NOTE: Ought to construct with [info args] and
# [info default], but can't be bothered now.  If [parray] changes, then
# this will need changing too.
auto_load ::parray
proc tcltest::parray {a {pattern *}} [info body ::parray]

# 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.
#
# Side Effects:
#     None.
#

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

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

#####################################################################

proc tcltest::Warn {msg} {
    puts [outputChannel] "WARNING: $msg"
}

# tcltest::mainThread
#
#     Accessor command for tcltest variable mainThread.
#
proc tcltest::mainThread { {new ""} } {
    variable mainThread
    if {[llength [info level 0]] == 1} {
	return $mainThread
    }
    set mainThread $new
}

# tcltest::testConstraint --
#
#	sets a test constraint to a value; to do multiple constraints,
#       call this proc multiple times.  also returns the value of the
#       named constraint if no value was supplied.
#
# Arguments:
#	constraint - name of the constraint
#       value - new value for constraint (should be boolean) - if not
#               supplied, this is a query
#
# Results:
#	content of tcltest::testConstraints($constraint)
#
# Side effects:
#	none

proc tcltest::testConstraint {constraint {value ""}} {
    variable testConstraints
    variable Option
    DebugPuts 3 "entering testConstraint $constraint $value"
    if {[llength [info level 0]] == 2} {
	return $testConstraints($constraint)
    }
    # Check for boolean values
    if {[catch {expr {$value && $value}} msg]} {
	return -code error $msg
    }
    if {[limitConstraints] 
	    && [lsearch -exact $Option(-constraints) $constraint] == -1} {
	set value 0
    }
    set testConstraints($constraint) $value
}

# tcltest::interpreter --
#
#	the interpreter name stored in tcltest::tcltest
#
# Arguments:
#	executable name
#
# Results:
#	content of tcltest::tcltest
#
# Side effects:
#	None.

proc tcltest::interpreter { {interp ""} } {
    variable tcltest
    if {[llength [info level 0]] == 1} {
	return $tcltest
    }
    if {[string equal {} $interp]} {
	set tcltest {}
    } else {
	set tcltest $interp
    }
}

#####################################################################

# tcltest::AddToSkippedBecause --
#
#	Increments the variable used to track how many tests were
#       skipped because of a particular constraint.
#
# Arguments:
#	constraint     The name of the constraint to be modified
#
# Results:
#	Modifies tcltest::skippedBecause; sets the variable to 1 if
#       didn't previously exist - otherwise, it just increments it.
#
# Side effects:
#	None.

proc tcltest::AddToSkippedBecause { constraint {value 1}} {
    # add the constraint to the list of constraints that kept tests
    # from running
    variable skippedBecause

    if {[info exists skippedBecause($constraint)]} {
	incr skippedBecause($constraint) $value
    } else {
	set skippedBecause($constraint) $value
    }
    return
}

# tcltest::PrintError --
#
#	Prints errors to tcltest::errorChannel and then flushes that
#       channel, making sure that all messages are < 80 characters per
#       line.
#
# Arguments:
#	errorMsg     String containing the error to be printed
#
# Results:
#	None.
#
# Side effects:
#	None.

proc tcltest::PrintError {errorMsg} {
    set InitialMessage "Error:  "
    set InitialMsgLen  [string length $InitialMessage]
    puts -nonewline [errorChannel] $InitialMessage

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

    if {$endingIndex < (80 - $InitialMsgLen)} {
	puts [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 [errorChannel] [string range $errorMsg 0 $beginningIndex]

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

# tcltest::SafeFetch --
#
#	 The following trace procedure makes it so that we can safely
#        refer to non-existent members of the testConstraints array
#        without causing an error.  Instead, reading a non-existent
#        member will return 0. This is necessary because tests are
#        allowed to use constraint "X" without ensuring that
#        testConstraints("X") is defined.
#
# Arguments:
#	n1 - name of the array (testConstraints)
#       n2 - array key value (constraint name)
#       op - operation performed on testConstraints (generally r)
#
# Results:
#	none
#
# Side effects:
#	sets testConstraints($n2) to 0 if it's referenced but never
#       before used

proc tcltest::SafeFetch {n1 n2 op} {
    variable testConstraints
    DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
    if {[string equal {} $n2]} {return}
    if {![info exists testConstraints($n2)]} {
	if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
	    testConstraint $n2 0
	}
    }
}

# tcltest::ConstraintInitializer --
#
#	Get or set a script that when evaluated in the tcltest namespace
#	will return a boolean value with which to initialize the
#	associated constraint.
#
# Arguments:
#	constraint - name of the constraint initialized by the script
#	script - the initializer script
#
# Results
#	boolean value of the constraint - enabled or disabled
#
# Side effects:
#	Constraint is initialized for future reference by [test]
proc tcltest::ConstraintInitializer {constraint {script ""}} {
    variable ConstraintInitializer
    DebugPuts 3 "entering ConstraintInitializer $constraint $script"
    if {[llength [info level 0]] == 2} {
	return $ConstraintInitializer($constraint)
    }
    # Check for boolean values
    if {![info complete $script]} {
	return -code error "ConstraintInitializer must be complete script"
    }
    set ConstraintInitializer($constraint) $script
}

# tcltest::InitConstraints --
#
# Call all registered constraint initializers to force initialization
# of all known constraints.
# See the tcltest man page for the list of built-in constraints defined
# in this procedure.
#
# Arguments:
#	none
#
# Results:
#	The testConstraints array is reset to have an index for each
#	built-in test constraint.
#
# Side Effects:
#       None.
#

proc tcltest::InitConstraints {} {
    variable ConstraintInitializer
    initConstraintsHook
    foreach constraint [array names ConstraintInitializer] {
	testConstraint $constraint
    }
}

proc tcltest::DefineConstraintInitializers {} {
    ConstraintInitializer singleTestInterp {singleProcess}

    # All the 'pc' constraints are here for backward compatibility and
    # are not documented.  They have been replaced with equivalent 'win'
    # constraints.

    ConstraintInitializer unixOnly \
	    {string equal $::tcl_platform(platform) unix}
    ConstraintInitializer macOnly \
	    {string equal $::tcl_platform(platform) macintosh}
    ConstraintInitializer pcOnly \
	    {string equal $::tcl_platform(platform) windows}
    ConstraintInitializer winOnly \
	    {string equal $::tcl_platform(platform) windows}

    ConstraintInitializer unix {testConstraint unixOnly}
    ConstraintInitializer mac {testConstraint macOnly}
    ConstraintInitializer pc {testConstraint pcOnly}
    ConstraintInitializer win {testConstraint winOnly}

    ConstraintInitializer unixOrPc \
	    {expr {[testConstraint unix] || [testConstraint pc]}}
    ConstraintInitializer macOrPc \
	    {expr {[testConstraint mac] || [testConstraint pc]}}
    ConstraintInitializer unixOrWin \
	    {expr {[testConstraint unix] || [testConstraint win]}}
    ConstraintInitializer macOrWin \
	    {expr {[testConstraint mac] || [testConstraint win]}}
    ConstraintInitializer macOrUnix \
	    {expr {[testConstraint mac] || [testConstraint unix]}}

    ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
    ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
    ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}

    # The following Constraints switches are used to mark tests that
    # should work, but have been temporarily disabled on certain
    # platforms because they don't and we haven't gotten around to
    # fixing the underlying problem.

    ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
    ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
    ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
    ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}

    # The following Constraints switches are used to mark tests that
    # crash on certain platforms, so that they can be reactivated again
    # when the underlying problem is fixed.

    ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
    ConstraintInitializer winCrash {expr {![testConstraint win]}}
    ConstraintInitializer macCrash {expr {![testConstraint mac]}}
    ConstraintInitializer unixCrash {expr {![testConstraint unix]}}

    # Skip empty tests

    ConstraintInitializer emptyTest {format 0}

    # By default, tests that expose known bugs are skipped.

    ConstraintInitializer knownBug {format 0}

    # By default, non-portable tests are skipped.

    ConstraintInitializer nonPortable {format 0}

    # Some tests require user interaction.

    ConstraintInitializer userInteraction {format 0}

    # Some tests must be skipped if the interpreter is not in
    # interactive mode

    ConstraintInitializer interactive \
	    {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}

    # Some tests can only be run if the installation came from a CD
    # image instead of a web image.  Some tests must be skipped if you
    # are running as root on Unix.  Other tests can only be run if you
    # are running as root on Unix.

    ConstraintInitializer root {expr \
	    {[string equal unix $::tcl_platform(platform)]
	    && ([string equal root $::tcl_platform(user)]
		|| [string equal "" $::tcl_platform(user)])}}
    ConstraintInitializer notRoot {expr {![testConstraint root]}}

    # Set nonBlockFiles constraint: 1 means this platform supports
    # setting files into nonblocking mode.

    ConstraintInitializer nonBlockFiles {
	    set code [expr {[catch {set f [open defs r]}] 
		    || [catch {fconfigure $f -blocking off}]}]
	    catch {close $f}
	    set code
    }

    # Set asyncPipeClose constraint: 1 means this platform supports
    # async flush and async close on a pipe.
    #
    # Test for SCO Unix - cannot run async flushing tests because a
    # potential problem with select is apparently interfering.
    # (Mark Diekhans).

    ConstraintInitializer asyncPipeClose {expr {
	    !([string equal unix $::tcl_platform(platform)] 
	    && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}

    # Test to see if we have a broken version of sprintf with respect
    # to the "e" format of floating-point numbers.

    ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}

    # Test to see if execed commands such as cat, echo, rm and so forth
    # are present on this machine.

    ConstraintInitializer unixExecs {
	set code 1
        if {[string equal macintosh $::tcl_platform(platform)]} {
	    set code 0
        }
        if {[string equal windows $::tcl_platform(platform)]} {
	    if {[catch {
	        set file _tcl_test_remove_me.txt
	        makeFile {hello} $file
	    }]} {
	        set code 0
	    } elseif {
	        [catch {exec cat $file}] ||
	        [catch {exec echo hello}] ||
	        [catch {exec sh -c echo hello}] ||
	        [catch {exec wc $file}] ||
	        [catch {exec sleep 1}] ||
	        [catch {exec echo abc > $file}] ||
	        [catch {exec chmod 644 $file}] ||
	        [catch {exec rm $file}] ||
	        [llength [auto_execok mkdir]] == 0 ||
	        [llength [auto_execok fgrep]] == 0 ||
	        [llength [auto_execok grep]] == 0 ||
	        [llength [auto_execok ps]] == 0
	    } {
	        set code 0
	    }
	    removeFile $file
        }
	set code
    }

    ConstraintInitializer stdio {
	set code 0
	if {![catch {set f [open "|[list [interpreter]]" w]}]} {
	    if {![catch {puts $f exit}]} {
		if {![catch {close $f}]} {
		    set code 1
		}
	    }
	}
	set code
    }

    # Deliberately call socket with the wrong number of arguments.  The
    # error message you get will indicate whether sockets are available
    # on this system.

    ConstraintInitializer socket {
	catch {socket} msg
	string compare $msg "sockets are not available on this system"
    }

    # Check for internationalization
    ConstraintInitializer hasIsoLocale {
	if {[llength [info commands testlocale]] == 0} {
	    set code 0
	} else {
	    set code [string length [SetIso8859_1_Locale]]
	    RestoreLocale
	}
	set code
    }

}
#####################################################################

# Usage and command line arguments processing.

# tcltest::PrintUsageInfo
#
#	Prints out the usage information for package tcltest.  This can
#	be customized with the redefinition of [PrintUsageInfoHook].
#
# Arguments:
#	none
#
# Results:
#       none
#
# Side Effects:
#       none
proc tcltest::PrintUsageInfo {} {
    puts [Usage]
    PrintUsageInfoHook
}

proc tcltest::Usage { {option ""} } {
    variable Usage
    variable Verify
    if {[llength [info level 0]] == 1} {
	set msg "Usage: [file tail [info nameofexecutable]] script "
	append msg "?-help? ?flag value? ... \n"
	append msg "Available flags (and valid input values) are:"

	set max 0
	set allOpts [concat -help [Configure]]
	foreach opt $allOpts {
	    set foo [Usage $opt]
	    foreach [list x type($opt) usage($opt)] $foo break
	    set line($opt) "  $opt $type($opt)  "
	    set length($opt) [string length $line($opt)]
	    if {$length($opt) > $max} {set max $length($opt)}
	}
	set rest [expr {72 - $max}]
	foreach opt $allOpts {
	    append msg \n$line($opt)
	    append msg [string repeat " " [expr {$max - $length($opt)}]]
	    set u [string trim $usage($opt)]
	    catch {append u "  (default: \[[Configure $opt]])"}
	    regsub -all {\s*\n\s*} $u " " u
	    while {[string length $u] > $rest} {
		set break [string wordstart $u $rest]
		if {$break == 0} {
		    set break [string wordend $u 0]
		}
		append msg [string range $u 0 [expr {$break - 1}]]
		set u [string trim [string range $u $break end]]
		append msg \n[string repeat " " $max]
	    }
	    append msg $u
	}
	return $msg\n
    } elseif {[string equal -help $option]} {
	return [list -help "" "Display this usage information."]
    } else {
	set type [lindex [info args $Verify($option)] 0]
	return [list $option $type $Usage($option)]
    }
}

# tcltest::ProcessFlags --
#
#	process command line arguments supplied in the flagArray - this
#	is called by processCmdLineArgs.  Modifies tcltest variables
#	according to the content of the flagArray.
#
# Arguments:
#	flagArray - array containing name/value pairs of flags
#
# Results:
#	sets tcltest variables according to their values as defined by
#       flagArray
#
# Side effects:
#	None.

proc tcltest::ProcessFlags {flagArray} {
    # Process -help first
    if {[lsearch -exact $flagArray {-help}] != -1} {
	PrintUsageInfo
	exit 1
    }

    if {[llength $flagArray] == 0} {
	RemoveAutoConfigureTraces
    } else {
	set args $flagArray
	while {[llength $args]>1 && [catch {eval configure $args} msg]} {

	    # Something went wrong parsing $args for tcltest options
	    # Check whether the problem is "unknown option"
	    if {[regexp {^unknown option (\S+):} $msg -> option]} {
		# Could be this is an option the Hook knows about
		set moreOptions [processCmdLineArgsAddFlagsHook]
		if {[lsearch -exact $moreOptions $option] == -1} {
		    # Nope.  Report the error, including additional options,
		    # but keep going
		    if {[llength $moreOptions]} {
			append msg ", "
			append msg [join [lrange $moreOptions 0 end-1] ", "]
			append msg "or [lindex $moreOptions end]"
		    }
		    Warn $msg
		}
	    } else {
		# error is something other than "unknown option"
		# notify user of the error; and exit
		puts [errorChannel] $msg
		exit 1
	    }

	    # To recover, find that unknown option and remove up to it.
	    # then retry
	    while {![string equal [lindex $args 0] $option]} {
		set args [lrange $args 2 end]
	    }
	    set args [lrange $args 2 end]
	}
	if {[llength $args] == 1} {
	    puts [errorChannel] \
		    "missing value for option [lindex $args 0]"
	    exit 1
	}
    }

    # Call the hook
    catch {
        array set flag $flagArray
        processCmdLineArgsHook [array get flag]
    }
    return
}

# tcltest::ProcessCmdLineArgs --
#
#       This procedure must be run after constraint initialization is
#	set up (by [DefineConstraintInitializers]) because some constraints
#	can be overridden.
#
#       Perform configuration according to the command-line options.
#
# Arguments:
#	none
#
# Results:
#	Sets the above-named variables in the tcltest namespace.
#
# Side Effects:
#       None.
#

proc tcltest::ProcessCmdLineArgs {} {
    variable originalEnv
    variable testConstraints

    # The "argv" var doesn't exist in some cases, so use {}.
    if {![info exists ::argv]} {
	ProcessFlags {}
    } else {
	ProcessFlags $::argv
    }

    # Spit out everything you know if we're at a debug level 2 or
    # greater
    DebugPuts 2 "Flags passed into tcltest:"
    if {[info exists ::env(TCLTEST_OPTIONS)]} {
	DebugPuts 2 \
		"    ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
    }
    if {[info exists ::argv]} {
	DebugPuts 2 "    argv: $::argv"
    }
    DebugPuts    2 "tcltest::debug              = [debug]"
    DebugPuts    2 "tcltest::testsDirectory     = [testsDirectory]"
    DebugPuts    2 "tcltest::workingDirectory   = [workingDirectory]"
    DebugPuts    2 "tcltest::temporaryDirectory = [temporaryDirectory]"
    DebugPuts    2 "tcltest::outputChannel      = [outputChannel]"
    DebugPuts    2 "tcltest::errorChannel       = [errorChannel]"
    DebugPuts    2 "Original environment (tcltest::originalEnv):"
    DebugPArray  2 originalEnv
    DebugPuts    2 "Constraints:"
    DebugPArray  2 testConstraints
}

#####################################################################

# Code to run the tests goes here.

# tcltest::TestPuts --
#
#	Used to redefine puts in test environment.  Stores whatever goes
#	out on stdout in tcltest::outData and stderr in errData before
#	sending it on to the regular puts.
#
# Arguments:
#	same as standard puts
#
# Results:
#	none
#
# Side effects:
#       Intercepts puts; data that would otherwise go to stdout, stderr,
#	or file channels specified in outputChannel and errorChannel
#	does not get sent to the normal puts function.
namespace eval tcltest::Replace {
    namespace export puts
}
proc tcltest::Replace::puts {args} {
    variable [namespace parent]::outData
    variable [namespace parent]::errData
    switch [llength $args] {
	1 {
	    # Only the string to be printed is specified
	    append outData [lindex $args 0]\n
	    return
	    # return [Puts [lindex $args 0]]
	}
	2 {
	    # Either -nonewline or channelId has been specified
	    if {[string equal -nonewline [lindex $args 0]]} {
		append outData [lindex $args end]
		return
		# return [Puts -nonewline [lindex $args end]]
	    } else {
		set channel [lindex $args 0]
		set newline \n
	    }
	}
	3 {
	    if {[string equal -nonewline [lindex $args 0]]} {
		# Both -nonewline and channelId are specified, unless
		# it's an error.  -nonewline is supposed to be argv[0].
		set channel [lindex $args 1]
		set newline ""
	    }
	}
    }

    if {[info exists channel]} {
	if {[string equal $channel [[namespace parent]::outputChannel]]
		|| [string equal $channel stdout]} {
	    append outData [lindex $args end]$newline
	    return
	} elseif {[string equal $channel [[namespace parent]::errorChannel]]
		|| [string equal $channel stderr]} {
	    append errData [lindex $args end]$newline
	    return
	}
    }

    # If we haven't returned by now, we don't know how to handle the
    # input.  Let puts handle it.
    return [eval Puts $args]
}

# tcltest::Eval --
#
#	Evaluate the script in the test environment.  If ignoreOutput is
#       false, store data sent to stderr and stdout in outData and
#       errData.  Otherwise, ignore this output altogether.
#
# Arguments:
#	script             Script to evaluate
#       ?ignoreOutput?     Indicates whether or not to ignore output
#			   sent to stdout & stderr
#
# Results:
#	result from running the script
#
# Side effects:
#	Empties the contents of outData and errData before running a
#	test if ignoreOutput is set to 0.

proc tcltest::Eval {script {ignoreOutput 1}} {
    variable outData
    variable errData
    DebugPuts 3 "[lindex [info level 0] 0] called"
    if {!$ignoreOutput} {
	set outData {}
	set errData {}
	rename ::puts [namespace current]::Replace::Puts
	namespace eval :: \
		[list namespace import [namespace origin Replace::puts]]
	namespace import Replace::puts
    }
    set result [uplevel 1 $script]
    if {!$ignoreOutput} {
	namespace forget puts
	namespace eval :: namespace forget puts
	rename [namespace current]::Replace::Puts ::puts
    }
    return $result
}

# tcltest::CompareStrings --
#
#	compares the expected answer to the actual answer, depending on
#	the mode provided.  Mode determines whether a regexp, exact,
#	glob or custom comparison is done.
#
# Arguments:
#	actual - string containing the actual result
#       expected - pattern to be matched against
#       mode - type of comparison to be done
#
# Results:
#	result of the match
#
# Side effects:
#	None.

proc tcltest::CompareStrings {actual expected mode} {
    variable CustomMatch
    if {![info exists CustomMatch($mode)]} {
        return -code error "No matching command registered for `-match $mode'"
    }
    set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
    if {[catch {expr {$match && $match}} result]} {
	return -code error "Invalid result from `-match $mode' command: $result"
    }
    return $match
}

# tcltest::customMatch --
#
#	registers a command to be called when a particular type of
#	matching is required.
#
# Arguments:
#	nickname - Keyword for the type of matching
#	cmd - Incomplete command that implements that type of matching
#		when completed with expected string and actual string
#		and then evaluated.
#
# Results:
#	None.
#
# Side effects:
#	Sets the variable tcltest::CustomMatch

proc tcltest::customMatch {mode script} {
    variable CustomMatch
    if {![info complete $script]} {
	return -code error \
		"invalid customMatch script; can't evaluate after completion"
    }
    set CustomMatch($mode) $script
}

# tcltest::SubstArguments list
#
# This helper function takes in a list of words, then perform a
# substitution on the list as though each word in the list is a separate
# argument to the Tcl function.  For example, if this function is
# invoked as:
#
#      SubstArguments {$a {$a}}
#
# Then it is as though the function is invoked as:
#
#      SubstArguments $a {$a}
#
# This code is adapted from Paul Duffin's function "SplitIntoWords".
# The original function can be found  on:
#
#      http://purl.org/thecliff/tcl/wiki/858.html
#
# Results:
#     a list containing the result of the substitution
#
# Exceptions:
#     An error may occur if the list containing unbalanced quote or
#     unknown variable.
#
# Side Effects:
#     None.
#

proc tcltest::SubstArguments {argList} {

    # We need to split the argList up into tokens but cannot use list
    # operations as they throw away some significant quoting, and
    # [split] ignores braces as it should.  Therefore what we do is
    # gradually build up a string out of whitespace seperated strings.
    # We cannot use [split] to split the argList into whitespace
    # separated strings as it throws away the whitespace which maybe
    # important so we have to do it all by hand.

    set result {}
    set token ""

    while {[string length $argList]} {
        # Look for the next word containing a quote: " { }
        if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
		$argList all]} {
            # Get the text leading up to this word, but not including
	    # this word, from the argList.
            set text [string range $argList 0 \
		    [expr {[lindex $all 0] - 1}]]
            # Get the word with the quote
            set word [string range $argList \
                    [lindex $all 0] [lindex $all 1]]

            # Remove all text up to and including the word from the
            # argList.
            set argList [string range $argList \
                    [expr {[lindex $all 1] + 1}] end]
        } else {
            # Take everything up to the end of the argList.
            set text $argList
            set word {}
            set argList {}
        }

        if {$token != {}} {
            # If we saw a word with quote before, then there is a
            # multi-word token starting with that word.  In this case,
            # add the text and the current word to this token.
            append token $text $word
        } else {
            # Add the text to the result.  There is no need to parse
            # the text because it couldn't be a part of any multi-word
            # token.  Then start a new multi-word token with the word
            # because we need to pass this token to the Tcl parser to
            # check for balancing quotes
            append result $text
            set token $word
        }

        if { [catch {llength $token} length] == 0 && $length == 1} {
            # The token is a valid list so add it to the result.
            # lappend result [string trim $token]
            append result \{$token\}
            set token {}
        }
    }

    # If the last token has not been added to the list then there
    # is a problem.
    if { [string length $token] } {
        error "incomplete token \"$token\""
    }

    return $result
}


# tcltest::test --
#
# This procedure runs a test and prints an error message if the test
# fails.  If 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
# match variable, if it matches an element in skip, or if one of the
# elements of "constraints" turns out not to be true.
#
# If testLevel is 1, then this is a top level test, and we record
# pass/fail information; otherwise, this information is not logged and
# is not added to running totals.
#
# Attributes:
#   Only description is a required attribute.  All others are optional.
#   Default values are indicated.
#
#   constraints -	A list of one or more keywords, each of which
#			must be the name of an element in the array
#			"testConstraints".  If any of these elements is
#			zero, the test is skipped. This attribute is
#			optional; default is {}
#   body -	        Script to run to carry out the test.  It must
#		        return a result that can be checked for
#		        correctness.  This attribute is optional;
#                       default is {}
#   result -	        Expected result from script.  This attribute is
#                       optional; default is {}.
#   output -            Expected output sent to stdout.  This attribute
#                       is optional; default is {}.
#   errorOutput -       Expected output sent to stderr.  This attribute
#                       is optional; default is {}.
#   returnCodes -       Expected return codes.  This attribute is
#                       optional; default is {0 2}.
#   setup -             Code to run before $script (above).  This
#                       attribute is optional; default is {}.
#   cleanup -           Code to run after $script (above).  This
#                       attribute is optional; default is {}.
#   match -             specifies type of matching to do on result,
#                       output, errorOutput; this must be a string
#			previously registered by a call to [customMatch].
#			The strings exact, glob, and regexp are pre-registered
#			by the tcltest package.  Default value is exact.
#
# 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.
#
# Results:
#	None.
#
# Side effects:
#       Just about anything is possible depending on the test.
#

proc tcltest::test {name description args} {
    global tcl_platform
    variable testLevel
    variable coreModTime
    DebugPuts 3 "test $name $args"
    DebugDo 1 {
	variable TestNames
	catch {
	    puts "test name '$name' re-used; prior use in $TestNames($name)"
	}
	set TestNames($name) [info script]
    }

    FillFilesExisted
    incr testLevel

    # Pre-define everything to null except output and errorOutput.  We
    # determine whether or not to trap output based on whether or not
    # these variables (output & errorOutput) are defined.
    foreach item {constraints setup cleanup body result returnCodes
	    match} {
	set $item {}
    }

    # Set the default match mode
    set match exact

    # Set the default match values for return codes (0 is the standard
    # expected return value if everything went well; 2 represents
    # 'return' being used in the test script).
    set returnCodes [list 0 2]

    # The old test format can't have a 3rd argument (constraints or
    # script) that starts with '-'.
    if {[string match -* [lindex $args 0]]
	    || ([llength $args] <= 1)} {
	if {[llength $args] == 1} {
	    set list [SubstArguments [lindex $args 0]]
	    foreach {element value} $list {
		set testAttributes($element) $value
	    }
	    foreach item {constraints match setup body cleanup \
		    result returnCodes output errorOutput} {
		if {[info exists testAttributes(-$item)]} {
		    set testAttributes(-$item) [uplevel 1 \
			    ::concat $testAttributes(-$item)]
		}
	    }
	} else {
	    array set testAttributes $args
	}

	set validFlags {-setup -cleanup -body -result -returnCodes \
		-match -output -errorOutput -constraints}

	foreach flag [array names testAttributes] {
	    if {[lsearch -exact $validFlags $flag] == -1} {
		incr testLevel -1
		set sorted [lsort $validFlags]