"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tltcl/lib/tcl8/8.5/tcltest-2.5.1.tm" (17 Mar 2020, 101498 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 # tcltest.tcl --
    2 #
    3 #	This file contains support code for the Tcl test suite.  It
    4 #       defines the tcltest namespace and finds and defines the output
    5 #       directory, constraints available, output and error channels,
    6 #	etc. used by Tcl tests.  See the tcltest man page for more
    7 #	details.
    8 #
    9 #       This design was based on the Tcl testing approach designed and
   10 #       initially implemented by Mary Ann May-Pumphrey of Sun
   11 #	Microsystems.
   12 #
   13 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
   14 # Copyright (c) 1998-1999 by Scriptics Corporation.
   15 # Copyright (c) 2000 by Ajuba Solutions
   16 # Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
   17 # All rights reserved.
   18 
   19 package require Tcl 8.5-		;# -verbose line uses [info frame]
   20 namespace eval tcltest {
   21 
   22     # When the version number changes, be sure to update the pkgIndex.tcl file,
   23     # and the install directory in the Makefiles.  When the minor version
   24     # changes (new feature) be sure to update the man page as well.
   25     variable Version 2.5.1
   26 
   27     # Compatibility support for dumb variables defined in tcltest 1
   28     # Do not use these.  Call [package provide Tcl] and [info patchlevel]
   29     # yourself.  You don't need tcltest to wrap it for you.
   30     variable version [package provide Tcl]
   31     variable patchLevel [info patchlevel]
   32 
   33 ##### Export the public tcltest procs; several categories
   34     #
   35     # Export the main functional commands that do useful things
   36     namespace export cleanupTests loadTestedCommands makeDirectory \
   37 	makeFile removeDirectory removeFile runAllTests test
   38 
   39     # Export configuration commands that control the functional commands
   40     namespace export configure customMatch errorChannel interpreter \
   41 	    outputChannel testConstraint
   42 
   43     # Export commands that are duplication (candidates for deprecation)
   44     namespace export bytestring		;# dups [encoding convertfrom identity]
   45     namespace export debug		;#	[configure -debug]
   46     namespace export errorFile		;#	[configure -errfile]
   47     namespace export limitConstraints	;#	[configure -limitconstraints]
   48     namespace export loadFile		;#	[configure -loadfile]
   49     namespace export loadScript		;#	[configure -load]
   50     namespace export match		;#	[configure -match]
   51     namespace export matchFiles		;#	[configure -file]
   52     namespace export matchDirectories	;#	[configure -relateddir]
   53     namespace export normalizeMsg	;#	application of [customMatch]
   54     namespace export normalizePath	;#	[file normalize] (8.4)
   55     namespace export outputFile		;#	[configure -outfile]
   56     namespace export preserveCore	;#	[configure -preservecore]
   57     namespace export singleProcess	;#	[configure -singleproc]
   58     namespace export skip		;#	[configure -skip]
   59     namespace export skipFiles		;#	[configure -notfile]
   60     namespace export skipDirectories	;#	[configure -asidefromdir]
   61     namespace export temporaryDirectory	;#	[configure -tmpdir]
   62     namespace export testsDirectory	;#	[configure -testdir]
   63     namespace export verbose		;#	[configure -verbose]
   64     namespace export viewFile		;#	binary encoding [read]
   65     namespace export workingDirectory	;#	[cd] [pwd]
   66 
   67     # Export deprecated commands for tcltest 1 compatibility
   68     namespace export getMatchingFiles mainThread restoreState saveState \
   69 	    threadReap
   70 
   71     # tcltest::normalizePath --
   72     #
   73     #     This procedure resolves any symlinks in the path thus creating
   74     #     a path without internal redirection. It assumes that the
   75     #     incoming path is absolute.
   76     #
   77     # Arguments
   78     #     pathVar - name of variable containing path to modify.
   79     #
   80     # Results
   81     #     The path is modified in place.
   82     #
   83     # Side Effects:
   84     #     None.
   85     #
   86     proc normalizePath {pathVar} {
   87 	upvar 1 $pathVar path
   88 	set oldpwd [pwd]
   89 	catch {cd $path}
   90 	set path [pwd]
   91 	cd $oldpwd
   92 	return $path
   93     }
   94 
   95 ##### Verification commands used to test values of variables and options
   96     #
   97     # Verification command that accepts everything
   98     proc AcceptAll {value} {
   99 	return $value
  100     }
  101 
  102     # Verification command that accepts valid Tcl lists
  103     proc AcceptList { list } {
  104 	return [lrange $list 0 end]
  105     }
  106 
  107     # Verification command that accepts a glob pattern
  108     proc AcceptPattern { pattern } {
  109 	return [AcceptAll $pattern]
  110     }
  111 
  112     # Verification command that accepts integers
  113     proc AcceptInteger { level } {
  114 	return [incr level 0]
  115     }
  116 
  117     # Verification command that accepts boolean values
  118     proc AcceptBoolean { boolean } {
  119 	return [expr {$boolean && $boolean}]
  120     }
  121 
  122     # Verification command that accepts (syntactically) valid Tcl scripts
  123     proc AcceptScript { script } {
  124 	if {![info complete $script]} {
  125 	    return -code error "invalid Tcl script: $script"
  126 	}
  127 	return $script
  128     }
  129 
  130     # Verification command that accepts (converts to) absolute pathnames
  131     proc AcceptAbsolutePath { path } {
  132 	return [file join [pwd] $path]
  133     }
  134 
  135     # Verification command that accepts existing readable directories
  136     proc AcceptReadable { path } {
  137 	if {![file readable $path]} {
  138 	    return -code error "\"$path\" is not readable"
  139 	}
  140 	return $path
  141     }
  142     proc AcceptDirectory { directory } {
  143 	set directory [AcceptAbsolutePath $directory]
  144 	if {![file exists $directory]} {
  145 	    return -code error "\"$directory\" does not exist"
  146 	}
  147 	if {![file isdir $directory]} {
  148 	    return -code error "\"$directory\" is not a directory"
  149 	}
  150 	return [AcceptReadable $directory]
  151     }
  152 
  153 ##### Initialize internal arrays of tcltest, but only if the caller
  154     # has not already pre-initialized them.  This is done to support
  155     # compatibility with older tests that directly access internals
  156     # rather than go through command interfaces.
  157     #
  158     proc ArrayDefault {varName value} {
  159 	variable $varName
  160 	if {[array exists $varName]} {
  161 	    return
  162 	}
  163 	if {[info exists $varName]} {
  164 	    # Pre-initialized value is a scalar: destroy it!
  165 	    unset $varName
  166 	}
  167 	array set $varName $value
  168     }
  169 
  170     # save the original environment so that it can be restored later
  171     ArrayDefault originalEnv [array get ::env]
  172 
  173     # initialize numTests array to keep track of the number of tests
  174     # that pass, fail, and are skipped.
  175     ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
  176 
  177     # createdNewFiles will store test files as indices and the list of
  178     # files (that should not have been) left behind by the test files
  179     # as values.
  180     ArrayDefault createdNewFiles {}
  181 
  182     # initialize skippedBecause array to keep track of constraints that
  183     # kept tests from running; a constraint name of "userSpecifiedSkip"
  184     # means that the test appeared on the list of tests that matched the
  185     # -skip value given to the flag; "userSpecifiedNonMatch" means that
  186     # the test didn't match the argument given to the -match flag; both
  187     # of these constraints are counted only if tcltest::debug is set to
  188     # true.
  189     ArrayDefault skippedBecause {}
  190 
  191     # initialize the testConstraints array to keep track of valid
  192     # predefined constraints (see the explanation for the
  193     # InitConstraints proc for more details).
  194     ArrayDefault testConstraints {}
  195 
  196 ##### Initialize internal variables of tcltest, but only if the caller
  197     # has not already pre-initialized them.  This is done to support
  198     # compatibility with older tests that directly access internals
  199     # rather than go through command interfaces.
  200     #
  201     proc Default {varName value {verify AcceptAll}} {
  202 	variable $varName
  203 	if {![info exists $varName]} {
  204 	    variable $varName [$verify $value]
  205 	} else {
  206 	    variable $varName [$verify [set $varName]]
  207 	}
  208     }
  209 
  210     # Save any arguments that we might want to pass through to other
  211     # programs.  This is used by the -args flag.
  212     # FINDUSER
  213     Default parameters {}
  214 
  215     # Count the number of files tested (0 if runAllTests wasn't called).
  216     # runAllTests will set testSingleFile to false, so stats will
  217     # not be printed until runAllTests calls the cleanupTests proc.
  218     # The currentFailure var stores the boolean value of whether the
  219     # current test file has had any failures.  The failFiles list
  220     # stores the names of test files that had failures.
  221     Default numTestFiles 0 AcceptInteger
  222     Default testSingleFile true AcceptBoolean
  223     Default currentFailure false AcceptBoolean
  224     Default failFiles {} AcceptList
  225 
  226     # Tests should remove all files they create.  The test suite will
  227     # check the current working dir for files created by the tests.
  228     # filesMade keeps track of such files created using the makeFile and
  229     # makeDirectory procedures.  filesExisted stores the names of
  230     # pre-existing files.
  231     #
  232     # Note that $filesExisted lists only those files that exist in
  233     # the original [temporaryDirectory].
  234     Default filesMade {} AcceptList
  235     Default filesExisted {} AcceptList
  236     proc FillFilesExisted {} {
  237 	variable filesExisted
  238 
  239 	# Save the names of files that already exist in the scratch directory.
  240 	foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
  241 	    lappend filesExisted [file tail $file]
  242 	}
  243 
  244 	# After successful filling, turn this into a no-op.
  245 	proc FillFilesExisted args {}
  246     }
  247 
  248     # Kept only for compatibility
  249     Default constraintsSpecified {} AcceptList
  250     trace add variable constraintsSpecified read [namespace code {
  251 	    set constraintsSpecified [array names testConstraints] ;#}]
  252 
  253     # tests that use threads need to know which is the main thread
  254     Default mainThread 1
  255     variable mainThread
  256     if {[info commands thread::id] ne {}} {
  257 	set mainThread [thread::id]
  258     } elseif {[info commands testthread] ne {}} {
  259 	set mainThread [testthread id]
  260     }
  261 
  262     # Set workingDirectory to [pwd]. The default output directory for
  263     # Tcl tests is the working directory.  Whenever this value changes
  264     # change to that directory.
  265     variable workingDirectory
  266     trace add variable workingDirectory write \
  267 	    [namespace code {cd $workingDirectory ;#}]
  268 
  269     Default workingDirectory [pwd] AcceptAbsolutePath
  270     proc workingDirectory { {dir ""} } {
  271 	variable workingDirectory
  272 	if {[llength [info level 0]] == 1} {
  273 	    return $workingDirectory
  274 	}
  275 	set workingDirectory [AcceptAbsolutePath $dir]
  276     }
  277 
  278     # Set the location of the execuatble
  279     Default tcltest [info nameofexecutable]
  280     trace add variable tcltest write [namespace code {testConstraint stdio \
  281 	    [eval [ConstraintInitializer stdio]] ;#}]
  282 
  283     # save the platform information so it can be restored later
  284     Default originalTclPlatform [array get ::tcl_platform]
  285 
  286     # If a core file exists, save its modification time.
  287     if {[file exists [file join [workingDirectory] core]]} {
  288 	Default coreModTime \
  289 		[file mtime [file join [workingDirectory] core]]
  290     }
  291 
  292     # stdout and stderr buffers for use when we want to store them
  293     Default outData {}
  294     Default errData {}
  295 
  296     # keep track of test level for nested test commands
  297     variable testLevel 0
  298 
  299     # the variables and procs that existed when saveState was called are
  300     # stored in a variable of the same name
  301     Default saveState {}
  302 
  303     # Internationalization support -- used in [SetIso8859_1_Locale] and
  304     # [RestoreLocale]. Those commands are used in cmdIL.test.
  305 
  306     if {![info exists [namespace current]::isoLocale]} {
  307 	variable isoLocale fr
  308 	switch -- $::tcl_platform(platform) {
  309 	    "unix" {
  310 
  311 		# Try some 'known' values for some platforms:
  312 
  313 		switch -exact -- $::tcl_platform(os) {
  314 		    "FreeBSD" {
  315 			set isoLocale fr_FR.ISO_8859-1
  316 		    }
  317 		    HP-UX {
  318 			set isoLocale fr_FR.iso88591
  319 		    }
  320 		    Linux -
  321 		    IRIX {
  322 			set isoLocale fr
  323 		    }
  324 		    default {
  325 
  326 			# Works on SunOS 4 and Solaris, and maybe
  327 			# others...  Define it to something else on your
  328 			# system if you want to test those.
  329 
  330 			set isoLocale iso_8859_1
  331 		    }
  332 		}
  333 	    }
  334 	    "windows" {
  335 		set isoLocale French
  336 	    }
  337 	}
  338     }
  339 
  340     variable ChannelsWeOpened; array set ChannelsWeOpened {}
  341     # output goes to stdout by default
  342     Default outputChannel stdout
  343     proc outputChannel { {filename ""} } {
  344 	variable outputChannel
  345 	variable ChannelsWeOpened
  346 
  347 	# This is very subtle and tricky, so let me try to explain.
  348 	# (Hopefully this longer comment will be clear when I come
  349 	# back in a few months, unlike its predecessor :) )
  350 	#
  351 	# The [outputChannel] command (and underlying variable) have to
  352 	# be kept in sync with the [configure -outfile] configuration
  353 	# option ( and underlying variable Option(-outfile) ).  This is
  354 	# accomplished with a write trace on Option(-outfile) that will
  355 	# update [outputChannel] whenver a new value is written.  That
  356 	# much is easy.
  357 	#
  358 	# The trick is that in order to maintain compatibility with
  359 	# version 1 of tcltest, we must allow every configuration option
  360 	# to get its inital value from command line arguments.  This is
  361 	# accomplished by setting initial read traces on all the
  362 	# configuration options to parse the command line option the first
  363 	# time they are read.  These traces are cancelled whenever the
  364 	# program itself calls [configure].
  365 	#
  366 	# OK, then so to support tcltest 1 compatibility, it seems we want
  367 	# to get the return from [outputFile] to trigger the read traces,
  368 	# just in case.
  369 	#
  370 	# BUT!  A little known feature of Tcl variable traces is that
  371 	# traces are disabled during the handling of other traces.  So,
  372 	# if we trigger read traces on Option(-outfile) and that triggers
  373 	# command line parsing which turns around and sets an initial
  374 	# value for Option(-outfile) -- <whew!> -- the write trace that
  375 	# would keep [outputChannel] in sync with that new initial value
  376 	# would not fire!
  377 	#
  378 	# SO, finally, as a workaround, instead of triggering read traces
  379 	# by invoking [outputFile], we instead trigger the same set of
  380 	# read traces by invoking [debug].  Any command that reads a
  381 	# configuration option would do.  [debug] is just a handy one.
  382 	# The end result is that we support tcltest 1 compatibility and
  383 	# keep outputChannel and -outfile in sync in all cases.
  384 	debug
  385 
  386 	if {[llength [info level 0]] == 1} {
  387 	    return $outputChannel
  388 	}
  389 	if {[info exists ChannelsWeOpened($outputChannel)]} {
  390 	    close $outputChannel
  391 	    unset ChannelsWeOpened($outputChannel)
  392 	}
  393 	switch -exact -- $filename {
  394 	    stderr -
  395 	    stdout {
  396 		set outputChannel $filename
  397 	    }
  398 	    default {
  399 		set outputChannel [open $filename a]
  400 		set ChannelsWeOpened($outputChannel) 1
  401 
  402 		# If we created the file in [temporaryDirectory], then
  403 		# [cleanupTests] will delete it, unless we claim it was
  404 		# already there.
  405 		set outdir [normalizePath [file dirname \
  406 			[file join [pwd] $filename]]]
  407 		if {$outdir eq [temporaryDirectory]} {
  408 		    variable filesExisted
  409 		    FillFilesExisted
  410 		    set filename [file tail $filename]
  411 		    if {$filename ni $filesExisted} {
  412 			lappend filesExisted $filename
  413 		    }
  414 		}
  415 	    }
  416 	}
  417 	return $outputChannel
  418     }
  419 
  420     # errors go to stderr by default
  421     Default errorChannel stderr
  422     proc errorChannel { {filename ""} } {
  423 	variable errorChannel
  424 	variable ChannelsWeOpened
  425 
  426 	# This is subtle and tricky.  See the comment above in
  427 	# [outputChannel] for a detailed explanation.
  428 	debug
  429 
  430 	if {[llength [info level 0]] == 1} {
  431 	    return $errorChannel
  432 	}
  433 	if {[info exists ChannelsWeOpened($errorChannel)]} {
  434 	    close $errorChannel
  435 	    unset ChannelsWeOpened($errorChannel)
  436 	}
  437 	switch -exact -- $filename {
  438 	    stderr -
  439 	    stdout {
  440 		set errorChannel $filename
  441 	    }
  442 	    default {
  443 		set errorChannel [open $filename a]
  444 		set ChannelsWeOpened($errorChannel) 1
  445 
  446 		# If we created the file in [temporaryDirectory], then
  447 		# [cleanupTests] will delete it, unless we claim it was
  448 		# already there.
  449 		set outdir [normalizePath [file dirname \
  450 			[file join [pwd] $filename]]]
  451 		if {$outdir eq [temporaryDirectory]} {
  452 		    variable filesExisted
  453 		    FillFilesExisted
  454 		    set filename [file tail $filename]
  455 		    if {$filename ni $filesExisted} {
  456 			lappend filesExisted $filename
  457 		    }
  458 		}
  459 	    }
  460 	}
  461 	return $errorChannel
  462     }
  463 
  464 ##### Set up the configurable options
  465     #
  466     # The configurable options of the package
  467     variable Option; array set Option {}
  468 
  469     # Usage strings for those options
  470     variable Usage; array set Usage {}
  471 
  472     # Verification commands for those options
  473     variable Verify; array set Verify {}
  474 
  475     # Initialize the default values of the configurable options that are
  476     # historically associated with an exported variable.  If that variable
  477     # is already set, support compatibility by accepting its pre-set value.
  478     # Use [trace] to establish ongoing connection between the deprecated
  479     # exported variable and the modern option kept as a true internal var.
  480     # Also set up usage string and value testing for the option.
  481     proc Option {option value usage {verify AcceptAll} {varName {}}} {
  482 	variable Option
  483 	variable Verify
  484 	variable Usage
  485 	variable OptionControlledVariables
  486 	variable DefaultValue
  487 	set Usage($option) $usage
  488 	set Verify($option) $verify
  489 	set DefaultValue($option) $value
  490 	if {[catch {$verify $value} msg]} {
  491 	    return -code error $msg
  492 	} else {
  493 	    set Option($option) $msg
  494 	}
  495 	if {[string length $varName]} {
  496 	    variable $varName
  497 	    if {[info exists $varName]} {
  498 		if {[catch {$verify [set $varName]} msg]} {
  499 		    return -code error $msg
  500 		} else {
  501 		    set Option($option) $msg
  502 		}
  503 		unset $varName
  504 	    }
  505 	    namespace eval [namespace current] \
  506 	    	    [list upvar 0 Option($option) $varName]
  507 	    # Workaround for Bug (now Feature Request) 572889.  Grrrr....
  508 	    # Track all the variables tied to options
  509 	    lappend OptionControlledVariables $varName
  510 	    # Later, set auto-configure read traces on all
  511 	    # of them, since a single trace on Option does not work.
  512 	    proc $varName {{value {}}} [subst -nocommands {
  513 		if {[llength [info level 0]] == 2} {
  514 		    Configure $option [set value]
  515 		}
  516 		return [Configure $option]
  517 	    }]
  518 	}
  519     }
  520 
  521     proc MatchingOption {option} {
  522 	variable Option
  523 	set match [array names Option $option*]
  524 	switch -- [llength $match] {
  525 	    0 {
  526 		set sorted [lsort [array names Option]]
  527 		set values [join [lrange $sorted 0 end-1] ", "]
  528 		append values ", or [lindex $sorted end]"
  529 		return -code error "unknown option $option: should be\
  530 			one of $values"
  531 	    }
  532 	    1 {
  533 		return [lindex $match 0]
  534 	    }
  535 	    default {
  536 		# Exact match trumps ambiguity
  537 		if {$option in $match} {
  538 		    return $option
  539 		}
  540 		set values [join [lrange $match 0 end-1] ", "]
  541 		append values ", or [lindex $match end]"
  542 		return -code error "ambiguous option $option:\
  543 			could match $values"
  544 	    }
  545 	}
  546     }
  547 
  548     proc EstablishAutoConfigureTraces {} {
  549 	variable OptionControlledVariables
  550 	foreach varName [concat $OptionControlledVariables Option] {
  551 	    variable $varName
  552 	    trace add variable $varName read [namespace code {
  553 		    ProcessCmdLineArgs ;#}]
  554 	}
  555     }
  556 
  557     proc RemoveAutoConfigureTraces {} {
  558 	variable OptionControlledVariables
  559 	foreach varName [concat $OptionControlledVariables Option] {
  560 	    variable $varName
  561 	    foreach pair [trace info variable $varName] {
  562 		lassign $pair op cmd
  563 		if {($op eq "read") &&
  564 			[string match *ProcessCmdLineArgs* $cmd]} {
  565 		    trace remove variable $varName $op $cmd
  566 		}
  567 	    }
  568 	}
  569 	# Once the traces are removed, this can become a no-op
  570 	proc RemoveAutoConfigureTraces {} {}
  571     }
  572 
  573     proc Configure args {
  574 	variable Option
  575 	variable Verify
  576 	set n [llength $args]
  577 	if {$n == 0} {
  578 	    return [lsort [array names Option]]
  579 	}
  580 	if {$n == 1} {
  581 	    if {[catch {MatchingOption [lindex $args 0]} option]} {
  582 		return -code error $option
  583 	    }
  584 	    return $Option($option)
  585 	}
  586 	while {[llength $args] > 1} {
  587 	    if {[catch {MatchingOption [lindex $args 0]} option]} {
  588 		return -code error $option
  589 	    }
  590 	    if {[catch {$Verify($option) [lindex $args 1]} value]} {
  591 		return -code error "invalid $option\
  592 			value \"[lindex $args 1]\": $value"
  593 	    }
  594 	    set Option($option) $value
  595 	    set args [lrange $args 2 end]
  596 	}
  597 	if {[llength $args]} {
  598 	    if {[catch {MatchingOption [lindex $args 0]} option]} {
  599 		return -code error $option
  600 	    }
  601 	    return -code error "missing value for option $option"
  602 	}
  603     }
  604     proc configure args {
  605 	if {[llength $args] > 1} {
  606 	    RemoveAutoConfigureTraces
  607 	}
  608 	set code [catch {Configure {*}$args} msg]
  609 	return -code $code $msg
  610     }
  611 
  612     proc AcceptVerbose { level } {
  613 	set level [AcceptList $level]
  614 	set levelMap {
  615 	    l list
  616 	    p pass
  617 	    b body
  618 	    s skip
  619 	    t start
  620 	    e error
  621 	    l line
  622 	    m msec
  623 	    u usec
  624 	}
  625 	set levelRegexp "^([join [dict values $levelMap] |])\$"
  626 	if {[llength $level] == 1} {
  627 	    if {![regexp $levelRegexp $level]} {
  628 		# translate single characters abbreviations to expanded list
  629 		set level [string map $levelMap [split $level {}]]
  630 	    }
  631 	}
  632 	set valid [list]
  633 	foreach v $level {
  634 	    if {[regexp $levelRegexp $v]} {
  635 		lappend valid $v
  636 	    }
  637 	}
  638 	return $valid
  639     }
  640 
  641     proc IsVerbose {level} {
  642 	variable Option
  643 	return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
  644     }
  645 
  646     # Default verbosity is to show bodies of failed tests
  647     Option -verbose {body error} {
  648 	Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
  649 	Test suite will display all passed tests if 'p' is specified, all
  650 	skipped tests if 's' is specified, the bodies of failed tests if
  651 	'b' is specified, and when tests start if 't' is specified.
  652 	ErrorInfo is displayed if 'e' is specified. Source file line
  653 	information of failed tests is displayed if 'l' is specified.
  654     } AcceptVerbose verbose
  655 
  656     # Match and skip patterns default to the empty list, except for
  657     # matchFiles, which defaults to all .test files in the
  658     # testsDirectory and matchDirectories, which defaults to all
  659     # directories.
  660     Option -match * {
  661 	Run all tests within the specified files that match one of the
  662 	list of glob patterns given.
  663     } AcceptList match
  664 
  665     Option -skip {} {
  666 	Skip all tests within the specified tests (via -match) and files
  667 	that match one of the list of glob patterns given.
  668     } AcceptList skip
  669 
  670     Option -file *.test {
  671 	Run tests in all test files that match the glob pattern given.
  672     } AcceptPattern matchFiles
  673 
  674     # By default, skip files that appear to be SCCS lock files.
  675     Option -notfile l.*.test {
  676 	Skip all test files that match the glob pattern given.
  677     } AcceptPattern skipFiles
  678 
  679     Option -relateddir * {
  680 	Run tests in directories that match the glob pattern given.
  681     } AcceptPattern matchDirectories
  682 
  683     Option -asidefromdir {} {
  684 	Skip tests in directories that match the glob pattern given.
  685     } AcceptPattern skipDirectories
  686 
  687     # By default, don't save core files
  688     Option -preservecore 0 {
  689 	If 2, save any core files produced during testing in the directory
  690 	specified by -tmpdir. If 1, notify the user if core files are
  691 	created.
  692     } AcceptInteger preserveCore
  693 
  694     # debug output doesn't get printed by default; debug level 1 spits
  695     # up only the tests that were skipped because they didn't match or
  696     # were specifically skipped.  A debug level of 2 would spit up the
  697     # tcltest variables and flags provided; a debug level of 3 causes
  698     # some additional output regarding operations of the test harness.
  699     # The tcltest package currently implements only up to debug level 3.
  700     Option -debug 0 {
  701 	Internal debug level
  702     } AcceptInteger debug
  703 
  704     proc SetSelectedConstraints args {
  705 	variable Option
  706 	foreach c $Option(-constraints) {
  707 	    testConstraint $c 1
  708 	}
  709     }
  710     Option -constraints {} {
  711 	Do not skip the listed constraints listed in -constraints.
  712     } AcceptList
  713     trace add variable Option(-constraints) write \
  714 	    [namespace code {SetSelectedConstraints ;#}]
  715 
  716     # Don't run only the "-constraint" specified tests by default
  717     proc ClearUnselectedConstraints args {
  718 	variable Option
  719 	variable testConstraints
  720 	if {!$Option(-limitconstraints)} {return}
  721 	foreach c [array names testConstraints] {
  722 	    if {$c ni $Option(-constraints)} {
  723 		testConstraint $c 0
  724 	    }
  725 	}
  726     }
  727     Option -limitconstraints 0 {
  728 	whether to run only tests with the constraints
  729     } AcceptBoolean limitConstraints
  730     trace add variable Option(-limitconstraints) write \
  731 	    [namespace code {ClearUnselectedConstraints ;#}]
  732 
  733     # A test application has to know how to load the tested commands
  734     # into the interpreter.
  735     Option -load {} {
  736 	Specifies the script to load the tested commands.
  737     } AcceptScript loadScript
  738 
  739     # Default is to run each test file in a separate process
  740     Option -singleproc 0 {
  741 	whether to run all tests in one process
  742     } AcceptBoolean singleProcess
  743 
  744     proc AcceptTemporaryDirectory { directory } {
  745 	set directory [AcceptAbsolutePath $directory]
  746 	if {![file exists $directory]} {
  747 	    file mkdir $directory
  748 	}
  749 	set directory [AcceptDirectory $directory]
  750 	if {![file writable $directory]} {
  751 	    if {[workingDirectory] eq $directory} {
  752 		# Special exception: accept the default value
  753 		# even if the directory is not writable
  754 		return $directory
  755 	    }
  756 	    return -code error "\"$directory\" is not writeable"
  757 	}
  758 	return $directory
  759     }
  760 
  761     # Directory where files should be created
  762     Option -tmpdir [workingDirectory] {
  763 	Save temporary files in the specified directory.
  764     } AcceptTemporaryDirectory temporaryDirectory
  765     trace add variable Option(-tmpdir) write \
  766 	    [namespace code {normalizePath Option(-tmpdir) ;#}]
  767 
  768     # Tests should not rely on the current working directory.
  769     # Files that are part of the test suite should be accessed relative
  770     # to [testsDirectory]
  771     Option -testdir [workingDirectory] {
  772 	Search tests in the specified directory.
  773     } AcceptDirectory testsDirectory
  774     trace add variable Option(-testdir) write \
  775 	    [namespace code {normalizePath Option(-testdir) ;#}]
  776 
  777     proc AcceptLoadFile { file } {
  778 	if {$file eq {}} {return $file}
  779 	set file [file join [temporaryDirectory] $file]
  780 	return [AcceptReadable $file]
  781     }
  782     proc ReadLoadScript {args} {
  783 	variable Option
  784 	if {$Option(-loadfile) eq {}} {return}
  785 	set tmp [open $Option(-loadfile) r]
  786 	loadScript [read $tmp]
  787 	close $tmp
  788     }
  789     Option -loadfile {} {
  790 	Read the script to load the tested commands from the specified file.
  791     } AcceptLoadFile loadFile
  792     trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
  793 
  794     proc AcceptOutFile { file } {
  795 	if {[string equal stderr $file]} {return $file}
  796 	if {[string equal stdout $file]} {return $file}
  797 	return [file join [temporaryDirectory] $file]
  798     }
  799 
  800     # output goes to stdout by default
  801     Option -outfile stdout {
  802 	Send output from test runs to the specified file.
  803     } AcceptOutFile outputFile
  804     trace add variable Option(-outfile) write \
  805 	    [namespace code {outputChannel $Option(-outfile) ;#}]
  806 
  807     # errors go to stderr by default
  808     Option -errfile stderr {
  809 	Send errors from test runs to the specified file.
  810     } AcceptOutFile errorFile
  811     trace add variable Option(-errfile) write \
  812 	    [namespace code {errorChannel $Option(-errfile) ;#}]
  813 
  814     proc loadIntoSlaveInterpreter {slave args} {
  815 	variable Version
  816 	interp eval $slave [package ifneeded tcltest $Version]
  817 	interp eval $slave "tcltest::configure {*}{$args}"
  818 	interp alias $slave ::tcltest::ReportToMaster \
  819 	    {} ::tcltest::ReportedFromSlave
  820     }
  821     proc ReportedFromSlave {total passed skipped failed because newfiles} {
  822 	variable numTests
  823 	variable skippedBecause
  824 	variable createdNewFiles
  825 	incr numTests(Total)   $total
  826 	incr numTests(Passed)  $passed
  827 	incr numTests(Skipped) $skipped
  828 	incr numTests(Failed)  $failed
  829 	foreach {constraint count} $because {
  830 	    incr skippedBecause($constraint) $count
  831 	}
  832 	foreach {testfile created} $newfiles {
  833 	    lappend createdNewFiles($testfile) {*}$created
  834 	}
  835 	return
  836     }
  837 }
  838 
  839 #####################################################################
  840 
  841 # tcltest::Debug* --
  842 #
  843 #     Internal helper procedures to write out debug information
  844 #     dependent on the chosen level. A test shell may overide
  845 #     them, f.e. to redirect the output into a different
  846 #     channel, or even into a GUI.
  847 
  848 # tcltest::DebugPuts --
  849 #
  850 #     Prints the specified string if the current debug level is
  851 #     higher than the provided level argument.
  852 #
  853 # Arguments:
  854 #     level   The lowest debug level triggering the output
  855 #     string  The string to print out.
  856 #
  857 # Results:
  858 #     Prints the string. Nothing else is allowed.
  859 #
  860 # Side Effects:
  861 #     None.
  862 #
  863 
  864 proc tcltest::DebugPuts {level string} {
  865     variable debug
  866     if {$debug >= $level} {
  867 	puts $string
  868     }
  869     return
  870 }
  871 
  872 # tcltest::DebugPArray --
  873 #
  874 #     Prints the contents of the specified array if the current
  875 #       debug level is higher than the provided level argument
  876 #
  877 # Arguments:
  878 #     level           The lowest debug level triggering the output
  879 #     arrayvar        The name of the array to print out.
  880 #
  881 # Results:
  882 #     Prints the contents of the array. Nothing else is allowed.
  883 #
  884 # Side Effects:
  885 #     None.
  886 #
  887 
  888 proc tcltest::DebugPArray {level arrayvar} {
  889     variable debug
  890 
  891     if {$debug >= $level} {
  892 	catch {upvar 1 $arrayvar $arrayvar}
  893 	parray $arrayvar
  894     }
  895     return
  896 }
  897 
  898 # Define our own [parray] in ::tcltest that will inherit use of the [puts]
  899 # defined in ::tcltest.  NOTE: Ought to construct with [info args] and
  900 # [info default], but can't be bothered now.  If [parray] changes, then
  901 # this will need changing too.
  902 auto_load ::parray
  903 proc tcltest::parray {a {pattern *}} [info body ::parray]
  904 
  905 # tcltest::DebugDo --
  906 #
  907 #     Executes the script if the current debug level is greater than
  908 #       the provided level argument
  909 #
  910 # Arguments:
  911 #     level   The lowest debug level triggering the execution.
  912 #     script  The tcl script executed upon a debug level high enough.
  913 #
  914 # Results:
  915 #     Arbitrary side effects, dependent on the executed script.
  916 #
  917 # Side Effects:
  918 #     None.
  919 #
  920 
  921 proc tcltest::DebugDo {level script} {
  922     variable debug
  923 
  924     if {$debug >= $level} {
  925 	uplevel 1 $script
  926     }
  927     return
  928 }
  929 
  930 #####################################################################
  931 
  932 proc tcltest::Warn {msg} {
  933     puts [outputChannel] "WARNING: $msg"
  934 }
  935 
  936 # tcltest::mainThread
  937 #
  938 #     Accessor command for tcltest variable mainThread.
  939 #
  940 proc tcltest::mainThread { {new ""} } {
  941     variable mainThread
  942     if {[llength [info level 0]] == 1} {
  943 	return $mainThread
  944     }
  945     set mainThread $new
  946 }
  947 
  948 # tcltest::testConstraint --
  949 #
  950 #	sets a test constraint to a value; to do multiple constraints,
  951 #       call this proc multiple times.  also returns the value of the
  952 #       named constraint if no value was supplied.
  953 #
  954 # Arguments:
  955 #	constraint - name of the constraint
  956 #       value - new value for constraint (should be boolean) - if not
  957 #               supplied, this is a query
  958 #
  959 # Results:
  960 #	content of tcltest::testConstraints($constraint)
  961 #
  962 # Side effects:
  963 #	none
  964 
  965 proc tcltest::testConstraint {constraint {value ""}} {
  966     variable testConstraints
  967     variable Option
  968     DebugPuts 3 "entering testConstraint $constraint $value"
  969     if {[llength [info level 0]] == 2} {
  970 	return $testConstraints($constraint)
  971     }
  972     # Check for boolean values
  973     if {[catch {expr {$value && $value}} msg]} {
  974 	return -code error $msg
  975     }
  976     if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
  977 	set value 0
  978     }
  979     set testConstraints($constraint) $value
  980 }
  981 
  982 # tcltest::interpreter --
  983 #
  984 #	the interpreter name stored in tcltest::tcltest
  985 #
  986 # Arguments:
  987 #	executable name
  988 #
  989 # Results:
  990 #	content of tcltest::tcltest
  991 #
  992 # Side effects:
  993 #	None.
  994 
  995 proc tcltest::interpreter { {interp ""} } {
  996     variable tcltest
  997     if {[llength [info level 0]] == 1} {
  998 	return $tcltest
  999     }
 1000     set tcltest $interp
 1001 }
 1002 
 1003 #####################################################################
 1004 
 1005 # tcltest::AddToSkippedBecause --
 1006 #
 1007 #	Increments the variable used to track how many tests were
 1008 #       skipped because of a particular constraint.
 1009 #
 1010 # Arguments:
 1011 #	constraint     The name of the constraint to be modified
 1012 #
 1013 # Results:
 1014 #	Modifies tcltest::skippedBecause; sets the variable to 1 if
 1015 #       didn't previously exist - otherwise, it just increments it.
 1016 #
 1017 # Side effects:
 1018 #	None.
 1019 
 1020 proc tcltest::AddToSkippedBecause { constraint {value 1}} {
 1021     # add the constraint to the list of constraints that kept tests
 1022     # from running
 1023     variable skippedBecause
 1024 
 1025     if {[info exists skippedBecause($constraint)]} {
 1026 	incr skippedBecause($constraint) $value
 1027     } else {
 1028 	set skippedBecause($constraint) $value
 1029     }
 1030     return
 1031 }
 1032 
 1033 # tcltest::PrintError --
 1034 #
 1035 #	Prints errors to tcltest::errorChannel and then flushes that
 1036 #       channel, making sure that all messages are < 80 characters per
 1037 #       line.
 1038 #
 1039 # Arguments:
 1040 #	errorMsg     String containing the error to be printed
 1041 #
 1042 # Results:
 1043 #	None.
 1044 #
 1045 # Side effects:
 1046 #	None.
 1047 
 1048 proc tcltest::PrintError {errorMsg} {
 1049     set InitialMessage "Error:  "
 1050     set InitialMsgLen  [string length $InitialMessage]
 1051     puts -nonewline [errorChannel] $InitialMessage
 1052 
 1053     # Keep track of where the end of the string is.
 1054     set endingIndex [string length $errorMsg]
 1055 
 1056     if {$endingIndex < (80 - $InitialMsgLen)} {
 1057 	puts [errorChannel] $errorMsg
 1058     } else {
 1059 	# Print up to 80 characters on the first line, including the
 1060 	# InitialMessage.
 1061 	set beginningIndex [string last " " [string range $errorMsg 0 \
 1062 		[expr {80 - $InitialMsgLen}]]]
 1063 	puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
 1064 
 1065 	while {$beginningIndex ne "end"} {
 1066 	    puts -nonewline [errorChannel] \
 1067 		    [string repeat " " $InitialMsgLen]
 1068 	    if {($endingIndex - $beginningIndex)
 1069 		    < (80 - $InitialMsgLen)} {
 1070 		puts [errorChannel] [string trim \
 1071 			[string range $errorMsg $beginningIndex end]]
 1072 		break
 1073 	    } else {
 1074 		set newEndingIndex [expr {[string last " " \
 1075 			[string range $errorMsg $beginningIndex \
 1076 				[expr {$beginningIndex
 1077 					+ (80 - $InitialMsgLen)}]
 1078 		]] + $beginningIndex}]
 1079 		if {($newEndingIndex <= 0)
 1080 			|| ($newEndingIndex <= $beginningIndex)} {
 1081 		    set newEndingIndex end
 1082 		}
 1083 		puts [errorChannel] [string trim \
 1084 			[string range $errorMsg \
 1085 			    $beginningIndex $newEndingIndex]]
 1086 		set beginningIndex $newEndingIndex
 1087 	    }
 1088 	}
 1089     }
 1090     flush [errorChannel]
 1091     return
 1092 }
 1093 
 1094 # tcltest::SafeFetch --
 1095 #
 1096 #	 The following trace procedure makes it so that we can safely
 1097 #        refer to non-existent members of the testConstraints array
 1098 #        without causing an error.  Instead, reading a non-existent
 1099 #        member will return 0. This is necessary because tests are
 1100 #        allowed to use constraint "X" without ensuring that
 1101 #        testConstraints("X") is defined.
 1102 #
 1103 # Arguments:
 1104 #	n1 - name of the array (testConstraints)
 1105 #       n2 - array key value (constraint name)
 1106 #       op - operation performed on testConstraints (generally r)
 1107 #
 1108 # Results:
 1109 #	none
 1110 #
 1111 # Side effects:
 1112 #	sets testConstraints($n2) to 0 if it's referenced but never
 1113 #       before used
 1114 
 1115 proc tcltest::SafeFetch {n1 n2 op} {
 1116     variable testConstraints
 1117     DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
 1118     if {$n2 eq {}} {return}
 1119     if {![info exists testConstraints($n2)]} {
 1120 	if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
 1121 	    testConstraint $n2 0
 1122 	}
 1123     }
 1124 }
 1125 
 1126 # tcltest::ConstraintInitializer --
 1127 #
 1128 #	Get or set a script that when evaluated in the tcltest namespace
 1129 #	will return a boolean value with which to initialize the
 1130 #	associated constraint.
 1131 #
 1132 # Arguments:
 1133 #	constraint - name of the constraint initialized by the script
 1134 #	script - the initializer script
 1135 #
 1136 # Results
 1137 #	boolean value of the constraint - enabled or disabled
 1138 #
 1139 # Side effects:
 1140 #	Constraint is initialized for future reference by [test]
 1141 proc tcltest::ConstraintInitializer {constraint {script ""}} {
 1142     variable ConstraintInitializer
 1143     DebugPuts 3 "entering ConstraintInitializer $constraint $script"
 1144     if {[llength [info level 0]] == 2} {
 1145 	return $ConstraintInitializer($constraint)
 1146     }
 1147     # Check for boolean values
 1148     if {![info complete $script]} {
 1149 	return -code error "ConstraintInitializer must be complete script"
 1150     }
 1151     set ConstraintInitializer($constraint) $script
 1152 }
 1153 
 1154 # tcltest::InitConstraints --
 1155 #
 1156 # Call all registered constraint initializers to force initialization
 1157 # of all known constraints.
 1158 # See the tcltest man page for the list of built-in constraints defined
 1159 # in this procedure.
 1160 #
 1161 # Arguments:
 1162 #	none
 1163 #
 1164 # Results:
 1165 #	The testConstraints array is reset to have an index for each
 1166 #	built-in test constraint.
 1167 #
 1168 # Side Effects:
 1169 #       None.
 1170 #
 1171 
 1172 proc tcltest::InitConstraints {} {
 1173     variable ConstraintInitializer
 1174     initConstraintsHook
 1175     foreach constraint [array names ConstraintInitializer] {
 1176 	testConstraint $constraint
 1177     }
 1178 }
 1179 
 1180 proc tcltest::DefineConstraintInitializers {} {
 1181     ConstraintInitializer singleTestInterp {singleProcess}
 1182 
 1183     # All the 'pc' constraints are here for backward compatibility and
 1184     # are not documented.  They have been replaced with equivalent 'win'
 1185     # constraints.
 1186 
 1187     ConstraintInitializer unixOnly \
 1188 	    {string equal $::tcl_platform(platform) unix}
 1189     ConstraintInitializer macOnly \
 1190 	    {string equal $::tcl_platform(platform) macintosh}
 1191     ConstraintInitializer pcOnly \
 1192 	    {string equal $::tcl_platform(platform) windows}
 1193     ConstraintInitializer winOnly \
 1194 	    {string equal $::tcl_platform(platform) windows}
 1195 
 1196     ConstraintInitializer unix {testConstraint unixOnly}
 1197     ConstraintInitializer mac {testConstraint macOnly}
 1198     ConstraintInitializer pc {testConstraint pcOnly}
 1199     ConstraintInitializer win {testConstraint winOnly}
 1200 
 1201     ConstraintInitializer unixOrPc \
 1202 	    {expr {[testConstraint unix] || [testConstraint pc]}}
 1203     ConstraintInitializer macOrPc \
 1204 	    {expr {[testConstraint mac] || [testConstraint pc]}}
 1205     ConstraintInitializer unixOrWin \
 1206 	    {expr {[testConstraint unix] || [testConstraint win]}}
 1207     ConstraintInitializer macOrWin \
 1208 	    {expr {[testConstraint mac] || [testConstraint win]}}
 1209     ConstraintInitializer macOrUnix \
 1210 	    {expr {[testConstraint mac] || [testConstraint unix]}}
 1211 
 1212     ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
 1213     ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
 1214     ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
 1215 
 1216     # The following Constraints switches are used to mark tests that
 1217     # should work, but have been temporarily disabled on certain
 1218     # platforms because they don't and we haven't gotten around to
 1219     # fixing the underlying problem.
 1220 
 1221     ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
 1222     ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
 1223     ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
 1224     ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
 1225 
 1226     # The following Constraints switches are used to mark tests that
 1227     # crash on certain platforms, so that they can be reactivated again
 1228     # when the underlying problem is fixed.
 1229 
 1230     ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
 1231     ConstraintInitializer winCrash {expr {![testConstraint win]}}
 1232     ConstraintInitializer macCrash {expr {![testConstraint mac]}}
 1233     ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
 1234 
 1235     # Skip empty tests
 1236 
 1237     ConstraintInitializer emptyTest {format 0}
 1238 
 1239     # By default, tests that expose known bugs are skipped.
 1240 
 1241     ConstraintInitializer knownBug {format 0}
 1242 
 1243     # By default, non-portable tests are skipped.
 1244 
 1245     ConstraintInitializer nonPortable {format 0}
 1246 
 1247     # Some tests require user interaction.
 1248 
 1249     ConstraintInitializer userInteraction {format 0}
 1250 
 1251     # Some tests must be skipped if the interpreter is not in
 1252     # interactive mode
 1253 
 1254     ConstraintInitializer interactive \
 1255 	    {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
 1256 
 1257     # Some tests can only be run if the installation came from a CD
 1258     # image instead of a web image.  Some tests must be skipped if you
 1259     # are running as root on Unix.  Other tests can only be run if you
 1260     # are running as root on Unix.
 1261 
 1262     ConstraintInitializer root {expr \
 1263 	    {($::tcl_platform(platform) eq "unix") &&
 1264 		    ($::tcl_platform(user) in {root {}})}}
 1265     ConstraintInitializer notRoot {expr {![testConstraint root]}}
 1266 
 1267     # Set nonBlockFiles constraint: 1 means this platform supports
 1268     # setting files into nonblocking mode.
 1269 
 1270     ConstraintInitializer nonBlockFiles {
 1271 	    set code [expr {[catch {set f [open defs r]}]
 1272 		    || [catch {chan configure $f -blocking off}]}]
 1273 	    catch {close $f}
 1274 	    set code
 1275     }
 1276 
 1277     # Set asyncPipeClose constraint: 1 means this platform supports
 1278     # async flush and async close on a pipe.
 1279     #
 1280     # Test for SCO Unix - cannot run async flushing tests because a
 1281     # potential problem with select is apparently interfering.
 1282     # (Mark Diekhans).
 1283 
 1284     ConstraintInitializer asyncPipeClose {expr {
 1285 	    !([string equal unix $::tcl_platform(platform)]
 1286 	    && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
 1287 
 1288     # Test to see if we have a broken version of sprintf with respect
 1289     # to the "e" format of floating-point numbers.
 1290 
 1291     ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
 1292 
 1293     # Test to see if execed commands such as cat, echo, rm and so forth
 1294     # are present on this machine.
 1295 
 1296     ConstraintInitializer unixExecs {
 1297 	set code 1
 1298         if {$::tcl_platform(platform) eq "macintosh"} {
 1299 	    set code 0
 1300         }
 1301         if {$::tcl_platform(platform) eq "windows"} {
 1302 	    if {[catch {
 1303 	        set file _tcl_test_remove_me.txt
 1304 	        makeFile {hello} $file
 1305 	    }]} {
 1306 	        set code 0
 1307 	    } elseif {
 1308 	        [catch {exec cat $file}] ||
 1309 	        [catch {exec echo hello}] ||
 1310 	        [catch {exec sh -c echo hello}] ||
 1311 	        [catch {exec wc $file}] ||
 1312 	        [catch {exec sleep 1}] ||
 1313 	        [catch {exec echo abc > $file}] ||
 1314 	        [catch {exec chmod 644 $file}] ||
 1315 	        [catch {exec rm $file}] ||
 1316 	        [llength [auto_execok mkdir]] == 0 ||
 1317 	        [llength [auto_execok fgrep]] == 0 ||
 1318 	        [llength [auto_execok grep]] == 0 ||
 1319 	        [llength [auto_execok ps]] == 0
 1320 	    } {
 1321 	        set code 0
 1322 	    }
 1323 	    removeFile $file
 1324         }
 1325 	set code
 1326     }
 1327 
 1328     ConstraintInitializer stdio {
 1329 	set code 0
 1330 	if {![catch {set f [open "|[list [interpreter]]" w]}]} {
 1331 	    if {![catch {puts $f exit}]} {
 1332 		if {![catch {close $f}]} {
 1333 		    set code 1
 1334 		}
 1335 	    }
 1336 	}
 1337 	set code
 1338     }
 1339 
 1340     # Deliberately call socket with the wrong number of arguments.  The
 1341     # error message you get will indicate whether sockets are available
 1342     # on this system.
 1343 
 1344     ConstraintInitializer socket {
 1345 	catch {socket} msg
 1346 	string compare $msg "sockets are not available on this system"
 1347     }
 1348 
 1349     # Check for internationalization
 1350     ConstraintInitializer hasIsoLocale {
 1351 	if {[llength [info commands testlocale]] == 0} {
 1352 	    set code 0
 1353 	} else {
 1354 	    set code [string length [SetIso8859_1_Locale]]
 1355 	    RestoreLocale
 1356 	}
 1357 	set code
 1358     }
 1359 
 1360 }
 1361 #####################################################################
 1362 
 1363 # Usage and command line arguments processing.
 1364 
 1365 # tcltest::PrintUsageInfo
 1366 #
 1367 #	Prints out the usage information for package tcltest.  This can
 1368 #	be customized with the redefinition of [PrintUsageInfoHook].
 1369 #
 1370 # Arguments:
 1371 #	none
 1372 #
 1373 # Results:
 1374 #       none
 1375 #
 1376 # Side Effects:
 1377 #       none
 1378 proc tcltest::PrintUsageInfo {} {
 1379     puts [Usage]
 1380     PrintUsageInfoHook
 1381 }
 1382 
 1383 proc tcltest::Usage { {option ""} } {
 1384     variable Usage
 1385     variable Verify
 1386     if {[llength [info level 0]] == 1} {
 1387 	set msg "Usage: [file tail [info nameofexecutable]] script "
 1388 	append msg "?-help? ?flag value? ... \n"
 1389 	append msg "Available flags (and valid input values) are:"
 1390 
 1391 	set max 0
 1392 	set allOpts [concat -help [Configure]]
 1393 	foreach opt $allOpts {
 1394 	    set foo [Usage $opt]
 1395 	    lassign $foo x type($opt) usage($opt)
 1396 	    set line($opt) "  $opt $type($opt)  "
 1397 	    set length($opt) [string length $line($opt)]
 1398 	    if {$length($opt) > $max} {set max $length($opt)}
 1399 	}
 1400 	set rest [expr {72 - $max}]
 1401 	foreach opt $allOpts {
 1402 	    append msg \n$line($opt)
 1403 	    append msg [string repeat " " [expr {$max - $length($opt)}]]
 1404 	    set u [string trim $usage($opt)]
 1405 	    catch {append u "  (default: \[[Configure $opt]])"}
 1406 	    regsub -all {\s*\n\s*} $u " " u
 1407 	    while {[string length $u] > $rest} {
 1408 		set break [string wordstart $u $rest]
 1409 		if {$break == 0} {
 1410 		    set break [string wordend $u 0]
 1411 		}
 1412 		append msg [string range $u 0 [expr {$break - 1}]]
 1413 		set u [string trim [string range $u $break end]]
 1414 		append msg \n[string repeat " " $max]
 1415 	    }
 1416 	    append msg $u
 1417 	}
 1418 	return $msg\n
 1419     } elseif {$option eq "-help"} {
 1420 	return [list -help "" "Display this usage information."]
 1421     } else {
 1422 	set type [lindex [info args $Verify($option)] 0]
 1423 	return [list $option $type $Usage($option)]
 1424     }
 1425 }
 1426 
 1427 # tcltest::ProcessFlags --
 1428 #
 1429 #	process command line arguments supplied in the flagArray - this
 1430 #	is called by processCmdLineArgs.  Modifies tcltest variables
 1431 #	according to the content of the flagArray.
 1432 #
 1433 # Arguments:
 1434 #	flagArray - array containing name/value pairs of flags
 1435 #
 1436 # Results:
 1437 #	sets tcltest variables according to their values as defined by
 1438 #       flagArray
 1439 #
 1440 # Side effects:
 1441 #	None.
 1442 
 1443 proc tcltest::ProcessFlags {flagArray} {
 1444     # Process -help first
 1445     if {"-help" in $flagArray} {
 1446 	PrintUsageInfo
 1447 	exit 1
 1448     }
 1449 
 1450     if {[llength $flagArray] == 0} {
 1451 	RemoveAutoConfigureTraces
 1452     } else {
 1453 	set args $flagArray
 1454 	while {[llength $args] > 1 && [catch {configure {*}$args} msg]} {
 1455 
 1456 	    # Something went wrong parsing $args for tcltest options
 1457 	    # Check whether the problem is "unknown option"
 1458 	    if {[regexp {^unknown option (\S+):} $msg -> option]} {
 1459 		# Could be this is an option the Hook knows about
 1460 		set moreOptions [processCmdLineArgsAddFlagsHook]
 1461 		if {$option ni $moreOptions} {
 1462 		    # Nope.  Report the error, including additional options,
 1463 		    # but keep going
 1464 		    if {[llength $moreOptions]} {
 1465 			append msg ", "
 1466 			append msg [join [lrange $moreOptions 0 end-1] ", "]
 1467 			append msg "or [lindex $moreOptions end]"
 1468 		    }
 1469 		    Warn $msg
 1470 		}
 1471 	    } else {
 1472 		# error is something other than "unknown option"
 1473 		# notify user of the error; and exit
 1474 		puts [errorChannel] $msg
 1475 		exit 1
 1476 	    }
 1477 
 1478 	    # To recover, find that unknown option and remove up to it.
 1479 	    # then retry
 1480 	    while {[lindex $args 0] ne $option} {
 1481 		set args [lrange $args 2 end]
 1482 	    }
 1483 	    set args [lrange $args 2 end]
 1484 	}
 1485 	if {[llength $args] == 1} {
 1486 	    puts [errorChannel] \
 1487 		    "missing value for option [lindex $args 0]"
 1488 	    exit 1
 1489 	}
 1490     }
 1491 
 1492     # Call the hook
 1493     catch {
 1494         array set flag $flagArray
 1495         processCmdLineArgsHook [array get flag]
 1496     }
 1497     return
 1498 }
 1499 
 1500 # tcltest::ProcessCmdLineArgs --
 1501 #
 1502 #       This procedure must be run after constraint initialization is
 1503 #	set up (by [DefineConstraintInitializers]) because some constraints
 1504 #	can be overridden.
 1505 #
 1506 #       Perform configuration according to the command-line options.
 1507 #
 1508 # Arguments:
 1509 #	none
 1510 #
 1511 # Results:
 1512 #	Sets the above-named variables in the tcltest namespace.
 1513 #
 1514 # Side Effects:
 1515 #       None.
 1516 #
 1517 
 1518 proc tcltest::ProcessCmdLineArgs {} {
 1519     variable originalEnv
 1520     variable testConstraints
 1521 
 1522     # The "argv" var doesn't exist in some cases, so use {}.
 1523     if {![info exists ::argv]} {
 1524 	ProcessFlags {}
 1525     } else {
 1526 	ProcessFlags $::argv
 1527     }
 1528 
 1529     # Spit out everything you know if we're at a debug level 2 or
 1530     # greater
 1531     DebugPuts 2 "Flags passed into tcltest:"
 1532     if {[info exists ::env(TCLTEST_OPTIONS)]} {
 1533 	DebugPuts 2 \
 1534 		"    ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
 1535     }
 1536     if {[info exists ::argv]} {
 1537 	DebugPuts 2 "    argv: $::argv"
 1538     }
 1539     DebugPuts    2 "tcltest::debug              = [debug]"
 1540     DebugPuts    2 "tcltest::testsDirectory     = [testsDirectory]"
 1541     DebugPuts    2 "tcltest::workingDirectory   = [workingDirectory]"
 1542     DebugPuts    2 "tcltest::temporaryDirectory = [temporaryDirectory]"
 1543     DebugPuts    2 "tcltest::outputChannel      = [outputChannel]"
 1544     DebugPuts    2 "tcltest::errorChannel       = [errorChannel]"
 1545     DebugPuts    2 "Original environment (tcltest::originalEnv):"
 1546     DebugPArray  2 originalEnv
 1547     DebugPuts    2 "Constraints:"
 1548     DebugPArray  2 testConstraints
 1549 }
 1550 
 1551 #####################################################################
 1552 
 1553 # Code to run the tests goes here.
 1554 
 1555 # tcltest::TestPuts --
 1556 #
 1557 #	Used to redefine puts in test environment.  Stores whatever goes
 1558 #	out on stdout in tcltest::outData and stderr in errData before
 1559 #	sending it on to the regular puts.
 1560 #
 1561 # Arguments:
 1562 #	same as standard puts
 1563 #
 1564 # Results:
 1565 #	none
 1566 #
 1567 # Side effects:
 1568 #       Intercepts puts; data that would otherwise go to stdout, stderr,
 1569 #	or file channels specified in outputChannel and errorChannel
 1570 #	does not get sent to the normal puts function.
 1571 namespace eval tcltest::Replace {
 1572     namespace export puts
 1573 }
 1574 proc tcltest::Replace::puts {args} {
 1575     variable [namespace parent]::outData
 1576     variable [namespace parent]::errData
 1577     switch [llength $args] {
 1578 	1 {
 1579 	    # Only the string to be printed is specified
 1580 	    append outData [lindex $args 0]\n
 1581 	    return
 1582 	    # return [Puts [lindex $args 0]]
 1583 	}
 1584 	2 {
 1585 	    # Either -nonewline or channelId has been specified
 1586 	    if {[lindex $args 0] eq "-nonewline"} {
 1587 		append outData [lindex $args end]
 1588 		return
 1589 		# return [Puts -nonewline [lindex $args end]]
 1590 	    } else {
 1591 		set channel [lindex $args 0]
 1592 		set newline \n
 1593 	    }
 1594 	}
 1595 	3 {
 1596 	    if {[lindex $args 0] eq "-nonewline"} {
 1597 		# Both -nonewline and channelId are specified, unless
 1598 		# it's an error.  -nonewline is supposed to be argv[0].
 1599 		set channel [lindex $args 1]
 1600 		set newline ""
 1601 	    }
 1602 	}
 1603     }
 1604 
 1605     if {[info exists channel]} {
 1606 	if {$channel in [list [[namespace parent]::outputChannel] stdout]} {
 1607 	    append outData [lindex $args end]$newline
 1608 	    return
 1609 	} elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} {
 1610 	    append errData [lindex $args end]$newline
 1611 	    return
 1612 	}
 1613     }
 1614 
 1615     # If we haven't returned by now, we don't know how to handle the
 1616     # input.  Let puts handle it.
 1617     return [Puts {*}$args]
 1618 }
 1619 
 1620 # tcltest::Eval --
 1621 #
 1622 #	Evaluate the script in the test environment.  If ignoreOutput is
 1623 #       false, store data sent to stderr and stdout in outData and
 1624 #       errData.  Otherwise, ignore this output altogether.
 1625 #
 1626 # Arguments:
 1627 #	script             Script to evaluate
 1628 #       ?ignoreOutput?     Indicates whether or not to ignore output
 1629 #			   sent to stdout & stderr
 1630 #
 1631 # Results:
 1632 #	result from running the script
 1633 #
 1634 # Side effects:
 1635 #	Empties the contents of outData and errData before running a
 1636 #	test if ignoreOutput is set to 0.
 1637 
 1638 proc tcltest::Eval {script {ignoreOutput 1}} {
 1639     variable outData
 1640     variable errData
 1641     DebugPuts 3 "[lindex [info level 0] 0] called"
 1642     if {!$ignoreOutput} {
 1643 	set outData {}
 1644 	set errData {}
 1645 	rename ::puts [namespace current]::Replace::Puts
 1646 	namespace eval :: [list namespace import [namespace origin Replace::puts]]
 1647 	namespace import Replace::puts
 1648     }
 1649     set result [uplevel 1 $script]
 1650     if {!$ignoreOutput} {
 1651 	namespace forget puts
 1652 	namespace eval :: namespace forget puts
 1653 	rename [namespace current]::Replace::Puts ::puts
 1654     }
 1655     return $result
 1656 }
 1657 
 1658 # tcltest::CompareStrings --
 1659 #
 1660 #	compares the expected answer to the actual answer, depending on
 1661 #	the mode provided.  Mode determines whether a regexp, exact,
 1662 #	glob or custom comparison is done.
 1663 #
 1664 # Arguments:
 1665 #	actual - string containing the actual result
 1666 #       expected - pattern to be matched against
 1667 #       mode - type of comparison to be done
 1668 #
 1669 # Results:
 1670 #	result of the match
 1671 #
 1672 # Side effects:
 1673 #	None.
 1674 
 1675 proc tcltest::CompareStrings {actual expected mode} {
 1676     variable CustomMatch
 1677     if {![info exists CustomMatch($mode)]} {
 1678         return -code error "No matching command registered for `-match $mode'"
 1679     }
 1680     set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
 1681     if {[catch {expr {$match && $match}} result]} {
 1682 	return -code error "Invalid result from `-match $mode' command: $result"
 1683     }
 1684     return $match
 1685 }
 1686 
 1687 # tcltest::customMatch --
 1688 #
 1689 #	registers a command to be called when a particular type of
 1690 #	matching is required.
 1691 #
 1692 # Arguments:
 1693 #	nickname - Keyword for the type of matching
 1694 #	cmd - Incomplete command that implements that type of matching
 1695 #		when completed with expected string and actual string
 1696 #		and then evaluated.
 1697 #
 1698 # Results:
 1699 #	None.
 1700 #
 1701 # Side effects:
 1702 #	Sets the variable tcltest::CustomMatch
 1703 
 1704 proc tcltest::customMatch {mode script} {
 1705     variable CustomMatch
 1706     if {![info complete $script]} {
 1707 	return -code error \
 1708 		"invalid customMatch script; can't evaluate after completion"
 1709     }
 1710     set CustomMatch($mode) $script
 1711 }
 1712 
 1713 # tcltest::SubstArguments list
 1714 #
 1715 # This helper function takes in a list of words, then perform a
 1716 # substitution on the list as though each word in the list is a separate
 1717 # argument to the Tcl function.  For example, if this function is
 1718 # invoked as:
 1719 #
 1720 #      SubstArguments {$a {$a}}
 1721 #
 1722 # Then it is as though the function is invoked as:
 1723 #
 1724 #      SubstArguments $a {$a}
 1725 #
 1726 # This code is adapted from Paul Duffin's function "SplitIntoWords".
 1727 # The original function can be found  on:
 1728 #
 1729 #      http://purl.org/thecliff/tcl/wiki/858.html
 1730 #
 1731 # Results:
 1732 #     a list containing the result of the substitution
 1733 #
 1734 # Exceptions:
 1735 #     An error may occur if the list containing unbalanced quote or
 1736 #     unknown variable.
 1737 #
 1738 # Side Effects:
 1739 #     None.
 1740 #
 1741 
 1742 proc tcltest::SubstArguments {argList} {
 1743 
 1744     # We need to split the argList up into tokens but cannot use list
 1745     # operations as they throw away some significant quoting, and
 1746     # [split] ignores braces as it should.  Therefore what we do is
 1747     # gradually build up a string out of whitespace seperated strings.
 1748     # We cannot use [split] to split the argList into whitespace
 1749     # separated strings as it throws away the whitespace which maybe
 1750     # important so we have to do it all by hand.
 1751 
 1752     set result {}
 1753     set token ""
 1754 
 1755     while {[string length $argList]} {
 1756         # Look for the next word containing a quote: " { }
 1757         if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
 1758 		$argList all]} {
 1759             # Get the text leading up to this word, but not including
 1760 	    # this word, from the argList.
 1761             set text [string range $argList 0 \
 1762 		    [expr {[lindex $all 0] - 1}]]
 1763             # Get the word with the quote
 1764             set word [string range $argList \
 1765                     [lindex $all 0] [lindex $all 1]]
 1766 
 1767             # Remove all text up to and including the word from the
 1768             # argList.
 1769             set argList [string range $argList \
 1770                     [expr {[lindex $all 1] + 1}] end]
 1771         } else {
 1772             # Take everything up to the end of the argList.
 1773             set text $argList
 1774             set word {}
 1775             set argList {}
 1776         }
 1777 
 1778         if {$token ne {}} {
 1779             # If we saw a word with quote before, then there is a
 1780             # multi-word token starting with that word.  In this case,
 1781             # add the text and the current word to this token.
 1782             append token $text $word
 1783         } else {
 1784             # Add the text to the result.  There is no need to parse
 1785             # the text because it couldn't be a part of any multi-word
 1786             # token.  Then start a new multi-word token with the word
 1787             # because we need to pass this token to the Tcl parser to
 1788             # check for balancing quotes
 1789             append result $text
 1790             set token $word
 1791         }
 1792 
 1793         if { [catch {llength $token} length] == 0 && $length == 1} {
 1794             # The token is a valid list so add it to the result.
 1795             # lappend result [string trim $token]
 1796             append result \{$token\}
 1797             set token {}
 1798         }
 1799     }
 1800 
 1801     # If the last token has not been added to the list then there
 1802     # is a problem.
 1803     if { [string length $token] } {
 1804         error "incomplete token \"$token\""
 1805     }
 1806 
 1807     return $result
 1808 }
 1809 
 1810 
 1811 # tcltest::test --
 1812 #
 1813 # This procedure runs a test and prints an error message if the test
 1814 # fails.  If verbose has been set, it also prints a message even if the
 1815 # test succeeds.  The test will be skipped if it doesn't match the
 1816 # match variable, if it matches an element in skip, or if one of the
 1817 # elements of "constraints" turns out not to be true.
 1818 #
 1819 # If testLevel is 1, then this is a top level test, and we record
 1820 # pass/fail information; otherwise, this information is not logged and
 1821 # is not added to running totals.
 1822 #
 1823 # Attributes:
 1824 #   Only description is a required attribute.  All others are optional.
 1825 #   Default values are indicated.
 1826 #
 1827 #   constraints -	A list of one or more keywords, each of which
 1828 #			must be the name of an element in the array
 1829 #			"testConstraints".  If any of these elements is
 1830 #			zero, the test is skipped. This attribute is
 1831 #			optional; default is {}
 1832 #   body -	        Script to run to carry out the test.  It must
 1833 #		        return a result that can be checked for
 1834 #		        correctness.  This attribute is optional;
 1835 #                       default is {}
 1836 #   result -	        Expected result from script.  This attribute is
 1837 #                       optional; default is {}.
 1838 #   output -            Expected output sent to stdout.  This attribute
 1839 #                       is optional; default is {}.
 1840 #   errorOutput -       Expected output sent to stderr.  This attribute
 1841 #                       is optional; default is {}.
 1842 #   returnCodes -       Expected return codes.  This attribute is
 1843 #                       optional; default is {0 2}.
 1844 #   errorCode -         Expected error code.  This attribute is
 1845 #                       optional; default is {*}. It is a glob pattern.
 1846 #                       If given, returnCodes defaults to {1}.
 1847 #   setup -             Code to run before $script (above).  This
 1848 #                       attribute is optional; default is {}.
 1849 #   cleanup -           Code to run after $script (above).  This
 1850 #                       attribute is optional; default is {}.
 1851 #   match -             specifies type of matching to do on result,
 1852 #                       output, errorOutput; this must be a string
 1853 #			previously registered by a call to [customMatch].
 1854 #			The strings exact, glob, and regexp are pre-registered
 1855 #			by the tcltest package.  Default value is exact.
 1856 #
 1857 # Arguments:
 1858 #   name -		Name of test, in the form foo-1.2.
 1859 #   description -	Short textual description of the test, to
 1860 #  		  	help humans understand what it does.
 1861 #
 1862 # Results:
 1863 #	None.
 1864 #
 1865 # Side effects:
 1866 #       Just about anything is possible depending on the test.
 1867 #
 1868 
 1869 proc tcltest::test {name description args} {
 1870     global tcl_platform
 1871     variable testLevel
 1872     variable coreModTime
 1873     DebugPuts 3 "test $name $args"
 1874     DebugDo 1 {
 1875 	variable TestNames
 1876 	catch {
 1877 	    puts "test name '$name' re-used; prior use in $TestNames($name)"
 1878 	}
 1879 	set TestNames($name) [info script]
 1880     }
 1881 
 1882     FillFilesExisted
 1883     incr testLevel
 1884 
 1885     # Pre-define everything to null except output and errorOutput.  We
 1886     # determine whether or not to trap output based on whether or not
 1887     # these variables (output & errorOutput) are defined.
 1888     lassign {} constraints setup cleanup body result returnCodes errorCode match
 1889 
 1890     # Set the default match mode
 1891     set match exact
 1892 
 1893     # Set the default match values for return codes (0 is the standard
 1894     # expected return value if everything went well; 2 represents
 1895     # 'return' being used in the test script).
 1896     set returnCodes [list 0 2]
 1897 
 1898     # Set the default error code pattern
 1899     set errorCode "*"
 1900 
 1901     # The old test format can't have a 3rd argument (constraints or
 1902     # script) that starts with '-'.
 1903     if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} {
 1904 	if {[llength $args] == 1} {
 1905 	    set list [SubstArguments [lindex $args 0]]
 1906 	    foreach {element value} $list {
 1907 		set testAttributes($element) $value
 1908 	    }
 1909 	    foreach item {constraints match setup body cleanup \
 1910 		    result returnCodes errorCode output errorOutput} {
 1911 		if {[info exists testAttributes(-$item)]} {
 1912 		    set testAttributes(-$item) [uplevel 1 \
 1913 			    ::concat $testAttributes(-$item)]
 1914 		}
 1915 	    }
 1916 	} else {
 1917 	    array set testAttributes $args
 1918 	}
 1919 
 1920 	set validFlags {-setup -cleanup -body -result -returnCodes \
 1921 		-errorCode -match -output -errorOutput -constraints}
 1922 
 1923 	foreach flag [array names testAttributes] {
 1924 	    if {$flag ni $validFlags} {
 1925 		incr testLevel -1
 1926 		set sorted [lsort $validFlags]
 1927 		set options [join [lrange $sorted 0 end-1] ", "]
 1928 		append options ", or [lindex $sorted end]"
 1929 		return -code error "bad option \"$flag\": must be $options"
 1930 	    }
 1931 	}
 1932 
 1933 	# store whatever the user gave us
 1934 	foreach item [array names testAttributes] {
 1935 	    set [string trimleft $item "-"] $testAttributes($item)
 1936 	}
 1937 
 1938 	# Check the values supplied for -match
 1939 	variable CustomMatch
 1940 	if {$match ni [array names CustomMatch]} {
 1941 	    incr testLevel -1
 1942 	    set sorted [lsort [array names CustomMatch]]
 1943 	    set values [join [lrange $sorted 0 end-1] ", "]
 1944 	    append values ", or [lindex $sorted end]"
 1945 	    return -code error "bad -match value \"$match\":\
 1946 		    must be $values"
 1947 	}
 1948 
 1949 	# Replace symbolic valies supplied for -returnCodes
 1950 	foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
 1951 	    set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
 1952 	}
 1953         # errorCode without returnCode 1 is meaningless
 1954         if {$errorCode ne "*" && 1 ni $returnCodes} {
 1955             set returnCodes 1
 1956         }
 1957     } else {
 1958 	# This is parsing for the old test command format; it is here
 1959 	# for backward compatibility.
 1960 	set result [lindex $args end]
 1961 	if {[llength $args] == 2} {
 1962 	    set body [lindex $args 0]
 1963 	} elseif {[llength $args] == 3} {
 1964 	    set constraints [lindex $args 0]
 1965 	    set body [lindex $args 1]
 1966 	} else {
 1967 	    incr testLevel -1
 1968 	    return -code error "wrong # args:\
 1969 		    should be \"test name desc ?options?\""
 1970 	}
 1971     }
 1972 
 1973     if {[Skipped $name $constraints]} {
 1974 	incr testLevel -1
 1975 	return
 1976     }
 1977 
 1978     # Save information about the core file.
 1979     if {[preserveCore]} {
 1980 	if {[file exists [file join [workingDirectory] core]]} {
 1981 	    set coreModTime [file mtime [file join [workingDirectory] core]]
 1982 	}
 1983     }
 1984 
 1985     # First, run the setup script
 1986     set code [catch {uplevel 1 $setup} setupMsg]
 1987     if {$code == 1} {
 1988 	set errorInfo(setup) $::errorInfo
 1989 	set errorCodeRes(setup) $::errorCode
 1990     }
 1991     set setupFailure [expr {$code != 0}]
 1992 
 1993     # Only run the test body if the setup was successful
 1994     if {!$setupFailure} {
 1995 
 1996 	# Register startup time
 1997 	if {[IsVerbose msec] || [IsVerbose usec]} {
 1998 	    set timeStart [clock microseconds]
 1999 	}
 2000 
 2001 	# Verbose notification of $body start
 2002 	if {[IsVerbose start]} {
 2003 	    puts [outputChannel] "---- $name start"
 2004 	    flush [outputChannel]
 2005 	}
 2006 
 2007 	set command [list [namespace origin RunTest] $name $body]
 2008 	if {[info exists output] || [info exists errorOutput]} {
 2009 	    set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
 2010 	} else {
 2011 	    set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
 2012 	}
 2013 	lassign $testResult actualAnswer returnCode
 2014 	if {$returnCode == 1} {
 2015 	    set errorInfo(body) $::errorInfo
 2016 	    set errorCodeRes(body) $::errorCode
 2017 	}
 2018     }
 2019 
 2020     # check if the return code matched the expected return code
 2021     set codeFailure 0
 2022     if {!$setupFailure && ($returnCode ni $returnCodes)} {
 2023 	set codeFailure 1
 2024     }
 2025     set errorCodeFailure 0
 2026     if {!$setupFailure && !$codeFailure && $returnCode == 1 && \
 2027                 ![string match $errorCode $errorCodeRes(body)]} {
 2028 	set errorCodeFailure 1
 2029     }
 2030 
 2031     # If expected output/error strings exist, we have to compare
 2032     # them.  If the comparison fails, then so did the test.
 2033     set outputFailure 0
 2034     variable outData
 2035     if {[info exists output] && !$codeFailure} {
 2036 	if {[set outputCompare [catch {
 2037 	    CompareStrings $outData $output $match
 2038 	} outputMatch]] == 0} {
 2039 	    set outputFailure [expr {!$outputMatch}]
 2040 	} else {
 2041 	    set outputFailure 1
 2042 	}
 2043     }
 2044 
 2045     set errorFailure 0
 2046     variable errData
 2047     if {[info exists errorOutput] && !$codeFailure} {
 2048 	if {[set errorCompare [catch {
 2049 	    CompareStrings $errData $errorOutput $match
 2050 	} errorMatch]] == 0} {
 2051 	    set errorFailure [expr {!$errorMatch}]
 2052 	} else {
 2053 	    set errorFailure 1
 2054 	}
 2055     }
 2056 
 2057     # check if the answer matched the expected answer
 2058     # Only check if we ran the body of the test (no setup failure)
 2059     if {$setupFailure || $codeFailure} {
 2060 	set scriptFailure 0
 2061     } elseif {[set scriptCompare [catch {
 2062 	CompareStrings $actualAnswer $result $match
 2063     } scriptMatch]] == 0} {
 2064 	set scriptFailure [expr {!$scriptMatch}]
 2065     } else {
 2066 	set scriptFailure 1
 2067     }
 2068 
 2069     # Always run the cleanup script
 2070     set code [catch {uplevel 1 $cleanup} cleanupMsg]
 2071     if {$code == 1} {
 2072 	set errorInfo(cleanup) $::errorInfo
 2073 	set errorCodeRes(cleanup) $::errorCode
 2074     }
 2075     set cleanupFailure [expr {$code != 0}]
 2076 
 2077     set coreFailure 0
 2078     set coreMsg ""
 2079     # check for a core file first - if one was created by the test,
 2080     # then the test failed
 2081     if {[preserveCore]} {
 2082 	if {[file exists [file join [workingDirectory] core]]} {
 2083 	    # There's only a test failure if there is a core file
 2084 	    # and (1) there previously wasn't one or (2) the new
 2085 	    # one is different from the old one.
 2086 	    if {[info exists coreModTime]} {
 2087 		if {$coreModTime != [file mtime \
 2088 			[file join [workingDirectory] core]]} {
 2089 		    set coreFailure 1
 2090 		}
 2091 	    } else {
 2092 		set coreFailure 1
 2093 	    }
 2094 
 2095 	    if {([preserveCore] > 1) && ($coreFailure)} {
 2096 		append coreMsg "\nMoving file to:\
 2097 		    [file join [temporaryDirectory] core-$name]"
 2098 		catch {file rename -force -- \
 2099 		    [file join [workingDirectory] core] \
 2100 		    [file join [temporaryDirectory] core-$name]
 2101 		} msg
 2102 		if {$msg ne {}} {
 2103 		    append coreMsg "\nError:\
 2104 			Problem renaming core file: $msg"
 2105 		}
 2106 	    }
 2107 	}
 2108     }
 2109 
 2110     if {[IsVerbose msec] || [IsVerbose usec]} {
 2111 	set t [expr {[clock microseconds] - $timeStart}]
 2112 	if {[IsVerbose usec]} {
 2113 	    puts [outputChannel] "++++ $name took $t μs"
 2114 	}
 2115 	if {[IsVerbose msec]} {
 2116 	    puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms"
 2117 	}
 2118     }
 2119 
 2120     # if we didn't experience any failures, then we passed
 2121     variable numTests
 2122     if {!($setupFailure || $cleanupFailure || $coreFailure
 2123 	    || $outputFailure || $errorFailure || $codeFailure
 2124 	    || $errorCodeFailure || $scriptFailure)} {
 2125 	if {$testLevel == 1} {
 2126 	    incr numTests(Passed)
 2127 	    if {[IsVerbose pass]} {
 2128 		puts [outputChannel] "++++ $name PASSED"
 2129 	    }
 2130 	}
 2131 	incr testLevel -1
 2132 	return
 2133     }
 2134 
 2135     # We know the test failed, tally it...
 2136     if {$testLevel == 1} {
 2137 	incr numTests(Failed)
 2138     }
 2139 
 2140     # ... then report according to the type of failure
 2141     variable currentFailure true
 2142     if {![IsVerbose body]} {
 2143 	set body ""
 2144     }
 2145     puts [outputChannel] "\n"
 2146     if {[IsVerbose line]} {
 2147 	if {![catch {set testFrame [info frame -1]}] &&
 2148 		[dict get $testFrame type] eq "source"} {
 2149 	    set testFile [dict get $testFrame file]
 2150 	    set testLine [dict get $testFrame line]
 2151 	} else {
 2152 	    set testFile [file normalize [uplevel 1 {info script}]]
 2153 	    if {[file readable $testFile]} {
 2154 		set testFd [open $testFile r]
 2155 		set testLine [expr {[lsearch -regexp \
 2156 			[split [read $testFd] "\n"] \
 2157 			"^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
 2158 		close $testFd
 2159 	    }
 2160 	}
 2161 	if {[info exists testLine]} {
 2162 	    puts [outputChannel] "$testFile:$testLine: error: test failed:\
 2163 		    $name [string trim $description]"
 2164 	}
 2165     }
 2166     puts [outputChannel] "==== $name\
 2167 	    [string trim $description] FAILED"
 2168     if {[string length $body]} {
 2169 	puts [outputChannel] "==== Contents of test case:"
 2170 	puts [outputChannel] $body
 2171     }
 2172     if {$setupFailure} {
 2173 	puts [outputChannel] "---- Test setup\
 2174 		failed:\n$setupMsg"
 2175 	if {[info exists errorInfo(setup)]} {
 2176 	    puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
 2177 	    puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
 2178 	}
 2179     }
 2180     if {$scriptFailure} {
 2181 	if {$scriptCompare} {
 2182 	    puts [outputChannel] "---- Error testing result: $scriptMatch"
 2183 	} else {
 2184 	    puts [outputChannel] "---- Result was:\n$actualAnswer"
 2185 	    puts [outputChannel] "---- Result should have been\
 2186 		    ($match matching):\n$result"
 2187 	}
 2188     }
 2189     if {$errorCodeFailure} {
 2190 	puts [outputChannel] "---- Error code was: '$errorCodeRes(body)'"
 2191 	puts [outputChannel] "---- Error code should have been: '$errorCode'"
 2192     }
 2193     if {$codeFailure} {
 2194 	switch -- $returnCode {
 2195 	    0 { set msg "Test completed normally" }
 2196 	    1 { set msg "Test generated error" }
 2197 	    2 { set msg "Test generated return exception" }
 2198 	    3 { set msg "Test generated break exception" }
 2199 	    4 { set msg "Test generated continue exception" }
 2200 	    default { set msg "Test generated exception" }
 2201 	}
 2202 	puts [outputChannel] "---- $msg; Return code was: $returnCode"
 2203 	puts [outputChannel] "---- Return code should have been\
 2204 		one of: $returnCodes"
 2205 	if {[IsVerbose error]} {
 2206 	    if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
 2207 		puts [outputChannel] "---- errorInfo: $errorInfo(body)"
 2208 		puts [outputChannel] "---- errorCode: $errorCodeRes(body)"
 2209 	    }
 2210 	}
 2211     }
 2212     if {$outputFailure} {
 2213 	if {$outputCompare} {
 2214 	    puts [outputChannel] "---- Error testing output: $outputMatch"
 2215 	} else {
 2216 	    puts [outputChannel] "---- Output was:\n$outData"
 2217 	    puts [outputChannel] "---- Output should have been\
 2218 		    ($match matching):\n$output"
 2219 	}
 2220     }
 2221     if {$errorFailure} {
 2222 	if {$errorCompare} {
 2223 	    puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
 2224 	} else {
 2225 	    puts [outputChannel] "---- Error output was:\n$errData"
 2226 	    puts [outputChannel] "---- Error output should have\
 2227 		    been ($match matching):\n$errorOutput"
 2228 	}
 2229     }
 2230     if {$cleanupFailure} {
 2231 	puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
 2232 	if {[info exists errorInfo(cleanup)]} {
 2233 	    puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
 2234 	    puts [outputChannel] "---- errorCode(cleanup): $errorCodeRes(cleanup)"
 2235 	}
 2236     }
 2237     if {$coreFailure} {
 2238 	puts [outputChannel] "---- Core file produced while running\
 2239 		test!  $coreMsg"
 2240     }
 2241     puts [outputChannel] "==== $name FAILED\n"
 2242 
 2243     incr testLevel -1
 2244     return
 2245 }
 2246 
 2247 # Skipped --
 2248 #
 2249 # Given a test name and it constraints, returns a boolean indicating
 2250 # whether the current configuration says the test should be skipped.
 2251 #
 2252 # Side Effects:  Maintains tally of total tests seen and tests skipped.
 2253 #
 2254 proc tcltest::Skipped {name constraints} {
 2255     variable testLevel
 2256     variable numTests
 2257     variable testConstraints
 2258 
 2259     if {$testLevel == 1} {
 2260 	incr numTests(Total)
 2261     }
 2262     # skip the test if it's name matches an element of skip
 2263     foreach pattern [skip] {
 2264 	if {[string match $pattern $name]} {
 2265 	    if {$testLevel == 1} {
 2266 		incr numTests(Skipped)
 2267 		DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
 2268 	    }
 2269 	    return 1
 2270 	}
 2271     }
 2272     # skip the test if it's name doesn't match any element of match
 2273     set ok 0
 2274     foreach pattern [match] {
 2275 	if {[string match $pattern $name]} {
 2276 	    set ok 1
 2277 	    break
 2278 	}
 2279     }
 2280     if {!$ok} {
 2281 	if {$testLevel == 1} {
 2282 	    incr numTests(Skipped)
 2283 	    DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
 2284 	}
 2285 	return 1
 2286     }
 2287     if {$constraints eq {}} {
 2288 	# If we're limited to the listed constraints and there aren't
 2289 	# any listed, then we shouldn't run the test.
 2290 	if {[limitConstraints]} {
 2291 	    AddToSkippedBecause userSpecifiedLimitConstraint
 2292 	    if {$testLevel == 1} {
 2293 		incr numTests(Skipped)
 2294 	    }
 2295 	    return 1
 2296 	}
 2297     } else {
 2298 	# "constraints" argument exists;
 2299 	# make sure that the constraints are satisfied.
 2300 
 2301 	set doTest 0
 2302 	if {[string match {*[$\[]*} $constraints] != 0} {
 2303 	    # full expression, e.g. {$foo > [info tclversion]}
 2304 	    catch {set doTest [uplevel #0 [list expr $constraints]]}
 2305 	} elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
 2306 	    # something like {a || b} should be turned into
 2307 	    # $testConstraints(a) || $testConstraints(b).
 2308 	    regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
 2309 	    catch {set doTest [eval [list expr $c]]}
 2310 	} elseif {![catch {llength $constraints}]} {
 2311 	    # just simple constraints such as {unixOnly fonts}.
 2312 	    set doTest 1
 2313 	    foreach constraint $constraints {
 2314 		if {(![info exists testConstraints($constraint)]) \
 2315 			|| (!$testConstraints($constraint))} {
 2316 		    set doTest 0
 2317 
 2318 		    # store the constraint that kept the test from
 2319 		    # running
 2320 		    set constraints $constraint
 2321 		    break
 2322 		}
 2323 	    }
 2324 	}
 2325 
 2326 	if {!$doTest} {
 2327 	    if {[IsVerbose skip]} {
 2328 		puts [outputChannel] "++++ $name SKIPPED: $constraints"
 2329 	    }
 2330 
 2331 	    if {$testLevel == 1} {
 2332 		incr numTests(Skipped)
 2333 		AddToSkippedBecause $constraints
 2334 	    }
 2335 	    return 1
 2336 	}
 2337     }
 2338     return 0
 2339 }
 2340 
 2341 # RunTest --
 2342 #
 2343 # This is where the body of a test is evaluated.  The combination of
 2344 # [RunTest] and [Eval] allows the output and error output of the test
 2345 # body to be captured for comparison against the expected values.
 2346 
 2347 proc tcltest::RunTest {name script} {
 2348     DebugPuts 3 "Running $name {$script}"
 2349 
 2350     # If there is no "memory" command (because memory debugging isn't
 2351     # enabled), then don't attempt to use the command.
 2352 
 2353     if {[llength [info commands memory]] == 1} {
 2354 	memory tag $name
 2355     }
 2356 
 2357     set code [catch {uplevel 1 $script} actualAnswer]
 2358 
 2359     return [list $actualAnswer $code]
 2360 }
 2361 
 2362 #####################################################################
 2363 
 2364 # tcltest::cleanupTestsHook --
 2365 #
 2366 #	This hook allows a harness that builds upon tcltest to specify
 2367 #       additional things that should be done at cleanup.
 2368 #
 2369 
 2370 if {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
 2371     proc tcltest::cleanupTestsHook {} {}
 2372 }
 2373 
 2374 # tcltest::cleanupTests --
 2375 #
 2376 # Remove files and dirs created using the makeFile and makeDirectory
 2377 # commands since the last time this proc was invoked.
 2378 #
 2379 # Print the names of the files created without the makeFile command
 2380 # since the tests were invoked.
 2381 #
 2382 # Print the number tests (total, passed, failed, and skipped) since the
 2383 # tests were invoked.
 2384 #
 2385 # Restore original environment (as reported by special variable env).
 2386 #
 2387 # Arguments:
 2388 #      calledFromAllFile - if 0, behave as if we are running a single
 2389 #      test file within an entire suite of tests.  if we aren't running
 2390 #      a single test file, then don't report status.  check for new
 2391 #      files created during the test run and report on them.  if 1,
 2392 #      report collated status from all the test file runs.
 2393 #
 2394 # Results:
 2395 #      None.
 2396 #
 2397 # Side Effects:
 2398 #      None
 2399 #
 2400 
 2401 proc tcltest::cleanupTests {{calledFromAllFile 0}} {
 2402     variable filesMade
 2403     variable filesExisted
 2404     variable createdNewFiles
 2405     variable testSingleFile
 2406     variable numTests
 2407     variable numTestFiles
 2408     variable failFiles
 2409     variable skippedBecause
 2410     variable currentFailure
 2411     variable originalEnv
 2412     variable originalTclPlatform
 2413     variable coreModTime
 2414 
 2415     FillFilesExisted
 2416     set testFileName [file tail [info script]]
 2417 
 2418     # Hook to handle reporting to a parent interpreter
 2419     if {[llength [info commands [namespace current]::ReportToMaster]]} {
 2420 	ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \
 2421 	    $numTests(Failed) [array get skippedBecause] \
 2422 	    [array get createdNewFiles]
 2423 	set testSingleFile false
 2424     }
 2425 
 2426     # Call the cleanup hook
 2427     cleanupTestsHook
 2428 
 2429     # Remove files and directories created by the makeFile and
 2430     # makeDirectory procedures.  Record the names of files in
 2431     # workingDirectory that were not pre-existing, and associate them
 2432     # with the test file that created them.
 2433 
 2434     if {!$calledFromAllFile} {
 2435 	foreach file $filesMade {
 2436 	    if {[file exists $file]} {
 2437 		DebugDo 1 {Warn "cleanupTests deleting $file..."}
 2438 		catch {file delete -force -- $file}
 2439 	    }
 2440 	}
 2441 	set currentFiles {}
 2442 	foreach file [glob -nocomplain \
 2443 		-directory [temporaryDirectory] *] {
 2444 	    lappend currentFiles [file tail $file]
 2445 	}
 2446 	set newFiles {}
 2447 	foreach file $currentFiles {
 2448 	    if {$file ni $filesExisted} {
 2449 		lappend newFiles $file
 2450 	    }
 2451 	}
 2452 	set filesExisted $currentFiles
 2453 	if {[llength $newFiles] > 0} {
 2454 	    set createdNewFiles($testFileName) $newFiles
 2455 	}
 2456     }
 2457 
 2458     if {$calledFromAllFile || $testSingleFile} {
 2459 
 2460 	# print stats
 2461 
 2462 	puts -nonewline [outputChannel] "$testFileName:"
 2463 	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
 2464 	    puts -nonewline [outputChannel] \
 2465 		    "\t$index\t$numTests($index)"
 2466 	}
 2467 	puts [outputChannel] ""
 2468 
 2469 	# print number test files sourced
 2470 	# print names of files that ran tests which failed
 2471 
 2472 	if {$calledFromAllFile} {
 2473 	    puts [outputChannel] \
 2474 		    "Sourced $numTestFiles Test Files."
 2475 	    set numTestFiles 0
 2476 	    if {[llength $failFiles] > 0} {
 2477 		puts [outputChannel] \
 2478 			"Files with failing tests: $failFiles"
 2479 		set failFiles {}
 2480 	    }
 2481 	}
 2482 
 2483 	# if any tests were skipped, print the constraints that kept
 2484 	# them from running.
 2485 
 2486 	set constraintList [array names skippedBecause]
 2487 	if {[llength $constraintList] > 0} {
 2488 	    puts [outputChannel] \
 2489 		    "Number of tests skipped for each constraint:"
 2490 	    foreach constraint [lsort $constraintList] {
 2491 		puts [outputChannel] \
 2492 			"\t$skippedBecause($constraint)\t$constraint"
 2493 		unset skippedBecause($constraint)
 2494 	    }
 2495 	}
 2496 
 2497 	# report the names of test files in createdNewFiles, and reset
 2498 	# the array to be empty.
 2499 
 2500 	set testFilesThatTurded [lsort [array names createdNewFiles]]
 2501 	if {[llength $testFilesThatTurded] > 0} {
 2502 	    puts [outputChannel] "Warning: files left behind:"
 2503 	    foreach testFile $testFilesThatTurded {
 2504 		puts [outputChannel] \
 2505 			"\t$testFile:\t$createdNewFiles($testFile)"
 2506 		unset createdNewFiles($testFile)
 2507 	    }
 2508 	}
 2509 
 2510 	# reset filesMade, filesExisted, and numTests
 2511 
 2512 	set filesMade {}
 2513 	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
 2514 	    set numTests($index) 0
 2515 	}
 2516 
 2517 	# exit only if running Tk in non-interactive mode
 2518 	# This should be changed to determine if an event
 2519 	# loop is running, which is the real issue.
 2520 	# Actually, this doesn't belong here at all.  A package
 2521 	# really has no business [exit]-ing an application.
 2522 	if {![catch {package present Tk}] && ![testConstraint interactive]} {
 2523 	    exit
 2524 	}
 2525     } else {
 2526 
 2527 	# if we're deferring stat-reporting until all files are sourced,
 2528 	# then add current file to failFile list if any tests in this
 2529 	# file failed
 2530 
 2531 	if {$currentFailure && ($testFileName ni $failFiles)} {
 2532 	    lappend failFiles $testFileName
 2533 	}
 2534 	set currentFailure false
 2535 
 2536 	# restore the environment to the state it was in before this package
 2537 	# was loaded
 2538 
 2539 	set newEnv {}
 2540 	set changedEnv {}
 2541 	set removedEnv {}
 2542 	foreach index [array names ::env] {
 2543 	    if {![info exists originalEnv($index)]} {
 2544 		lappend newEnv $index
 2545 		unset ::env($index)
 2546 	    }
 2547 	}
 2548 	foreach index [array names originalEnv] {
 2549 	    if {![info exists ::env($index)]} {
 2550 		lappend removedEnv $index
 2551 		set ::env($index) $originalEnv($index)
 2552 	    } elseif {$::env($index) ne $originalEnv($index)} {
 2553 		lappend changedEnv $index
 2554 		set ::env($index) $originalEnv($index)
 2555 	    }
 2556 	}
 2557 	if {[llength $newEnv] > 0} {
 2558 	    puts [outputChannel] \
 2559 		    "env array elements created:\t$newEnv"
 2560 	}
 2561 	if {[llength $changedEnv] > 0} {
 2562 	    puts [outputChannel] \
 2563 		    "env array elements changed:\t$changedEnv"
 2564 	}
 2565 	if {[llength $removedEnv] > 0} {
 2566 	    puts [outputChannel] \
 2567 		    "env array elements removed:\t$removedEnv"
 2568 	}
 2569 
 2570 	set changedTclPlatform {}
 2571 	foreach index [array names originalTclPlatform] {
 2572 	    if {$::tcl_platform($index) \
 2573 		    != $originalTclPlatform($index)} {
 2574 		lappend changedTclPlatform $index
 2575 		set ::tcl_platform($index) $originalTclPlatform($index)
 2576 	    }
 2577 	}
 2578 	if {[llength $changedTclPlatform] > 0} {
 2579 	    puts [outputChannel] "tcl_platform array elements\
 2580 		    changed:\t$changedTclPlatform"
 2581 	}
 2582 
 2583 	if {[file exists [file join [workingDirectory] core]]} {
 2584 	    if {[preserveCore] > 1} {
 2585 		puts "rename core file (> 1)"
 2586 		puts [outputChannel] "produced core file! \
 2587 			Moving file to: \
 2588 			[file join [temporaryDirectory] core-$testFileName]"
 2589 		catch {file rename -force -- \
 2590 			[file join [workingDirectory] core] \
 2591 			[file join [temporaryDirectory] core-$testFileName]
 2592 		} msg
 2593 		if {$msg ne {}} {
 2594 		    PrintError "Problem renaming file: $msg"
 2595 		}
 2596 	    } else {
 2597 		# Print a message if there is a core file and (1) there
 2598 		# previously wasn't one or (2) the new one is different
 2599 		# from the old one.
 2600 
 2601 		if {[info exists coreModTime]} {
 2602 		    if {$coreModTime != [file mtime \
 2603 			    [file join [workingDirectory] core]]} {
 2604 			puts [outputChannel] "A core file was created!"
 2605 		    }
 2606 		} else {
 2607 		    puts [outputChannel] "A core file was created!"
 2608 		}
 2609 	    }
 2610 	}
 2611     }
 2612     flush [outputChannel]
 2613     flush [errorChannel]
 2614     return
 2615 }
 2616 
 2617 #####################################################################
 2618 
 2619 # Procs that determine which tests/test files to run
 2620 
 2621 # tcltest::GetMatchingFiles
 2622 #
 2623 #       Looks at the patterns given to match and skip files and uses
 2624 #	them to put together a list of the tests that will be run.
 2625 #
 2626 # Arguments:
 2627 #       directory to search
 2628 #
 2629 # Results:
 2630 #       The constructed list is returned to the user.  This will
 2631 #	primarily be used in 'all.tcl' files.  It is used in
 2632 #	runAllTests.
 2633 #
 2634 # Side Effects:
 2635 #       None
 2636 
 2637 # a lower case version is needed for compatibility with tcltest 1.0
 2638 proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args}
 2639 
 2640 proc tcltest::GetMatchingFiles { args } {
 2641     if {[llength $args]} {
 2642 	set dirList $args
 2643     } else {
 2644 	# Finding tests only in [testsDirectory] is normal operation.
 2645 	# This procedure is written to accept multiple directory arguments
 2646 	# only to satisfy version 1 compatibility.
 2647 	set dirList [list [testsDirectory]]
 2648     }
 2649 
 2650     set matchingFiles [list]
 2651     foreach directory $dirList {
 2652 
 2653 	# List files in $directory that match patterns to run.
 2654 	set matchFileList [list]
 2655 	foreach match [matchFiles] {
 2656 	    set matchFileList [concat $matchFileList \
 2657 		    [glob -directory $directory -types {b c f p s} \
 2658 		    -nocomplain -- $match]]
 2659 	}
 2660 
 2661 	# List files in $directory that match patterns to skip.
 2662 	set skipFileList [list]
 2663 	foreach skip [skipFiles] {
 2664 	    set skipFileList [concat $skipFileList \
 2665 		    [glob -directory $directory -types {b c f p s} \
 2666 		    -nocomplain -- $skip]]
 2667 	}
 2668 
 2669 	# Add to result list all files in match list and not in skip list
 2670 	foreach file $matchFileList {
 2671 	    if {$file ni $skipFileList} {
 2672 		lappend matchingFiles $file
 2673 	    }
 2674 	}
 2675     }
 2676 
 2677     if {[llength $matchingFiles] == 0} {
 2678 	PrintError "No test files remain after applying your match and\
 2679 		skip patterns!"
 2680     }
 2681     return $matchingFiles
 2682 }
 2683 
 2684 # tcltest::GetMatchingDirectories --
 2685 #
 2686 #	Looks at the patterns given to match and skip directories and
 2687 #	uses them to put together a list of the test directories that we
 2688 #	should attempt to run.  (Only subdirectories containing an
 2689 #	"all.tcl" file are put into the list.)
 2690 #
 2691 # Arguments:
 2692 #	root directory from which to search
 2693 #
 2694 # Results:
 2695 #	The constructed list is returned to the user.  This is used in
 2696 #	the primary all.tcl file.
 2697 #
 2698 # Side Effects:
 2699 #       None.
 2700 
 2701 proc tcltest::GetMatchingDirectories {rootdir} {
 2702 
 2703     # Determine the skip list first, to avoid [glob]-ing over subdirectories
 2704     # we're going to throw away anyway.  Be sure we skip the $rootdir if it
 2705     # comes up to avoid infinite loops.
 2706     set skipDirs [list $rootdir]
 2707     foreach pattern [skipDirectories] {
 2708 	set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
 2709 		-nocomplain -- $pattern]]
 2710     }
 2711 
 2712     # Now step through the matching directories, prune out the skipped ones
 2713     # as you go.
 2714     set matchDirs [list]
 2715     foreach pattern [matchDirectories] {
 2716 	foreach path [glob -directory $rootdir -types d -nocomplain -- \
 2717 		$pattern] {
 2718 	    if {$path ni $skipDirs} {
 2719 		set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
 2720 		if {[file exists [file join $path all.tcl]]} {
 2721 		    lappend matchDirs $path
 2722 		}
 2723 	    }
 2724 	}
 2725     }
 2726 
 2727     if {[llength $matchDirs] == 0} {
 2728 	DebugPuts 1 "No test directories remain after applying match\
 2729 		and skip patterns!"
 2730     }
 2731     return [lsort $matchDirs]
 2732 }
 2733 
 2734 # tcltest::runAllTests --
 2735 #
 2736 #	prints output and sources test files according to the match and
 2737 #	skip patterns provided.  after sourcing test files, it goes on
 2738 #	to source all.tcl files in matching test subdirectories.
 2739 #
 2740 # Arguments:
 2741 #	shell being tested
 2742 #
 2743 # Results:
 2744 #	Whether there were any failures.
 2745 #
 2746 # Side effects:
 2747 #	None.
 2748 
 2749 proc tcltest::runAllTests { {shell ""} } {
 2750     variable testSingleFile
 2751     variable numTestFiles
 2752     variable numTests
 2753     variable failFiles
 2754     variable DefaultValue
 2755     set failFilesAccum {}
 2756 
 2757     FillFilesExisted
 2758     if {[llength [info level 0]] == 1} {
 2759 	set shell [interpreter]
 2760     }
 2761 
 2762     set testSingleFile false
 2763 
 2764     puts [outputChannel] "Tests running in interp:  $shell"
 2765     puts [outputChannel] "Tests located in:  [testsDirectory]"
 2766     puts [outputChannel] "Tests running in:  [workingDirectory]"
 2767     puts [outputChannel] "Temporary files stored in\
 2768 	    [temporaryDirectory]"
 2769 
 2770     # [file system] first available in Tcl 8.4
 2771     if {![catch {file system [testsDirectory]} result]
 2772 	    && ([lindex $result 0] ne "native")} {
 2773 	# If we aren't running in the native filesystem, then we must
 2774 	# run the tests in a single process (via 'source'), because
 2775 	# trying to run then via a pipe will fail since the files don't
 2776 	# really exist.
 2777 	singleProcess 1
 2778     }
 2779 
 2780     if {[singleProcess]} {
 2781 	puts [outputChannel] \
 2782 		"Test files sourced into current interpreter"
 2783     } else {
 2784 	puts [outputChannel] \
 2785 		"Test files run in separate interpreters"
 2786     }
 2787     if {[llength [skip]] > 0} {
 2788 	puts [outputChannel] "Skipping tests that match:  [skip]"
 2789     }
 2790     puts [outputChannel] "Running tests that match:  [match]"
 2791 
 2792     if {[llength [skipFiles]] > 0} {
 2793 	puts [outputChannel] \
 2794 		"Skipping test files that match:  [skipFiles]"
 2795     }
 2796     if {[llength [matchFiles]] > 0} {
 2797 	puts [outputChannel] \
 2798 		"Only running test files that match:  [matchFiles]"
 2799     }
 2800 
 2801     set timeCmd {clock format [clock seconds]}
 2802     puts [outputChannel] "Tests began at [eval $timeCmd]"
 2803 
 2804     # Run each of the specified tests
 2805     foreach file [lsort [GetMatchingFiles]] {
 2806 	set tail [file tail $file]
 2807 	puts [outputChannel] $tail
 2808 	flush [outputChannel]
 2809 
 2810 	if {[singleProcess]} {
 2811 	    incr numTestFiles
 2812 	    uplevel 1 [list ::source $file]
 2813 	} else {
 2814 	    # Pass along our configuration to the child processes.
 2815 	    # EXCEPT for the -outfile, because the parent process
 2816 	    # needs to read and process output of children.
 2817 	    set childargv [list]
 2818 	    foreach opt [Configure] {
 2819 		if {$opt eq "-outfile"} {continue}
 2820 		set value [Configure $opt]
 2821 		# Don't bother passing default configuration options
 2822 		if {$value eq $DefaultValue($opt)} {
 2823 			continue
 2824 		}
 2825 		lappend childargv $opt $value
 2826 	    }
 2827 	    set cmd [linsert $childargv 0 | $shell $file]
 2828 	    if {[catch {
 2829 		incr numTestFiles
 2830 		set pipeFd [open $cmd "r"]
 2831 		while {[gets $pipeFd line] >= 0} {
 2832 		    if {[regexp [join {
 2833 			    {^([^:]+):\t}
 2834 			    {Total\t([0-9]+)\t}
 2835 			    {Passed\t([0-9]+)\t}
 2836 			    {Skipped\t([0-9]+)\t}
 2837 			    {Failed\t([0-9]+)}
 2838 			    } ""] $line null testFile \
 2839 			    Total Passed Skipped Failed]} {
 2840 			foreach index {Total Passed Skipped Failed} {
 2841 			    incr numTests($index) [set $index]
 2842 			}
 2843 			if {$Failed > 0} {
 2844 			    lappend failFiles $testFile
 2845 			    lappend failFilesAccum $testFile
 2846 			}
 2847 		    } elseif {[regexp [join {
 2848 			    {^Number of tests skipped }
 2849 			    {for each constraint:}
 2850 			    {|^\t(\d+)\t(.+)$}
 2851 			    } ""] $line match skipped constraint]} {
 2852 			if {[string match \t* $match]} {
 2853 			    AddToSkippedBecause $constraint $skipped
 2854 			}
 2855 		    } else {
 2856 			puts [outputChannel] $line
 2857 		    }
 2858 		}
 2859 		close $pipeFd
 2860 	    } msg]} {
 2861 		puts [outputChannel] "Test file error: $msg"
 2862 		# append the name of the test to a list to be reported
 2863 		# later
 2864 		lappend testFileFailures $file
 2865 	    }
 2866 	}
 2867     }
 2868 
 2869     # cleanup
 2870     puts [outputChannel] "\nTests ended at [eval $timeCmd]"
 2871     cleanupTests 1
 2872     if {[info exists testFileFailures]} {
 2873 	puts [outputChannel] "\nTest files exiting with errors:  \n"
 2874 	foreach file $testFileFailures {
 2875 	    puts [outputChannel] "  [file tail $file]\n"
 2876 	}
 2877     }
 2878 
 2879     # Checking for subdirectories in which to run tests
 2880     foreach directory [GetMatchingDirectories [testsDirectory]] {
 2881 	set dir [file tail $directory]
 2882 	puts [outputChannel] [string repeat ~ 44]
 2883 	puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
 2884 
 2885 	uplevel 1 [list ::source [file join $directory all.tcl]]
 2886 
 2887 	set endTime [eval $timeCmd]
 2888 	puts [outputChannel] "\n$dir test ended at $endTime"
 2889 	puts [outputChannel] ""
 2890 	puts [outputChannel] [string repeat ~ 44]
 2891     }
 2892     return [expr {[info exists testFileFailures] || [llength $failFilesAccum]}]
 2893 }
 2894 
 2895 #####################################################################
 2896 
 2897 # Test utility procs - not used in tcltest, but may be useful for
 2898 # testing.
 2899 
 2900 # tcltest::loadTestedCommands --
 2901 #
 2902 #     Uses the specified script to load the commands to test. Allowed to
 2903 #     be empty, as the tested commands could have been compiled into the
 2904 #     interpreter.
 2905 #
 2906 # Arguments
 2907 #     none
 2908 #
 2909 # Results
 2910 #     none
 2911 #
 2912 # Side Effects:
 2913 #     none.
 2914 
 2915 proc tcltest::loadTestedCommands {} {
 2916     return [uplevel 1 [loadScript]]
 2917 }
 2918 
 2919 # tcltest::saveState --
 2920 #
 2921 #	Save information regarding what procs and variables exist.
 2922 #
 2923 # Arguments:
 2924 #	none
 2925 #
 2926 # Results:
 2927 #	Modifies the variable saveState
 2928 #
 2929 # Side effects:
 2930 #	None.
 2931 
 2932 proc tcltest::saveState {} {
 2933     variable saveState
 2934     uplevel 1 [list ::set [namespace which -variable saveState]] \
 2935 	    {[::list [::info procs] [::info vars]]}
 2936     DebugPuts  2 "[lindex [info level 0] 0]: $saveState"
 2937     return
 2938 }
 2939 
 2940 # tcltest::restoreState --
 2941 #
 2942 #	Remove procs and variables that didn't exist before the call to
 2943 #       [saveState].
 2944 #
 2945 # Arguments:
 2946 #	none
 2947 #
 2948 # Results:
 2949 #	Removes procs and variables from your environment if they don't
 2950 #	exist in the saveState variable.
 2951 #
 2952 # Side effects:
 2953 #	None.
 2954 
 2955 proc tcltest::restoreState {} {
 2956     variable saveState
 2957     foreach p [uplevel 1 {::info procs}] {
 2958 	if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne
 2959 		[uplevel 1 [list ::namespace origin $p]])} {
 2960 
 2961 	    DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
 2962 	    uplevel 1 [list ::catch [list ::rename $p {}]]
 2963 	}
 2964     }
 2965     foreach p [uplevel 1 {::info vars}] {
 2966 	if {$p ni [lindex $saveState 1]} {
 2967 	    DebugPuts 2 "[lindex [info level 0] 0]:\
 2968 		    Removing variable $p"
 2969 	    uplevel 1 [list ::catch [list ::unset $p]]
 2970 	}
 2971     }
 2972     return
 2973 }
 2974 
 2975 # tcltest::normalizeMsg --
 2976 #
 2977 #	Removes "extra" newlines from a string.
 2978 #
 2979 # Arguments:
 2980 #	msg        String to be modified
 2981 #
 2982 # Results:
 2983 #	string with extra newlines removed
 2984 #
 2985 # Side effects:
 2986 #	None.
 2987 
 2988 proc tcltest::normalizeMsg {msg} {
 2989     regsub "\n$" [string tolower $msg] "" msg
 2990     set msg [string map [list "\n\n" "\n"] $msg]
 2991     return [string map [list "\n\}" "\}"] $msg]
 2992 }
 2993 
 2994 # tcltest::makeFile --
 2995 #
 2996 # Create a new file with the name <name>, and write <contents> to it.
 2997 #
 2998 # If this file hasn't been created via makeFile since the last time
 2999 # cleanupTests was called, add it to the $filesMade list, so it will be
 3000 # removed by the next call to cleanupTests.
 3001 #
 3002 # Arguments:
 3003 #	contents        content of the new file
 3004 #       name            name of the new file
 3005 #       directory       directory name for new file
 3006 #
 3007 # Results:
 3008 #	absolute path to the file created
 3009 #
 3010 # Side effects:
 3011 #	None.
 3012 
 3013 proc tcltest::makeFile {contents name {directory ""}} {
 3014     variable filesMade
 3015     FillFilesExisted
 3016 
 3017     if {[llength [info level 0]] == 3} {
 3018 	set directory [temporaryDirectory]
 3019     }
 3020 
 3021     set fullName [file join $directory $name]
 3022 
 3023     DebugPuts 3 "[lindex [info level 0] 0]:\
 3024 	     putting ``$contents'' into $fullName"
 3025 
 3026     set fd [open $fullName w]
 3027     chan configure $fd -translation lf
 3028     if {[string index $contents end] eq "\n"} {
 3029 	puts -nonewline $fd $contents
 3030     } else {
 3031 	puts $fd $contents
 3032     }
 3033     close $fd
 3034 
 3035     if {$fullName ni $filesMade} {
 3036 	lappend filesMade $fullName
 3037     }
 3038     return $fullName
 3039 }
 3040 
 3041 # tcltest::removeFile --
 3042 #
 3043 #	Removes the named file from the filesystem
 3044 #
 3045 # Arguments:
 3046 #	name          file to be removed
 3047 #       directory     directory from which to remove file
 3048 #
 3049 # Results:
 3050 #	return value from [file delete]
 3051 #
 3052 # Side effects:
 3053 #	None.
 3054 
 3055 proc tcltest::removeFile {name {directory ""}} {
 3056     variable filesMade
 3057     FillFilesExisted
 3058     if {[llength [info level 0]] == 2} {
 3059 	set directory [temporaryDirectory]
 3060     }
 3061     set fullName [file join $directory $name]
 3062     DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
 3063     set idx [lsearch -exact $filesMade $fullName]
 3064     set filesMade [lreplace $filesMade $idx $idx]
 3065     if {$idx == -1} {
 3066 	DebugDo 1 {
 3067 	    Warn "removeFile removing \"$fullName\":\n  not created by makeFile"
 3068 	}
 3069     }
 3070     if {![file isfile $fullName]} {
 3071 	DebugDo 1 {
 3072 	    Warn "removeFile removing \"$fullName\":\n  not a file"
 3073 	}
 3074     }
 3075     if {[catch {file delete -- $fullName} msg ]} {
 3076 	DebugDo 1 {
 3077 	    Warn "removeFile removing \"$fullName\":\n  failed: $msg"
 3078 	}
 3079     }
 3080     return
 3081 }
 3082 
 3083 # tcltest::makeDirectory --
 3084 #
 3085 # Create a new dir with the name <name>.
 3086 #
 3087 # If this dir hasn't been created via makeDirectory since the last time
 3088 # cleanupTests was called, add it to the $directoriesMade list, so it
 3089 # will be removed by the next call to cleanupTests.
 3090 #
 3091 # Arguments:
 3092 #       name            name of the new directory
 3093 #       directory       directory in which to create new dir
 3094 #
 3095 # Results:
 3096 #	absolute path to the directory created
 3097 #
 3098 # Side effects:
 3099 #	None.
 3100 
 3101 proc tcltest::makeDirectory {name {directory ""}} {
 3102     variable filesMade
 3103     FillFilesExisted
 3104     if {[llength [info level 0]] == 2} {
 3105 	set directory [temporaryDirectory]
 3106     }
 3107     set fullName [file join $directory $name]
 3108     DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
 3109     file mkdir $fullName
 3110     if {$fullName ni $filesMade} {
 3111 	lappend filesMade $fullName
 3112     }
 3113     return $fullName
 3114 }
 3115 
 3116 # tcltest::removeDirectory --
 3117 #
 3118 #	Removes a named directory from the file system.
 3119 #
 3120 # Arguments:
 3121 #	name          Name of the directory to remove
 3122 #       directory     Directory from which to remove
 3123 #
 3124 # Results:
 3125 #	return value from [file delete]
 3126 #
 3127 # Side effects:
 3128 #	None
 3129 
 3130 proc tcltest::removeDirectory {name {directory ""}} {
 3131     variable filesMade
 3132     FillFilesExisted
 3133     if {[llength [info level 0]] == 2} {
 3134 	set directory [temporaryDirectory]
 3135     }
 3136     set fullName [file join $directory $name]
 3137     DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
 3138     set idx [lsearch -exact $filesMade $fullName]
 3139     set filesMade [lreplace $filesMade $idx $idx]
 3140     if {$idx == -1} {
 3141 	DebugDo 1 {
 3142 	    Warn "removeDirectory removing \"$fullName\":\n  not created\
 3143 		    by makeDirectory"
 3144 	}
 3145     }
 3146     if {![file isdirectory $fullName]} {
 3147 	DebugDo 1 {
 3148 	    Warn "removeDirectory removing \"$fullName\":\n  not a directory"
 3149 	}
 3150     }
 3151     return [file delete -force -- $fullName]
 3152 }
 3153 
 3154 # tcltest::viewFile --
 3155 #
 3156 #	reads the content of a file and returns it
 3157 #
 3158 # Arguments:
 3159 #	name of the file to read
 3160 #       directory in which file is located
 3161 #
 3162 # Results:
 3163 #	content of the named file
 3164 #
 3165 # Side effects:
 3166 #	None.
 3167 
 3168 proc tcltest::viewFile {name {directory ""}} {
 3169     FillFilesExisted
 3170     if {[llength [info level 0]] == 2} {
 3171 	set directory [temporaryDirectory]
 3172     }
 3173     set fullName [file join $directory $name]
 3174     set f [open $fullName]
 3175     set data [read -nonewline $f]
 3176     close $f
 3177     return $data
 3178 }
 3179 
 3180 # tcltest::bytestring --
 3181 #
 3182 # Construct a string that consists of the requested sequence of bytes,
 3183 # as opposed to a string of properly formed UTF-8 characters.
 3184 # This allows the tester to
 3185 # 1. Create denormalized or improperly formed strings to pass to C
 3186 #    procedures that are supposed to accept strings with embedded NULL
 3187 #    bytes.
 3188 # 2. Confirm that a string result has a certain pattern of bytes, for
 3189 #    instance to confirm that "\xe0\0" in a Tcl script is stored
 3190 #    internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
 3191 #
 3192 # Generally, it's a bad idea to examine the bytes in a Tcl string or to
 3193 # construct improperly formed strings in this manner, because it involves
 3194 # exposing that Tcl uses UTF-8 internally.
 3195 #
 3196 # Arguments:
 3197 #	string being converted
 3198 #
 3199 # Results:
 3200 #	result fom encoding
 3201 #
 3202 # Side effects:
 3203 #	None
 3204 
 3205 proc tcltest::bytestring {string} {
 3206     return [encoding convertfrom identity $string]
 3207 }
 3208 
 3209 # tcltest::OpenFiles --
 3210 #
 3211 #	used in io tests, uses testchannel
 3212 #
 3213 # Arguments:
 3214 #	None.
 3215 #
 3216 # Results:
 3217 #	???
 3218 #
 3219 # Side effects:
 3220 #	None.
 3221 
 3222 proc tcltest::OpenFiles {} {
 3223     if {[catch {testchannel open} result]} {
 3224 	return {}
 3225     }
 3226     return $result
 3227 }
 3228 
 3229 # tcltest::LeakFiles --
 3230 #
 3231 #	used in io tests, uses testchannel
 3232 #
 3233 # Arguments:
 3234 #	None.
 3235 #
 3236 # Results:
 3237 #	???
 3238 #
 3239 # Side effects:
 3240 #	None.
 3241 
 3242 proc tcltest::LeakFiles {old} {
 3243     if {[catch {testchannel open} new]} {
 3244 	return {}
 3245     }
 3246     set leak {}
 3247     foreach p $new {
 3248 	if {$p ni $old} {
 3249 	    lappend leak $p
 3250 	}
 3251     }
 3252     return $leak
 3253 }
 3254 
 3255 #
 3256 # Internationalization / ISO support procs     -- dl
 3257 #
 3258 
 3259 # tcltest::SetIso8859_1_Locale --
 3260 #
 3261 #	used in cmdIL.test, uses testlocale
 3262 #
 3263 # Arguments:
 3264 #	None.
 3265 #
 3266 # Results:
 3267 #	None.
 3268 #
 3269 # Side effects:
 3270 #	None.
 3271 
 3272 proc tcltest::SetIso8859_1_Locale {} {
 3273     variable previousLocale
 3274     variable isoLocale
 3275     if {[info commands testlocale] != ""} {
 3276 	set previousLocale [testlocale ctype]
 3277 	testlocale ctype $isoLocale
 3278     }
 3279     return
 3280 }
 3281 
 3282 # tcltest::RestoreLocale --
 3283 #
 3284 #	used in cmdIL.test, uses testlocale
 3285 #
 3286 # Arguments:
 3287 #	None.
 3288 #
 3289 # Results:
 3290 #	None.
 3291 #
 3292 # Side effects:
 3293 #	None.
 3294 
 3295 proc tcltest::RestoreLocale {} {
 3296     variable previousLocale
 3297     if {[info commands testlocale] != ""} {
 3298 	testlocale ctype $previousLocale
 3299     }
 3300     return
 3301 }
 3302 
 3303 # tcltest::threadReap --
 3304 #
 3305 #	Kill all threads except for the main thread.
 3306 #	Do nothing if testthread is not defined.
 3307 #
 3308 # Arguments:
 3309 #	none.
 3310 #
 3311 # Results:
 3312 #	Returns the number of existing threads.
 3313 #
 3314 # Side Effects:
 3315 #       none.
 3316 #
 3317 
 3318 proc tcltest::threadReap {} {
 3319     if {[info commands testthread] ne {}} {
 3320 
 3321 	# testthread built into tcltest
 3322 
 3323 	testthread errorproc ThreadNullError
 3324 	while {[llength [testthread names]] > 1} {
 3325 	    foreach tid [testthread names] {
 3326 		if {$tid != [mainThread]} {
 3327 		    catch {
 3328 			testthread send -async $tid {testthread exit}
 3329 		    }
 3330 		}
 3331 	    }
 3332 	    ## Enter a bit a sleep to give the threads enough breathing
 3333 	    ## room to kill themselves off, otherwise the end up with a
 3334 	    ## massive queue of repeated events
 3335 	    after 1
 3336 	}
 3337 	testthread errorproc ThreadError
 3338 	return [llength [testthread names]]
 3339     } elseif {[info commands thread::id] ne {}} {
 3340 
 3341 	# Thread extension
 3342 
 3343 	thread::errorproc ThreadNullError
 3344 	while {[llength [thread::names]] > 1} {
 3345 	    foreach tid [thread::names] {
 3346 		if {$tid != [mainThread]} {
 3347 		    catch {thread::send -async $tid {thread::exit}}
 3348 		}
 3349 	    }
 3350 	    ## Enter a bit a sleep to give the threads enough breathing
 3351 	    ## room to kill themselves off, otherwise the end up with a
 3352 	    ## massive queue of repeated events
 3353 	    after 1
 3354 	}
 3355 	thread::errorproc ThreadError
 3356 	return [llength [thread::names]]
 3357     } else {
 3358 	return 1
 3359     }
 3360     return 0
 3361 }
 3362 
 3363 # Initialize the constraints and set up command line arguments
 3364 namespace eval tcltest {
 3365     # Define initializers for all the built-in contraint definitions
 3366     DefineConstraintInitializers
 3367 
 3368     # Set up the constraints in the testConstraints array to be lazily
 3369     # initialized by a registered initializer, or by "false" if no
 3370     # initializer is registered.
 3371     trace add variable testConstraints read [namespace code SafeFetch]
 3372 
 3373     # Only initialize constraints at package load time if an
 3374     # [initConstraintsHook] has been pre-defined.  This is only
 3375     # for compatibility support.  The modern way to add a custom
 3376     # test constraint is to just call the [testConstraint] command
 3377     # straight away, without all this "hook" nonsense.
 3378     if {[namespace current] eq
 3379 	    [namespace qualifiers [namespace which initConstraintsHook]]} {
 3380 	InitConstraints
 3381     } else {
 3382 	proc initConstraintsHook {} {}
 3383     }
 3384 
 3385     # Define the standard match commands
 3386     customMatch exact	[list string equal]
 3387     customMatch glob	[list string match]
 3388     customMatch regexp	[list regexp --]
 3389 
 3390     # If the TCLTEST_OPTIONS environment variable exists, configure
 3391     # tcltest according to the option values it specifies.  This has
 3392     # the effect of resetting tcltest's default configuration.
 3393     proc ConfigureFromEnvironment {} {
 3394 	upvar #0 env(TCLTEST_OPTIONS) options
 3395 	if {[catch {llength $options} msg]} {
 3396 	    Warn "invalid TCLTEST_OPTIONS \"$options\":\n  invalid\
 3397 		    Tcl list: $msg"
 3398 	    return
 3399 	}
 3400 	if {[llength $options] % 2} {
 3401 	    Warn "invalid TCLTEST_OPTIONS: \"$options\":\n  should be\
 3402 		    -option value ?-option value ...?"
 3403 	    return
 3404 	}
 3405 	if {[catch {Configure {*}$options} msg]} {
 3406 	    Warn "invalid TCLTEST_OPTIONS: \"$options\":\n  $msg"
 3407 	    return
 3408 	}
 3409     }
 3410     if {[info exists ::env(TCLTEST_OPTIONS)]} {
 3411 	ConfigureFromEnvironment
 3412     }
 3413 
 3414     proc LoadTimeCmdLineArgParsingRequired {} {
 3415 	set required false
 3416 	if {[info exists ::argv] && ("-help" in $::argv)} {
 3417 	    # The command line asks for -help, so give it (and exit)
 3418 	    # right now.  ([configure] does not process -help)
 3419 	    set required true
 3420 	}
 3421 	foreach hook { PrintUsageInfoHook processCmdLineArgsHook
 3422 			processCmdLineArgsAddFlagsHook } {
 3423 	    if {[namespace current] eq
 3424 		    [namespace qualifiers [namespace which $hook]]} {
 3425 		set required true
 3426 	    } else {
 3427 		proc $hook args {}
 3428 	    }
 3429 	}
 3430 	return $required
 3431     }
 3432 
 3433     # Only initialize configurable options from the command line arguments
 3434     # at package load time if necessary for backward compatibility.  This
 3435     # lets the tcltest user call [configure] for themselves if they wish.
 3436     # Traces are established for auto-configuration from the command line
 3437     # if any configurable options are accessed before the user calls
 3438     # [configure].
 3439     if {[LoadTimeCmdLineArgParsingRequired]} {
 3440 	ProcessCmdLineArgs
 3441     } else {
 3442 	EstablishAutoConfigureTraces
 3443     }
 3444 
 3445     package provide [namespace tail [namespace current]] $Version
 3446 }