From e6a05dbef707dc10e546ef8fef8fc2a8b7d805bf Mon Sep 17 00:00:00 2001
From: cvs2svn
Date: Mon, 24 Jan 2005 15:46:33 +0000
Subject: This commit was manufactured by cvs2svn to create branch
 'POSTSCRIPT'.

---
 sandbox/defs.tcl | 1097 ------------------------------------------------------
 1 file changed, 1097 deletions(-)
 delete mode 100644 sandbox/defs.tcl

(limited to 'sandbox/defs.tcl')

diff --git a/sandbox/defs.tcl b/sandbox/defs.tcl
deleted file mode 100644
index a2e55cd..0000000
--- a/sandbox/defs.tcl
+++ /dev/null
@@ -1,1097 +0,0 @@
-# defs.tcl --
-#
-#	This file contains support code for the Tcl/Tk test suite.It is
-#	It is normally sourced by the individual files in the test suite
-#	before they run their tests.  This improved approach to testing
-#	was designed and initially implemented by Mary Ann May-Pumphrey
-#	of Sun Microsystems.
-#
-# Copyright (c) 1990-1994 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# All rights reserved.
-# 
-# RCS: @(#) $Id$
-
-# Initialize wish shell
-
-if {[info exists tk_version]} {
-    tk appname tktest
-    wm title . tktest
-} else {
-
-    # Ensure that we have a minimal auto_path so we don't pick up extra junk.
-
-    set auto_path [list [info library]]
-}
-
-# create the "tcltest" namespace for all testing variables and procedures
-
-namespace eval tcltest {
-    set procList [list test cleanupTests dotests saveState restoreState \
-	    normalizeMsg makeFile removeFile makeDirectory removeDirectory \
-	    viewFile bytestring set_iso8859_1_locale restore_locale \
-	    safeFetch threadReap]
-    if {[info exists tk_version]} {
-	lappend procList setupbg dobg bgReady cleanupbg fixfocus
-    }
-    foreach proc $procList {
-	namespace export $proc
-    }
-
-    # setup ::tcltest default vars
-    foreach {var default} {verbose b match {} skip {}} {
-	if {![info exists $var]} {
-	    variable $var $default
-	}
-    }
-
-    # Tests should not rely on the current working directory.
-    # Files that are part of the test suite should be accessed relative to
-    # ::tcltest::testsDir.
-
-    set originalDir [pwd]
-    set tDir [file join $originalDir [file dirname [info script]]]
-    cd $tDir
-    variable testsDir [pwd]
-    cd $originalDir
-
-    # Count the number of files tested (0 if all.tcl wasn't called).
-    # The all.tcl file will set testSingleFile to false, so stats will
-    # not be printed until all.tcl calls the cleanupTests proc.
-    # The currentFailure var stores the boolean value of whether the
-    # current test file has had any failures.  The failFiles list
-    # stores the names of test files that had failures.
-
-    variable numTestFiles 0
-    variable testSingleFile true
-    variable currentFailure false
-    variable failFiles {}
-
-    # Tests should remove all files they create.  The test suite will
-    # check the current working dir for files created by the tests.
-    # ::tcltest::filesMade keeps track of such files created using the
-    # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
-    # ::tcltest::filesExisted stores the names of pre-existing files.
-
-    variable filesMade {}
-    variable filesExisted {}
-
-    # ::tcltest::numTests will store test files as indices and the list
-    # of files (that should not have been) left behind by the test files.
-
-    array set ::tcltest::createdNewFiles {}
-
-    # initialize ::tcltest::numTests array to keep track fo the number of
-    # tests that pass, fial, and are skipped.
-
-    array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
-
-    # initialize ::tcltest::skippedBecause array to keep track of
-    # constraints that kept tests from running
-
-    array set ::tcltest::skippedBecause {}
-
-    # tests that use thread need to know which is the main thread
-
-    variable ::tcltest::mainThread 1
-    if {[info commands testthread] != {}} {
-	puts "Tk with threads enabled is known to have problems with X"
-	set ::tcltest::mainThread [testthread names]
-    }
-}
-
-# If there is no "memory" command (because memory debugging isn't
-# enabled), generate a dummy command that does nothing.
-
-if {[info commands memory] == ""} {
-    proc memory args {}
-}
-
-# ::tcltest::initConfig --
-#
-# Check configuration information that will determine which tests
-# to run.  To do this, create an array ::tcltest::testConfig.  Each
-# element has a 0 or 1 value.  If the element is "true" then tests
-# with that constraint will be run, otherwise tests with that constraint
-# will be skipped.  See the README file for the list of built-in
-# constraints defined in this procedure.
-#
-# Arguments:
-#	none
-#
-# Results:
-#	The ::tcltest::testConfig array is reset to have an index for
-#	each built-in test constraint.
-
-proc ::tcltest::initConfig {} {
-
-    global tcl_platform tcl_interactive tk_version
-
-    catch {unset ::tcltest::testConfig}
-
-    # The following trace procedure makes it so that we can safely refer to
-    # non-existent members of the ::tcltest::testConfig array without causing an
-    # error.  Instead, reading a non-existent member will return 0.  This is
-    # necessary because tests are allowed to use constraint "X" without ensuring
-    # that ::tcltest::testConfig("X") is defined.
-
-    trace variable ::tcltest::testConfig r ::tcltest::safeFetch
-
-    proc ::tcltest::safeFetch {n1 n2 op} {
-	if {($n2 != {}) && ([info exists ::tcltest::testConfig($n2)] == 0)} {
-	    set ::tcltest::testConfig($n2) 0
-	}
-    }
-
-    set ::tcltest::testConfig(unixOnly) \
-	    [expr {$tcl_platform(platform) == "unix"}]
-    set ::tcltest::testConfig(macOnly) \
-	    [expr {$tcl_platform(platform) == "macintosh"}]
-    set ::tcltest::testConfig(pcOnly) \
-	    [expr {$tcl_platform(platform) == "windows"}]
-
-    set ::tcltest::testConfig(unix) $::tcltest::testConfig(unixOnly)
-    set ::tcltest::testConfig(mac) $::tcltest::testConfig(macOnly)
-    set ::tcltest::testConfig(pc) $::tcltest::testConfig(pcOnly)
-
-    set ::tcltest::testConfig(unixOrPc) \
-	    [expr {$::tcltest::testConfig(unix) || $::tcltest::testConfig(pc)}]
-    set ::tcltest::testConfig(macOrPc) \
-	    [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(pc)}]
-    set ::tcltest::testConfig(macOrUnix) \
-	    [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(unix)}]
-
-    set ::tcltest::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
-    set ::tcltest::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
-
-    # The following config switches are used to mark tests that should work,
-    # but have been temporarily disabled on certain platforms because they don't
-    # and we haven't gotten around to fixing the underlying problem.
-
-    set ::tcltest::testConfig(tempNotPc) [expr {!$::tcltest::testConfig(pc)}]
-    set ::tcltest::testConfig(tempNotMac) [expr {!$::tcltest::testConfig(mac)}]
-    set ::tcltest::testConfig(tempNotUnix) [expr {!$::tcltest::testConfig(unix)}]
-
-    # The following config switches are used to mark tests that crash on
-    # certain platforms, so that they can be reactivated again when the
-    # underlying problem is fixed.
-
-    set ::tcltest::testConfig(pcCrash) [expr {!$::tcltest::testConfig(pc)}]
-    set ::tcltest::testConfig(macCrash) [expr {!$::tcltest::testConfig(mac)}]
-    set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}]
-
-    # Set the "fonts" constraint for wish apps
-
-    if {[info exists tk_version]} {
-	set ::tcltest::testConfig(fonts) 1
-	catch {destroy .e}
-	entry .e -width 0 -font {Helvetica -12} -bd 1
-	.e insert end "a.bcd"
-	if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
-	    set ::tcltest::testConfig(fonts) 0
-	}
-	destroy .e
-	catch {destroy .t}
-	text .t -width 80 -height 20 -font {Times -14} -bd 1
-	pack .t
-	.t insert end "This is\na dot."
-	update
-	set x [list [.t bbox 1.3] [.t bbox 2.5]]
-	destroy .t
-	if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
-	    set ::tcltest::testConfig(fonts) 0
-	}
-
-	# Test to see if we have are running Unix apps on Exceed,
-	# which won't return font failures (Windows-like), which is
-	# not what we want from ann X server (other Windows X servers
-	# operate as expected)
-
-	set ::tcltest::testConfig(noExceed) 1
-	if {$::tcltest::testConfig(unixOnly) && \
-		[catch {font actual "\{xyz"}] == 0} {
-	    puts "Running X app on Exceed, skipping problematic font tests..."
-	    set ::tcltest::testConfig(noExceed) 0
-	}
-    }
-
-    # Skip empty tests
-
-    set ::tcltest::testConfig(emptyTest) 0
-
-    # By default, tests that expost known bugs are skipped.
-
-    set ::tcltest::testConfig(knownBug) 0
-
-    # By default, non-portable tests are skipped.
-
-    set ::tcltest::testConfig(nonPortable) 0
-
-    # Some tests require user interaction.
-
-    set ::tcltest::testConfig(userInteraction) 0
-
-    # Some tests must be skipped if the interpreter is not in interactive mode
-
-    set ::tcltest::testConfig(interactive) $tcl_interactive
-
-    # Some tests must be skipped if you are running as root on Unix.
-    # Other tests can only be run if you are running as root on Unix.
-
-    set ::tcltest::testConfig(root) 0
-    set ::tcltest::testConfig(notRoot) 1
-    set user {}
-    if {$tcl_platform(platform) == "unix"} {
-	catch {set user [exec whoami]}
-	if {$user == ""} {
-	    catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
-	}
-	if {($user == "root") || ($user == "")} {
-	    set ::tcltest::testConfig(root) 1
-	    set ::tcltest::testConfig(notRoot) 0
-	}
-    }
-
-    # Set nonBlockFiles constraint: 1 means this platform supports
-    # setting files into nonblocking mode.
-
-    if {[catch {set f [open defs r]}]} {
-	set ::tcltest::testConfig(nonBlockFiles) 1
-    } else {
-	if {[catch {fconfigure $f -blocking off}] == 0} {
-	    set ::tcltest::testConfig(nonBlockFiles) 1
-	} else {
-	    set ::tcltest::testConfig(nonBlockFiles) 0
-	}
-	close $f
-    }
-
-    # Set asyncPipeClose constraint: 1 means this platform supports
-    # async flush and async close on a pipe.
-    #
-    # Test for SCO Unix - cannot run async flushing tests because a
-    # potential problem with select is apparently interfering.
-    # (Mark Diekhans).
-
-    if {$tcl_platform(platform) == "unix"} {
-	if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
-	    set ::tcltest::testConfig(asyncPipeClose) 0
-	} else {
-	    set ::tcltest::testConfig(asyncPipeClose) 1
-	}
-    } else {
-	set ::tcltest::testConfig(asyncPipeClose) 1
-    }
-
-    # Test to see if we have a broken version of sprintf with respect
-    # to the "e" format of floating-point numbers.
-
-    set ::tcltest::testConfig(eformat) 1
-    if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
-	set ::tcltest::testConfig(eformat) 0
-    }
-
-    # Test to see if execed commands such as cat, echo, rm and so forth are
-    # present on this machine.
-
-    set ::tcltest::testConfig(unixExecs) 1
-    if {$tcl_platform(platform) == "macintosh"} {
-	set ::tcltest::testConfig(unixExecs) 0
-    }
-    if {($::tcltest::testConfig(unixExecs) == 1) && \
-	    ($tcl_platform(platform) == "windows")} {
-	if {[catch {exec cat defs}] == 1} {
-	    set ::tcltest::testConfig(unixExecs) 0
-	}
-	if {($::tcltest::testConfig(unixExecs) == 1) && \
-		([catch {exec echo hello}] == 1)} {
-	    set ::tcltest::testConfig(unixExecs) 0
-	}
-	if {($::tcltest::testConfig(unixExecs) == 1) && \
-		([catch {exec sh -c echo hello}] == 1)} {
-	    set ::tcltest::testConfig(unixExecs) 0
-	}
-	if {($::tcltest::testConfig(unixExecs) == 1) && \
-		([catch {exec wc defs}] == 1)} {
-	    set ::tcltest::testConfig(unixExecs) 0
-	}
-	if {$::tcltest::testConfig(unixExecs) == 1} {
-	    exec echo hello > removeMe
-	    if {[catch {exec rm removeMe}] == 1} {
-		set ::tcltest::testConfig(unixExecs) 0
-	    }
-	}
-	if {($::tcltest::testConfig(unixExecs) == 1) && \
-		([catch {exec sleep 1}] == 1)} {
-	    set ::tcltest::testConfig(unixExecs) 0
-	}
-	if {($::tcltest::testConfig(unixExecs) == 1) && \
-		([catch {exec fgrep unixExecs defs}] == 1)} {
-	    set ::tcltest::testConfig(unixExecs) 0
-	}
-	if {($::tcltest::testConfig(unixExecs) == 1) && \
-		([catch {exec ps}] == 1)} {
-	    set ::tcltest::testConfig(unixExecs) 0
-	}
-	if {($::tcltest::testConfig(unixExecs) == 1) && \
-		([catch {exec echo abc > removeMe}] == 0) && \
-		([catch {exec chmod 644 removeMe}] == 1) && \
-		([catch {exec rm removeMe}] == 0)} {
-	    set ::tcltest::testConfig(unixExecs) 0
-	} else {
-	    catch {exec rm -f removeMe}
-	}
-	if {($::tcltest::testConfig(unixExecs) == 1) && \
-		([catch {exec mkdir removeMe}] == 1)} {
-	    set ::tcltest::testConfig(unixExecs) 0
-	} else {
-	    catch {exec rm -r removeMe}
-	}
-    }
-}
-
-::tcltest::initConfig
-
-
-# ::tcltest::processCmdLineArgs --
-#
-#	Use command line args to set the verbose, skip, and
-#	match variables.  This procedure must be run after
-#	constraints are initialized, because some constraints can be
-#	overridden.
-#
-# Arguments:
-#	none
-#
-# Results:
-#	::tcltest::verbose is set to <value>
-
-proc ::tcltest::processCmdLineArgs {} {
-    global argv
-
-    # The "argv" var doesn't exist in some cases, so use {}
-    # The "argv" var doesn't exist in some cases.
-
-    if {(![info exists argv]) || ([llength $argv] < 2)} {
-	set flagArray {}
-    } else {
-	set flagArray $argv
-    }
-
-    if {[catch {array set flag $flagArray}]} {
-	puts stderr "Error:  odd number of command line args specified:"
-	puts stderr "        $argv"
-	exit
-    }
-    
-    # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
-    # Note that -verbose cannot be abbreviated to -v in wish because it
-    # conflicts with the wish option -visual.
-
-    foreach arg {-verbose -match -skip -constraints} {
-	set abbrev [string range $arg 0 1]
-	if {([info exists flag($abbrev)]) && \
-		([lsearch -exact $flagArray $arg] < \
-		[lsearch -exact $flagArray $abbrev])} {
-	    set flag($arg) $flag($abbrev)
-	}
-    }
-
-    # Set ::tcltest::workingDir to [pwd].
-    # Save the names of files that already exist in ::tcltest::workingDir.
-
-    set ::tcltest::workingDir [pwd]
-    foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
-	lappend ::tcltest::filesExisted [file tail $file]
-    }
-
-    # Set ::tcltest::verbose to the arg of the -verbose flag, if given
-
-    if {[info exists flag(-verbose)]} {
-	set ::tcltest::verbose $flag(-verbose)
-    }
-
-    # Set ::tcltest::match to the arg of the -match flag, if given
-
-    if {[info exists flag(-match)]} {
-	set ::tcltest::match $flag(-match)
-    }
-
-    # Set ::tcltest::skip to the arg of the -skip flag, if given
-
-    if {[info exists flag(-skip)]} {
-	set ::tcltest::skip $flag(-skip)
-    }
-
-    # Use the -constraints flag, if given, to turn on constraints that are
-    # turned off by default: userInteractive knownBug nonPortable.  This
-    # code fragment must be run after constraints are initialized.
-
-    if {[info exists flag(-constraints)]} {
-	foreach elt $flag(-constraints) {
-	    set ::tcltest::testConfig($elt) 1
-	}
-    }
-}
-
-::tcltest::processCmdLineArgs
-
-
-# ::tcltest::cleanupTests --
-#
-# Remove files and dirs created using the makeFile and makeDirectory
-# commands since the last time this proc was invoked.
-#
-# Print the names of the files created without the makeFile command
-# since the tests were invoked.
-#
-# Print the number tests (total, passed, failed, and skipped) since the
-# tests were invoked.
-#
-
-proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
-    set tail [file tail [info script]]
-
-    # Remove files and directories created by the :tcltest::makeFile and
-    # ::tcltest::makeDirectory procedures.
-    # Record the names of files in ::tcltest::workingDir that were not
-    # pre-existing, and associate them with the test file that created them.
-
-    if {!$calledFromAllFile} {
-
-	foreach file $::tcltest::filesMade {
-	    if {[file exists $file]} {
-		catch {file delete -force $file}
-	    }
-	}
-	set currentFiles {}
-	foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
-	    lappend currentFiles [file tail $file]
-	}
-	set newFiles {}
-	foreach file $currentFiles {
-	    if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
-		lappend newFiles $file
-	    }
-	}
-	set ::tcltest::filesExisted $currentFiles
-	if {[llength $newFiles] > 0} {
-	    set ::tcltest::createdNewFiles($tail) $newFiles
-	}
-    }
-
-    if {$calledFromAllFile || $::tcltest::testSingleFile} {
-
-	# print stats
-
-	puts -nonewline stdout "$tail:"
-	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
-	    puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)"
-	}
-	puts stdout ""
-
-	# print number test files sourced
-	# print names of files that ran tests which failed
-
-	if {$calledFromAllFile} {
-	    puts stdout "Sourced $::tcltest::numTestFiles Test Files."
-	    set ::tcltest::numTestFiles 0
-	    if {[llength $::tcltest::failFiles] > 0} {
-		puts stdout "Files with failing tests: $::tcltest::failFiles"
-		set ::tcltest::failFiles {}
-	    }
-	}
-
-	# if any tests were skipped, print the constraints that kept them
-	# from running.
-
-	set constraintList [array names ::tcltest::skippedBecause]
-	if {[llength $constraintList] > 0} {
-	    puts stdout "Number of tests skipped for each constraint:"
-	    foreach constraint [lsort $constraintList] {
-		puts stdout \
-			"\t$::tcltest::skippedBecause($constraint)\t$constraint"
-		unset ::tcltest::skippedBecause($constraint)
-	    }
-	}
-
-	# report the names of test files in ::tcltest::createdNewFiles, and
-	# reset the array to be empty.
-
-	set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
-	if {[llength $testFilesThatTurded] > 0} {
-	    puts stdout "Warning: test files left files behind:"
-	    foreach testFile $testFilesThatTurded {
-		puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
-		unset ::tcltest::createdNewFiles($testFile)
-	    }
-	}
-
-	# reset filesMade, filesExisted, and numTests
-
-	set ::tcltest::filesMade {}
-	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
-	    set ::tcltest::numTests($index) 0
-	}
-
-	# exit only if running Tk in non-interactive mode
-
-	global tk_version tcl_interactive
-	if {[info exists tk_version] && !$tcl_interactive} {
-	    exit
-	}
-    } else {
-
-	# if we're deferring stat-reporting until all files are sourced,
-	# then add current file to failFile list if any tests in this file
-	# failed
-
-	incr ::tcltest::numTestFiles
-	if {($::tcltest::currentFailure) && \
-		([lsearch -exact $::tcltest::failFiles $tail] == -1)} {
-	    lappend ::tcltest::failFiles $tail
-	}
-	set ::tcltest::currentFailure false
-    }
-}
-
-
-# test --
-#
-# This procedure runs a test and prints an error message if the test fails.
-# If ::tcltest::verbose has been set, it also prints a message even if the
-# test succeeds.  The test will be skipped if it doesn't match the
-# ::tcltest::match variable, if it matches an element in
-# ::tcltest::skip, or if one of the elements of "constraints" turns
-# out not to be true.
-#
-# Arguments:
-# name -		Name of test, in the form foo-1.2.
-# description -		Short textual description of the test, to
-#			help humans understand what it does.
-# constraints -		A list of one or more keywords, each of
-#			which must be the name of an element in
-#			the array "::tcltest::testConfig".  If any of these
-#			elements is zero, the test is skipped.
-#			This argument may be omitted.
-# script -		Script to run to carry out the test.  It must
-#			return a result that can be checked for
-#			correctness.
-# expectedAnswer -	Expected result from script.
-
-proc ::tcltest::test {name description script expectedAnswer args} {
-    incr ::tcltest::numTests(Total)
-
-    # skip the test if it's name matches an element of skip
-
-    foreach pattern $::tcltest::skip {
-	if {[string match $pattern $name]} {
-	    incr ::tcltest::numTests(Skipped)
-	    return
-	}
-    }
-    # skip the test if it's name doesn't match any element of match
-
-    if {[llength $::tcltest::match] > 0} {
-	set ok 0
-	foreach pattern $::tcltest::match {
-	    if {[string match $pattern $name]} {
-		set ok 1
-		break
-	    }
-        }
-	if {!$ok} {
-	    incr ::tcltest::numTests(Skipped)
-	    return
-	}
-    }
-    set i [llength $args]
-    if {$i == 0} {
-	set constraints {}
-    } elseif {$i == 1} {
-
-	# "constraints" argument exists;  shuffle arguments down, then
-	# make sure that the constraints are satisfied.
-
-	set constraints $script
-	set script $expectedAnswer
-	set expectedAnswer [lindex $args 0]
-	set doTest 0
-	if {[string match {*[$\[]*} $constraints] != 0} {
-
-	    # full expression, e.g. {$foo > [info tclversion]}
-
-	    catch {set doTest [uplevel #0 expr $constraints]}
-
-	} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
-
-	    # something like {a || b} should be turned into 
-	    # $::tcltest::testConfig(a) || $::tcltest::testConfig(b).
-
- 	    regsub -all {[.a-zA-Z0-9]+} $constraints \
-		    {$::tcltest::testConfig(&)} c
-	    catch {set doTest [eval expr $c]}
-	} else {
-
-	    # just simple constraints such as {unixOnly fonts}.
-
-	    set doTest 1
-	    foreach constraint $constraints {
-		if {![info exists ::tcltest::testConfig($constraint)]
-			|| !$::tcltest::testConfig($constraint)} {
-		    set doTest 0
-
-		    # store the constraint that kept the test from running
-
-		    set constraints $constraint
-		    break
-		}
-	    }
-	}
-	if {$doTest == 0} {
-	    incr ::tcltest::numTests(Skipped)
-	    if {[string first s $::tcltest::verbose] != -1} {
-		puts stdout "++++ $name SKIPPED: $constraints"
-	    }
-
-	    # add the constraint to the list of constraints the kept tests
-	    # from running
-
-	    if {[info exists ::tcltest::skippedBecause($constraints)]} {
-		incr ::tcltest::skippedBecause($constraints)
-	    } else {
-		set ::tcltest::skippedBecause($constraints) 1
-	    }
-	    return	
-	}
-    } else {
-	error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
-    }
-    memory tag $name
-    set code [catch {uplevel $script} actualAnswer]
-    if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} {
-	incr ::tcltest::numTests(Failed)
-	set ::tcltest::currentFailure true
-	if {[string first b $::tcltest::verbose] == -1} {
-	    set script ""
-	}
-	puts stdout "\n==== $name $description FAILED"
-	if {$script != ""} {
-	    puts stdout "==== Contents of test case:"
-	    puts stdout $script
-	}
-	if {$code != 0} {
-	    if {$code == 1} {
-		puts stdout "==== Test generated error:"
-		puts stdout $actualAnswer
-	    } elseif {$code == 2} {
-		puts stdout "==== Test generated return exception;  result was:"
-		puts stdout $actualAnswer
-	    } elseif {$code == 3} {
-		puts stdout "==== Test generated break exception"
-	    } elseif {$code == 4} {
-		puts stdout "==== Test generated continue exception"
-	    } else {
-		puts stdout "==== Test generated exception $code;  message was:"
-		puts stdout $actualAnswer
-	    }
-	} else {
-	    puts stdout "---- Result was:\n$actualAnswer"
-	}
-	puts stdout "---- Result should have been:\n$expectedAnswer"
-	puts stdout "==== $name FAILED\n" 
-    } else { 
-	incr ::tcltest::numTests(Passed)
-	if {[string first p $::tcltest::verbose] != -1} {
-	    puts stdout "++++ $name PASSED"
-	}
-    }
-}
-
-# ::tcltest::dotests --
-#
-#	takes two arguments--the name of the test file (such
-#	as "parse.test"), and a pattern selecting the tests you want to
-#	execute.  It sets ::tcltest::matching to the second argument, calls
-#	"source" on the file specified in the first argument, and restores
-#	::tcltest::matching to its pre-call value at the end.
-#
-# Arguments:
-#	file    name of tests file to source
-#	args    pattern selecting the tests you want to execute
-#
-# Results:
-#	none
-
-proc ::tcltest::dotests {file args} {
-    set savedTests $::tcltest::match
-    set ::tcltest::match $args
-    source $file
-    set ::tcltest::match $savedTests
-}
-
-proc ::tcltest::openfiles {} {
-    if {[catch {testchannel open} result]} {
-	return {}
-    }
-    return $result
-}
-
-proc ::tcltest::leakfiles {old} {
-    if {[catch {testchannel open} new]} {
-        return {}
-    }
-    set leak {}
-    foreach p $new {
-    	if {[lsearch $old $p] < 0} {
-	    lappend leak $p
-	}
-    }
-    return $leak
-}
-
-set ::tcltest::saveState {}
-
-proc ::tcltest::saveState {} {
-    uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
-}
-
-proc ::tcltest::restoreState {} {
-    foreach p [info procs] {
-	if {[lsearch [lindex $::tcltest::saveState 0] $p] < 0} {
-	    rename $p {}
-	}
-    }
-    foreach p [uplevel #0 {info vars}] {
-	if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
-	    uplevel #0 "unset $p"
-	}
-    }
-}
-
-proc ::tcltest::normalizeMsg {msg} {
-    regsub "\n$" [string tolower $msg] "" msg
-    regsub -all "\n\n" $msg "\n" msg
-    regsub -all "\n\}" $msg "\}" msg
-    return $msg
-}
-
-# makeFile --
-#
-# Create a new file with the name <name>, and write <contents> to it.
-#
-# If this file hasn't been created via makeFile since the last time
-# cleanupTests was called, add it to the $filesMade list, so it will
-# be removed by the next call to cleanupTests.
-#
-proc ::tcltest::makeFile {contents name} {
-    set fd [open $name w]
-    fconfigure $fd -translation lf
-    if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
-	puts -nonewline $fd $contents
-    } else {
-	puts $fd $contents
-    }
-    close $fd
-
-    set fullName [file join [pwd] $name]
-    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
-	lappend ::tcltest::filesMade $fullName
-    }
-}
-
-proc ::tcltest::removeFile {name} {
-    file delete $name
-}
-
-# makeDirectory --
-#
-# Create a new dir with the name <name>.
-#
-# If this dir hasn't been created via makeDirectory since the last time
-# cleanupTests was called, add it to the $directoriesMade list, so it will
-# be removed by the next call to cleanupTests.
-#
-proc ::tcltest::makeDirectory {name} {
-    file mkdir $name
-
-    set fullName [file join [pwd] $name]
-    if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
-	lappend ::tcltest::filesMade $fullName
-    }
-}
-
-proc ::tcltest::removeDirectory {name} {
-    file delete -force $name
-}
-
-proc ::tcltest::viewFile {name} {
-    global tcl_platform
-    if {($tcl_platform(platform) == "macintosh") || \
-		($::tcltest::testConfig(unixExecs) == 0)} {
-	set f [open $name]
-	set data [read -nonewline $f]
-	close $f
-	return $data
-    } else {
-	exec cat $name
-    }
-}
-
-#
-# Construct a string that consists of the requested sequence of bytes,
-# as opposed to a string of properly formed UTF-8 characters.  
-# This allows the tester to 
-# 1. Create denormalized or improperly formed strings to pass to C procedures 
-#    that are supposed to accept strings with embedded NULL bytes.
-# 2. Confirm that a string result has a certain pattern of bytes, for instance
-#    to confirm that "\xe0\0" in a Tcl script is stored internally in 
-#    UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
-#
-# Generally, it's a bad idea to examine the bytes in a Tcl string or to
-# construct improperly formed strings in this manner, because it involves
-# exposing that Tcl uses UTF-8 internally.
-
-proc ::tcltest::bytestring {string} {
-    encoding convertfrom identity $string
-}
-
-# Locate tcltest executable
-
-if {![info exists tk_version]} {
-    set tcltest [info nameofexecutable]
-
-    if {$tcltest == "{}"} {
-	set tcltest {}
-    }
-}
-
-set ::tcltest::testConfig(stdio) 0
-catch {
-    catch {file delete -force tmp}
-    set f [open tmp w]
-    puts $f {
-	exit
-    }
-    close $f
-
-    set f [open "|[list $tcltest tmp]" r]
-    close $f
-    
-    set ::tcltest::testConfig(stdio) 1
-}
-catch {file delete -force tmp}
-
-# Deliberately call the socket with the wrong number of arguments.  The error
-# message you get will indicate whether sockets are available on this system.
-
-catch {socket} msg
-set ::tcltest::testConfig(socket) \
-	[expr {$msg != "sockets are not available on this system"}]
-
-#
-# Internationalization / ISO support procs     -- dl
-#
-
-if {[info commands testlocale]==""} {
-
-    # No testlocale command, no tests...
-    # (it could be that we are a sub interp and we could just load
-    # the Tcltest package but that would interfere with tests
-    # that tests packages/loading in slaves...)
-
-    set ::tcltest::testConfig(hasIsoLocale) 0
-} else {
-    proc ::tcltest::set_iso8859_1_locale {} {
-	set ::tcltest::previousLocale [testlocale ctype]
-	testlocale ctype $::tcltest::isoLocale
-    }
-
-    proc ::tcltest::restore_locale {} {
-	testlocale ctype $::tcltest::previousLocale
-    }
-
-    if {![info exists ::tcltest::isoLocale]} {
-	set ::tcltest::isoLocale fr
-        switch $tcl_platform(platform) {
-	    "unix" {
-
-		# Try some 'known' values for some platforms:
-
-		switch -exact -- $tcl_platform(os) {
-		    "FreeBSD" {
-			set ::tcltest::isoLocale fr_FR.ISO_8859-1
-		    }
-		    HP-UX {
-			set ::tcltest::isoLocale fr_FR.iso88591
-		    }
-		    Linux -
-		    IRIX {
-			set ::tcltest::isoLocale fr
-		    }
-		    default {
-
-			# Works on SunOS 4 and Solaris, and maybe others...
-			# define it to something else on your system
-			#if you want to test those.
-
-			set ::tcltest::isoLocale iso_8859_1
-		    }
-		}
-	    }
-	    "windows" {
-		set ::tcltest::isoLocale French
-	    }
-	}
-    }
-
-    set ::tcltest::testConfig(hasIsoLocale) \
-	    [string length [::tcltest::set_iso8859_1_locale]]
-    ::tcltest::restore_locale
-} 
-
-#
-# procedures that are Tk specific
-#
-
-if {[info exists tk_version]} {
-
-    # If the main window isn't already mapped (e.g. because the tests are
-    # being run automatically) , specify a precise size for it so that the
-    # user won't have to position it manually.
-
-    if {![winfo ismapped .]} {
-	wm geometry . +0+0
-	update
-    }
-
-    # The following code can be used to perform tests involving a second
-    # process running in the background.
-    
-    # Locate the tktest executable
-
-    set ::tcltest::tktest [info nameofexecutable]
-    if {$::tcltest::tktest == "{}"} {
-	set ::tcltest::tktest {}
-	puts stdout \
-		"Unable to find tktest executable, skipping multiple process tests."
-    }
-
-    # Create background process
-    
-    proc ::tcltest::setupbg args {
-	if {$::tcltest::tktest == ""} {
-	    error "you're not running tktest so setupbg should not have been called"
-	}
-	if {[info exists ::tcltest::fd] && ($::tcltest::fd != "")} {
-	    cleanupbg
-	}
-	
-	# The following code segment cannot be run on Windows prior
-	# to Tk 8.1b3 due to a channel I/O bug (bugID 1495).
-
-	global tcl_platform
-	set ::tcltest::fd [open "|[list $::tcltest::tktest -geometry +0+0 -name tktest] $args" r+]
-	puts $::tcltest::fd "puts foo; flush stdout"
-	flush $::tcltest::fd
-	if {[gets $::tcltest::fd data] < 0} {
-	    error "unexpected EOF from \"$::tcltest::tktest\""
-	}
-	if {[string compare $data foo]} {
-	    error "unexpected output from background process \"$data\""
-	}
-	fileevent $::tcltest::fd readable bgReady
-    }
-    
-    # Send a command to the background process, catching errors and
-    # flushing I/O channels
-
-    proc ::tcltest::dobg {command} {
-	puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
-	flush $::tcltest::fd
-	set ::tcltest::bgDone 0
-	set ::tcltest::bgData {}
-	tkwait variable ::tcltest::bgDone
-	set ::tcltest::bgData
-    }
-
-    # Data arrived from background process.  Check for special marker
-    # indicating end of data for this command, and make data available
-    # to dobg procedure.
-
-    proc ::tcltest::bgReady {} {
-	set x [gets $::tcltest::fd]
-	if {[eof $::tcltest::fd]} {
-	    fileevent $::tcltest::fd readable {}
-	    set ::tcltest::bgDone 1
-	} elseif {$x == "**DONE**"} {
-	    set ::tcltest::bgDone 1
-	} else {
-	    append ::tcltest::bgData $x
-	}
-    }
-
-    # Exit the background process, and close the pipes
-
-    proc ::tcltest::cleanupbg {} {
-	catch {
-	    puts $::tcltest::fd "exit"
-	    close $::tcltest::fd
-	}
-	set ::tcltest::fd ""
-    }
-
-    # Clean up focus after using generate event, which
-    # can leave the window manager with the wrong impression
-    # about who thinks they have the focus. (BW)
-    
-    proc ::tcltest::fixfocus {} {
-	catch {destroy .focus}
-	toplevel .focus
-	wm geometry .focus +0+0
-	entry .focus.e
-	.focus.e insert 0 "fixfocus"
-	pack .focus.e
-	update
-	focus -force .focus.e
-	destroy .focus
-    }
-}
-
-# threadReap --
-#
-#	Kill all threads except for the main thread.
-#	Do nothing if testthread is not defined.
-#
-# Arguments:
-#	none.
-#
-# Results:
-#	Returns the number of existing threads.
-
-if {[info commands testthread] != {}} {
-    proc ::tcltest::threadReap {} {
-	testthread errorproc ThreadNullError
-	while {[llength [testthread names]] > 1} {
-	    foreach tid [testthread names] {
-		if {$tid != $::tcltest::mainThread} {
-		    catch {testthread send -async $tid {testthread exit}}
-		    update
-		}
-	    }
-	}
-	testthread errorproc ThreadError
-	return [llength [testthread names]]
-    }
-} else {
-    proc ::tcltest::threadReap {} {
-	return 1
-    }   
-}
-
-# Need to catch the import because it fails if defs.tcl is sourced
-# more than once.
-
-catch {namespace import ::tcltest::*}
-return
-- 
cgit v1.1