summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/tcltest/pkgIndex.tcl11
-rw-r--r--library/tcltest/tcltest.tcl1237
-rw-r--r--library/tcltest1.0/pkgIndex.tcl11
-rw-r--r--library/tcltest1.0/tcltest.tcl1237
4 files changed, 2496 insertions, 0 deletions
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
new file mode 100644
index 0000000..f9e2d30
--- /dev/null
+++ b/library/tcltest/pkgIndex.tcl
@@ -0,0 +1,11 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg ::tcltest::removeDirectory ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory tcltest:grep}}}]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
new file mode 100644
index 0000000..3375718
--- /dev/null
+++ b/library/tcltest/tcltest.tcl
@@ -0,0 +1,1237 @@
+# tcltest.tcl --
+#
+# This file contains support code for the Tcl test suite. It defines the
+# defines the ::tcltest namespace and finds and defines the output
+# directory, constraints available, output and error channels, etc. used
+# by Tcl tests. See the README file for more details.
+#
+# This design was based on the original Tcl testing approach designed and
+# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
+#
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id: tcltest.tcl,v 1.1 1999/06/26 03:53:45 jenn Exp $
+
+package provide tcltest 1.0
+
+# Ensure that we have a minimal auto_path so we don't pick up extra junk.
+set auto_path [list [info library]]
+
+# create the "tcltest" namespace for all testing variables and procedures
+
+namespace eval tcltest {
+
+ # Export the public tcltest procs
+ set procList [list test cleanupTests dotests saveState restoreState \
+ normalizeMsg makeFile removeFile makeDirectory removeDirectory \
+ viewFile grep bytestring set_iso8859_1_locale restore_locale \
+ safeFetch threadReap]
+ foreach proc $procList {
+ namespace export $proc
+ }
+
+ # ::tcltest::verbose defaults to "b"
+
+ variable verbose "b"
+
+ # match defaults to the empty list
+
+ variable match {}
+
+ # skip defaults to the empty list
+
+ variable skip {}
+
+ # output goes to stdout by default
+
+ variable outputChannel stdout
+
+ # errors go to stderr by default
+
+ variable errorChannel stderr
+
+ # debug output doesn't get printed by default; default debugLevel (1) spits
+ # up only the tets that were skipped because they didn't match or were
+ # specifically skipped. A debugLevel of 2 would spit up the tcltest
+ # variables and flags provided; a debugLevel of 3 causes some additional
+ # output regarding operations of the test harness. The tcltest package
+ # currently implements only up to debugLevel 3.
+
+ variable debug false
+ variable debugLevel 1
+
+ # 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 ::tcltest::numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
+
+ # initialize ::tcltest::skippedBecause array to keep track of
+ # constraints that kept tests from running; a constraint name of
+ # "userSpecifiedSkip" means that the test appeared on the list of tests
+ # that matched the -skip value given to the flag; "userSpecifiedNonMatch"
+ # means that the test didn't match the argument given to the -match flag;
+ # both of these constraints are counted only if ::tcltest::debug is set to
+ # true.
+
+ array set ::tcltest::skippedBecause {}
+
+ # initialize the ::tcltest::testConstraints array to keep track of valid
+ # predefined constraints (see the explanation for the ::tcltest::initConstraints
+ # proc for more details).
+
+ array set ::tcltest::testConstraints {}
+
+ # tests that use thread need to know which is the main thread
+
+ variable mainThread 1
+ if {[info commands testthread] != {}} {
+ set mainThread [testthread names]
+ }
+
+ # save the original environement so that it can be restored later
+
+ array set ::tcltest::originalEnv [array get ::env]
+
+ # TclPro has other variables that need to be set, including the locations
+ # of various directories.
+
+ # Set ::tcltest::workingDirectory to [pwd]. The default output directory
+ # for Tcl tests is the working directory.
+
+ variable workingDirectory [pwd]
+ variable temporaryDirectory $workingDirectory
+
+ # Tests should not rely on the current working directory.
+ # Files that are part of the test suite should be accessed relative to
+ # ::tcltest::testsDirectory.
+
+ variable testsDirectory [pwd]
+
+ variable saveState {}
+
+ # Internationalization support
+ if {![info exists ::tcltest::isoLocale]} {
+ variable isoLocale fr
+ switch $tcl_platform(platform) {
+ "unix" {
+
+ # Try some 'known' values for some platforms:
+
+ switch -exact -- $tcl_platform(os) {
+ "FreeBSD" {
+ set ::tcltest::isoLocale fr_FR.ISO_8859-1
+ }
+ HP-UX {
+ set ::tcltest::isoLocale fr_FR.iso88591
+ }
+ Linux -
+ IRIX {
+ set ::tcltest::isoLocale fr
+ }
+ default {
+
+ # Works on SunOS 4 and Solaris, and maybe others...
+ # define it to something else on your system
+ #if you want to test those.
+
+ set ::tcltest::isoLocale iso_8859_1
+ }
+ }
+ }
+ "windows" {
+ set ::tcltest::isoLocale French
+ }
+ }
+ }
+
+ # Set the location of the execuatble
+ variable tcltest [info nameofexecutable]
+
+ # If there is no "memory" command (because memory debugging isn't
+ # enabled), generate a dummy command that does nothing.
+
+ if {[info commands memory] == {}} {
+ namespace eval :: {
+ proc memory args {}
+ }
+ }
+}
+
+
+proc ::tcltest::AddToSkippedBecause { constraint } {
+ # add the constraint to the list of constraints the kept tests
+ # from running
+
+ if {[info exists ::tcltest::skippedBecause($constraint)]} {
+ incr ::tcltest::skippedBecause($constraint)
+ } else {
+ set ::tcltest::skippedBecause($constraint) 1
+ }
+ return
+}
+
+# ::tcltest::PrintError --
+#
+# Prints errors to ::tcltest::errorChannel and then flushes that
+# channel.
+#
+# Arguments:
+# errorMsg String containing the error to be printed
+#
+
+proc ::tcltest::PrintError {errorMsg} {
+ set InitialMessage "Error: "
+ set InitialMsgLen [string length $InitialMessage]
+ puts -nonewline $::tcltest::errorChannel $InitialMessage
+ set beginningIndex [string wordend $errorMsg 72]
+ puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]
+ set endingIndex [string length $errorMsg]
+ while {$beginningIndex < $endingIndex} {
+ set newEndingIndex [string wordend $errorMsg \
+ [expr {$beginningIndex + 72}]]
+ puts -nonewline $::tcltest::errorChannel \
+ [string repeat " " $InitialMsgLen]
+ puts $::tcltest::errorChannel [string trim \
+ [string range $errorMsg $beginningIndex $newEndingIndex]]
+ set beginningIndex $newEndingIndex
+ }
+ return
+}
+
+proc ::tcltest::initConstraintsHook {} {}
+
+# ::tcltest::initConstraints --
+#
+# Check Constraintsuration information that will determine which tests
+# to run. To do this, create an array ::tcltest::testConstraints. Each
+# element has a 0 or 1 value. If the element is "true" then tests
+# with that constraint will be run, otherwise tests with that constraint
+# will be skipped. See the README file for the list of built-in
+# constraints defined in this procedure.
+#
+# Arguments:
+# none
+#
+# Results:
+# The ::tcltest::testConstraints array is reset to have an index for
+# each built-in test constraint.
+
+proc ::tcltest::initConstraints {} {
+ global tcl_platform tcl_interactive tk_version
+
+ catch {unset ::tcltest::testConstraints}
+
+ # The following trace procedure makes it so that we can safely refer to
+ # non-existent members of the ::tcltest::testConstraints array without causing an
+ # error. Instead, reading a non-existent member will return 0. This is
+ # necessary because tests are allowed to use constraint "X" without ensuring
+ # that ::tcltest::testConstraints("X") is defined.
+
+ trace variable ::tcltest::testConstraints r ::tcltest::safeFetch
+
+ proc ::tcltest::safeFetch {n1 n2 op} {
+ if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} {
+ set ::tcltest::testConstraints($n2) 0
+ }
+ }
+
+ ::tcltest::initConstraintsHook
+
+ set ::tcltest::testConstraints(unixOnly) \
+ [string equal $tcl_platform(platform) "unix"]
+ set ::tcltest::testConstraints(macOnly) \
+ [string equal $tcl_platform(platform) "macintosh"]
+ set ::tcltest::testConstraints(pcOnly) \
+ [string equal $tcl_platform(platform) "windows"]
+
+ set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly)
+ set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly)
+ set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly)
+
+ set ::tcltest::testConstraints(unixOrPc) \
+ [expr {$::tcltest::testConstraints(unix) || $::tcltest::testConstraints(pc)}]
+ set ::tcltest::testConstraints(macOrPc) \
+ [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(pc)}]
+ set ::tcltest::testConstraints(macOrUnix) \
+ [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(unix)}]
+
+ set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) "Windows NT"]
+ set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) "Windows 95"]
+ set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) "Win32s"]
+
+ # The following Constraints switches are used to mark tests that should work,
+ # but have been temporarily disabled on certain platforms because they don't
+ # and we haven't gotten around to fixing the underlying problem.
+
+ set ::tcltest::testConstraints(tempNotPc) [expr {!$::tcltest::testConstraints(pc)}]
+ set ::tcltest::testConstraints(tempNotMac) [expr {!$::tcltest::testConstraints(mac)}]
+ set ::tcltest::testConstraints(tempNotUnix) [expr {!$::tcltest::testConstraints(unix)}]
+
+ # The following Constraints switches are used to mark tests that crash on
+ # certain platforms, so that they can be reactivated again when the
+ # underlying problem is fixed.
+
+ set ::tcltest::testConstraints(pcCrash) [expr {!$::tcltest::testConstraints(pc)}]
+ set ::tcltest::testConstraints(win32sCrash) [expr {!$::tcltest::testConstraints(win32s)}]
+ set ::tcltest::testConstraints(macCrash) [expr {!$::tcltest::testConstraints(mac)}]
+ set ::tcltest::testConstraints(unixCrash) [expr {!$::tcltest::testConstraints(unix)}]
+
+ # Skip empty tests
+
+ set ::tcltest::testConstraints(emptyTest) 0
+
+ # By default, tests that expose known bugs are skipped.
+
+ set ::tcltest::testConstraints(knownBug) 0
+
+ # By default, non-portable tests are skipped.
+
+ set ::tcltest::testConstraints(nonPortable) 0
+
+ # Some tests require user interaction.
+
+ set ::tcltest::testConstraints(userInteraction) 0
+
+ # Some tests must be skipped if the interpreter is not in interactive mode
+
+ set ::tcltest::testConstraints(interactive) $tcl_interactive
+
+ # Some tests can only be run if the installation came from a CD image
+ # instead of a web image
+ # Some tests must be skipped if you are running as root on Unix.
+ # Other tests can only be run if you are running as root on Unix.
+
+ set ::tcltest::testConstraints(root) 0
+ set ::tcltest::testConstraints(notRoot) 1
+ set user {}
+ if {[string equal $tcl_platform(platform) "unix"]} {
+ catch {set user [exec whoami]}
+ if {[string equal $user ""]} {
+ catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
+ }
+ if {([string equal $user "root"]) || ([string equal $user ""])} {
+ set ::tcltest::testConstraints(root) 1
+ set ::tcltest::testConstraints(notRoot) 0
+ }
+ }
+
+ # Set nonBlockFiles constraint: 1 means this platform supports
+ # setting files into nonblocking mode.
+
+ if {[catch {set f [open defs r]}]} {
+ set ::tcltest::testConstraints(nonBlockFiles) 1
+ } else {
+ if {[catch {fconfigure $f -blocking off}] == 0} {
+ set ::tcltest::testConstraints(nonBlockFiles) 1
+ } else {
+ set ::tcltest::testConstraints(nonBlockFiles) 0
+ }
+ close $f
+ }
+
+ # Set asyncPipeClose constraint: 1 means this platform supports
+ # async flush and async close on a pipe.
+ #
+ # Test for SCO Unix - cannot run async flushing tests because a
+ # potential problem with select is apparently interfering.
+ # (Mark Diekhans).
+
+ if {[string equal $tcl_platform(platform) "unix"]} {
+ if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
+ set ::tcltest::testConstraints(asyncPipeClose) 0
+ } else {
+ set ::tcltest::testConstraints(asyncPipeClose) 1
+ }
+ } else {
+ set ::tcltest::testConstraints(asyncPipeClose) 1
+ }
+
+ # Test to see if we have a broken version of sprintf with respect
+ # to the "e" format of floating-point numbers.
+
+ set ::tcltest::testConstraints(eformat) 1
+ if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
+ set ::tcltest::testConstraints(eformat) 0
+ }
+
+ # Test to see if execed commands such as cat, echo, rm and so forth are
+ # present on this machine.
+
+ set ::tcltest::testConstraints(unixExecs) 1
+ if {[string equal $tcl_platform(platform) "macintosh"]} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([string equal $tcl_platform(platform) "windows"])} {
+ if {[catch {exec cat defs}] == 1} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec echo hello}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec sh -c echo hello}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec wc defs}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {$::tcltest::testConstraints(unixExecs) == 1} {
+ exec echo hello > removeMe
+ if {[catch {exec rm removeMe}] == 1} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec sleep 1}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec fgrep unixExecs defs}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec ps}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec echo abc > removeMe}] == 0) && \
+ ([catch {exec chmod 644 removeMe}] == 1) && \
+ ([catch {exec rm removeMe}] == 0)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ } else {
+ catch {exec rm -f removeMe}
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec mkdir removeMe}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ } else {
+ catch {exec rm -r removeMe}
+ }
+ }
+
+ # Locate tcltest executable
+
+ if {![info exists tk_version]} {
+ set tcltest [info nameofexecutable]
+
+ if {$tcltest == "{}"} {
+ set tcltest {}
+ }
+ }
+
+ set ::tcltest::testConstraints(stdio) 0
+ catch {
+ catch {file delete -force tmp}
+ set f [open tmp w]
+ puts $f {
+ exit
+ }
+ close $f
+
+ set f [open "|[list $tcltest tmp]" r]
+ close $f
+
+ set ::tcltest::testConstraints(stdio) 1
+ }
+ catch {file delete -force tmp}
+
+ # Deliberately call socket with the wrong number of arguments. The error
+ # message you get will indicate whether sockets are available on this system.
+
+ catch {socket} msg
+ set ::tcltest::testConstraints(socket) \
+ [expr {$msg != "sockets are not available on this system"}]
+
+ # Check for internationalization
+
+ if {[info commands testlocale] == ""} {
+ # No testlocale command, no tests...
+ set ::tcltest::testConstraints(hasIsoLocale) 0
+ } else {
+ set ::tcltest::testConstraints(hasIsoLocale) \
+ [string length [::tcltest::set_iso8859_1_locale]]
+ ::tcltest::restore_locale
+ }
+}
+
+proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
+
+proc ::tcltest::processCmdLineArgsHook {flag} {}
+
+# ::tcltest::processCmdLineArgs --
+#
+# Use command line args to set the verbose, skip, and
+# match, outputChannel, errorChannel, debug, and temporaryDirectory
+# variables.
+#
+# This procedure must be run after constraints are initialized, because
+# some constraints can be overridden.
+#
+# Arguments:
+# none
+#
+# Results:
+# Sets the above-named variables in the tcltest namespace.
+
+proc ::tcltest::processCmdLineArgs {} {
+ global argv
+
+ # The "argv" var doesn't exist in some cases, so use {}.
+
+ if {(![info exists argv]) || ([llength $argv] < 2)} {
+ set flagArray {}
+ } else {
+ set flagArray $argv
+ }
+
+ # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
+ # Note that -verbose cannot be abbreviated to -v in wish because it
+ # conflicts with the wish option -visual.
+
+ if {[catch {array set flag $flagArray}]} {
+ ::tcltest::PrintError "odd number of arguments specified on command line: \
+ $argv"
+ exit
+ }
+
+ lappend defaultFlags {-verbose -match -skip -constraints \
+ -outfile -errfile -debug -tmpdir}
+ lappend defaultFlags [ ::tcltest::processCmdLineArgsAddFlagsHook ]
+
+ foreach arg $defaultFlags {
+ set abbrev [string range $arg 0 1]
+ if {([info exists flag($abbrev)]) && \
+ ([lsearch -exact $flagArray $arg] < \
+ [lsearch -exact $flagArray $abbrev])} {
+ set flag($arg) $flag($abbrev)
+ }
+ }
+
+ # 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::testConstraints($elt) 1
+ }
+ }
+
+ # If an alternate error or output files are specified, change the
+ # default channels.
+
+ if {[info exists flag(-outfile)]} {
+ set tmp $flag(-outfile)
+ if {[string compare [file pathtype $tmp] "absolute"] != 0} {
+ set tmp [file join $::tcltest::temporaryDirectory $tmp]
+ }
+ set ::tcltest::outputChannel [open $tmp w]
+ }
+
+ if {[info exists flag(-errfile)]} {
+ set tmp $flag(-errfile)
+ if {[string compare [file pathtype $tmp] "absolute"] != 0} {
+ set tmp [file join $::tcltest::temporaryDirectory $tmp]
+ }
+ set ::tcltest::errorChannel [open $tmp w]
+ }
+
+ # If the user specifies debug testing, print out extra information during
+ # the run.
+ if {[info exists flag(-debug)]} {
+ set ::tcltest::debug true
+ if {$flag(-debug) != {}} {
+ set ::tcltest::debugLevel $flag(-debug)
+ }
+ }
+
+ # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if
+ # given.
+ #
+ # If the path is relative, make it absolute. If the file exists but
+ # is not a dir, then return an error.
+ #
+ # If ::tcltest::temporaryDirectory does not already exist, create it.
+ # If you cannot create it, then return an error.
+
+ set tmpDirError ""
+ if {[info exists flag(-tmpdir)]} {
+ set ::tcltest::temporaryDirectory $flag(-tmpdir)
+
+ if {[string compare \
+ [file pathtype $::tcltest::temporaryDirectory] \
+ "absolute"] != 0} {
+ set ::tcltest::temporaryDirectory [file join [pwd] \
+ $::tcltest::temporaryDirectory]
+ }
+ set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
+ }
+ if {[file exists $::tcltest::temporaryDirectory]} {
+ if {![file isdir $::tcltest::temporaryDirectory]} {
+ ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
+ is not a directory"
+ exit
+ } elseif {![file writable $::tcltest::temporaryDirectory]} {
+ ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
+ is not writeable"
+ exit
+ } elseif {![file readable $::tcltest::temporaryDirectory]} {
+ ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
+ is not readable"
+ exit
+ }
+ } else {
+ file mkdir $::tcltest::temporaryDirectory
+ }
+
+ # Save the names of files that already exist in
+ # the output directory.
+ foreach file [glob -nocomplain \
+ [file join $::tcltest::temporaryDirectory *]] {
+ lappend ::tcltest::filesExisted [file tail $file]
+ }
+
+ ::tcltest::processCmdLineArgsHook [array get flag]
+
+ # Spit out everything you know if ::tcltest::debug is set.
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} {
+ puts "Flags passed into tcltest:"
+ parray flag
+ puts "::tcltest::debug = $::tcltest::debug"
+ puts "::tcltest::debugLevel = $::tcltest::debugLevel"
+ puts "::tcltest::testsDirectory = $::tcltest::testsDirectory"
+ puts "::tcltest::workingDirectory = $::tcltest::workingDirectory"
+ puts "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
+ puts "::tcltest::outputChannel = $::tcltest::outputChannel"
+ puts "::tcltest::errorChannel = $::tcltest::errorChannel"
+ puts "Original environment (::tcltest::originalEnv):"
+ parray ::tcltest::originalEnv
+ }
+}
+
+# ::tcltest::cleanupTests --
+#
+# Remove files and dirs created using the makeFile and makeDirectory
+# commands since the last time this proc was invoked.
+#
+# Print the names of the files created without the makeFile command
+# since the tests were invoked.
+#
+# Print the number tests (total, passed, failed, and skipped) since the
+# tests were invoked.
+#
+# Restore original environment (as reported by special variable env).
+
+proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
+
+ set testFileName [file tail [info script]]
+
+ # Call the cleanup hook
+ ::tcltest::cleanupTestsHook
+
+ # Remove files and directories created by the :tcltest::makeFile and
+ # ::tcltest::makeDirectory procedures.
+ # Record the names of files in ::tcltest::workingDirectory that were not
+ # pre-existing, and associate them with the test file that created them.
+
+ if {!$calledFromAllFile} {
+ foreach file $::tcltest::filesMade {
+ if {[file exists $file]} {
+ catch {file delete -force $file}
+ }
+ }
+ set currentFiles {}
+ foreach file [glob -nocomplain \
+ [file join $::tcltest::temporaryDirectory *]] {
+ lappend currentFiles [file tail $file]
+ }
+ set newFiles {}
+ foreach file $currentFiles {
+ if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
+ lappend newFiles $file
+ }
+ }
+ set ::tcltest::filesExisted $currentFiles
+ if {[llength $newFiles] > 0} {
+ set ::tcltest::createdNewFiles($testFileName) $newFiles
+ }
+ }
+
+ if {$calledFromAllFile || $::tcltest::testSingleFile} {
+
+ # print stats
+
+ puts -nonewline $::tcltest::outputChannel "$testFileName:"
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ puts -nonewline $::tcltest::outputChannel \
+ "\t$index\t$::tcltest::numTests($index)"
+ }
+ puts $::tcltest::outputChannel ""
+
+ # print number test files sourced
+ # print names of files that ran tests which failed
+
+ if {$calledFromAllFile} {
+ puts $::tcltest::outputChannel \
+ "Sourced $::tcltest::numTestFiles Test Files."
+ set ::tcltest::numTestFiles 0
+ if {[llength $::tcltest::failFiles] > 0} {
+ puts $::tcltest::outputChannel \
+ "Files with failing tests: $::tcltest::failFiles"
+ set ::tcltest::failFiles {}
+ }
+ }
+
+ # if any tests were skipped, print the constraints that kept them
+ # from running.
+
+ set constraintList [array names ::tcltest::skippedBecause]
+ if {[llength $constraintList] > 0} {
+ puts $::tcltest::outputChannel \
+ "Number of tests skipped for each constraint:"
+ foreach constraint [lsort $constraintList] {
+ puts $::tcltest::outputChannel \
+ "\t$::tcltest::skippedBecause($constraint)\t$constraint"
+ unset ::tcltest::skippedBecause($constraint)
+ }
+ }
+
+ # report the names of test files in ::tcltest::createdNewFiles, and
+ # reset the array to be empty.
+
+ set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
+ if {[llength $testFilesThatTurded] > 0} {
+ puts $::tcltest::outputChannel "Warning: files left behind:"
+ foreach testFile $testFilesThatTurded {
+ puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
+ unset ::tcltest::createdNewFiles($testFile)
+ }
+ }
+
+ # reset filesMade, filesExisted, and numTests
+
+ set ::tcltest::filesMade {}
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ set ::tcltest::numTests($index) 0
+ }
+
+ # restore the environment to the state it was in before this package
+ # was loaded
+
+ set newEnv {}
+ set changedEnv {}
+ set removedEnv {}
+ foreach index [array names env] {
+ if {![info exists ::tcltest::originalEnv($index)]} {
+ lappend newEnv $index
+ unset env($index)
+ } else {
+ if {$env($index) != $::tcltest::originalEnv($index)} {
+ lappend changedEnv $index
+ set env($index) $::tcltest::originalEnv($index)
+ }
+ }
+ }
+ foreach index [array names ::tcltest::originalEnv] {
+ if {![info exists ::env($index)]} {
+ lappend removedEnv $index
+ set env($index) $::tcltest::originalEnv($index)
+ }
+ }
+ if {[llength $newEnv] > 0} {
+ puts $::tcltest::outputChannel \
+ "\t\tenv array elements created:\t$newEnv"
+ }
+ if {[llength $changedEnv] > 0} {
+ puts $::tcltest::outputChannel \
+ "\t\tenv array elements changed:\t$changedEnv"
+ }
+ if {[llength $removedEnv] > 0} {
+ puts $::tcltest::outputChannel \
+ "\t\tenv array elements removed:\t$removedEnv"
+ }
+
+ # exit only if running Tk in non-interactive mode
+
+ global tk_version tcl_interactive
+ if {[info exists tk_version] && !$tcl_interactive} {
+ exit
+ }
+ } else {
+
+ # if we're deferring stat-reporting until all files are sourced,
+ # then add current file to failFile list if any tests in this file
+ # failed
+
+ incr ::tcltest::numTestFiles
+ if {($::tcltest::currentFailure) && \
+ ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} {
+ lappend ::tcltest::failFiles $testFileName
+ }
+ set ::tcltest::currentFailure false
+ }
+}
+
+proc ::tcltest::cleanupTestsHook {} {}
+
+# test --
+#
+# This procedure runs a test and prints an error message if the test fails.
+# If ::tcltest::verbose has been set, it also prints a message even if the
+# test succeeds. The test will be skipped if it doesn't match the
+# ::tcltest::match variable, if it matches an element in
+# ::tcltest::skip, or if one of the elements of "constraints" turns
+# out not to be true.
+#
+# Arguments:
+# name - Name of test, in the form foo-1.2.
+# description - Short textual description of the test, to
+# help humans understand what it does.
+# constraints - A list of one or more keywords, each of
+# which must be the name of an element in
+# the array "::tcltest::testConstraints". If any of these
+# elements is zero, the test is skipped.
+# This argument may be omitted.
+# script - Script to run to carry out the test. It must
+# return a result that can be checked for
+# correctness.
+# expectedAnswer - Expected result from script.
+
+proc ::tcltest::test {name description script expectedAnswer args} {
+ 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)
+ if {$::tcltest::debug} {
+ ::tcltest::AddToSkippedBecause userSpecifiedSkip
+ }
+ return
+ }
+ }
+
+ # skip the test if it's name doesn't match any element of match
+
+ if {[llength $::tcltest::match] > 0} {
+ set ok 0
+ foreach pattern $::tcltest::match {
+ if {[string match $pattern $name]} {
+ set ok 1
+ break
+ }
+ }
+ if {!$ok} {
+ incr ::tcltest::numTests(Skipped)
+ if {$::tcltest::debug} {
+ ::tcltest::AddToSkippedBecause userSpecifiedNonMatch
+ }
+ 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::testConstraints(a) || $::tcltest::testConstraints(b).
+
+ regsub -all {[.a-zA-Z0-9]+} $constraints \
+ {$::tcltest::testConstraints(&)} c
+ catch {set doTest [eval expr $c]}
+ } else {
+
+ # just simple constraints such as {unixOnly fonts}.
+
+ set doTest 1
+ foreach constraint $constraints {
+ if {![info exists ::tcltest::testConstraints($constraint)]
+ || !$::tcltest::testConstraints($constraint)} {
+ set doTest 0
+
+ # store the constraint that kept the test from running
+
+ set constraints $constraint
+ break
+ }
+ }
+ }
+ if {$doTest == 0} {
+ incr ::tcltest::numTests(Skipped)
+ if {[string first s $::tcltest::verbose] != -1} {
+ puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
+ }
+
+ ::tcltest::AddToSkippedBecause $constraints
+ return
+ }
+ } else {
+ error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
+ }
+ memory tag $name
+ set code [catch {uplevel $script} actualAnswer]
+ if {([string compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} {
+ incr ::tcltest::numTests(Passed)
+ if {[string first p $::tcltest::verbose] != -1} {
+ puts $::tcltest::outputChannel "++++ $name PASSED"
+ }
+ } else {
+ incr ::tcltest::numTests(Failed)
+ set ::tcltest::currentFailure true
+ if {[string first b $::tcltest::verbose] == -1} {
+ set script ""
+ }
+ puts $::tcltest::outputChannel "\n==== $name $description FAILED"
+ if {$script != ""} {
+ puts $::tcltest::outputChannel "==== Contents of test case:"
+ puts $::tcltest::outputChannel $script
+ }
+ if {$code != 0} {
+ if {$code == 1} {
+ puts $::tcltest::outputChannel "==== Test generated error:"
+ puts $::tcltest::outputChannel $actualAnswer
+ } elseif {$code == 2} {
+ puts $::tcltest::outputChannel "==== Test generated return exception; result was:"
+ puts $::tcltest::outputChannel $actualAnswer
+ } elseif {$code == 3} {
+ puts $::tcltest::outputChannel "==== Test generated break exception"
+ } elseif {$code == 4} {
+ puts $::tcltest::outputChannel "==== Test generated continue exception"
+ } else {
+ puts $::tcltest::outputChannel "==== Test generated exception $code; message was:"
+ puts $::tcltest::outputChannel $actualAnswer
+ }
+ } else {
+ puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
+ }
+ puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
+ puts $::tcltest::outputChannel "==== $name FAILED\n"
+ }
+}
+
+# ::tcltest::dotests --
+#
+# takes two arguments--the name of the test file (such
+# as "parse.test"), and a pattern selecting the tests you want to
+# execute. It sets ::tcltest::match to the second argument, calls
+# "source" on the file specified in the first argument, and restores
+# ::tcltest::match 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
+}
+
+proc ::tcltest::saveState {} {
+ uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} {
+ puts "::tcltest::saveState: $::tcltest::saveState"
+ }
+}
+
+proc ::tcltest::restoreState {} {
+ foreach p [info procs] {
+ if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
+ (![string equal ::tcltest::$p [namespace origin $p]])} {
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+ puts "::tcltest::restoreState: Removing proc $p"
+ }
+ rename $p {}
+ }
+ }
+ foreach p [uplevel #0 {info vars}] {
+ if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+ puts "::tcltest::restoreState: Removing variable $p"
+ }
+ uplevel #0 "unset $p"
+ }
+ }
+}
+
+proc ::tcltest::normalizeMsg {msg} {
+ regsub "\n$" [string tolower $msg] "" msg
+ regsub -all "\n\n" $msg "\n" msg
+ regsub -all "\n\}" $msg "\}" msg
+ return $msg
+}
+
+# makeFile --
+#
+# Create a new file with the name <name>, and write <contents> to it.
+#
+# If this file hasn't been created via makeFile since the last time
+# cleanupTests was called, add it to the $filesMade list, so it will
+# be removed by the next call to cleanupTests.
+#
+proc ::tcltest::makeFile {contents name} {
+ global tcl_platform
+
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+ puts "::tcltest::makeFile: putting $contents into $name"
+ }
+ set fd [open $name w]
+
+ # Doing the translation breaks TclPro Checker tests
+ # under Windows
+ if {[string equal $tcl_platform(platform) "unix"]} {
+ fconfigure $fd -translation lf
+ }
+
+ if {[string equal \
+ [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} {
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+ puts "::tcltest::removeFile: removing $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 {([string equal $tcl_platform(platform) "macintosh"]) || \
+ ($::tcltest::testConstraints(unixExecs) == 0)} {
+ set f [open $name]
+ set data [read -nonewline $f]
+ close $f
+ return $data
+ } else {
+ exec cat $name
+ }
+}
+
+# grep --
+#
+# Evaluate a given expression against each element of a list and return all
+# elements for which the expression evaluates to true. For the purposes of
+# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the
+# value of the current element within the expression. This is equivalent to
+# the perl grep command where CURRENT_ELEMENT would be the name for the special
+# variable $_.
+#
+# Examples of usage would be:
+# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers]
+# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings]
+#
+# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is
+# assumed to be the final argument to the expression provided.
+#
+# Example:
+# grep {regexp a} $someList
+#
+proc ::tcltest:grep { expression searchList } {
+ foreach element $searchList {
+ if {[regsub -all CURRENT_ELEMENT $expression $element \
+ newExpression] == 0} {
+ set newExpression "$expression {$element}"
+ }
+ if {[eval $newExpression] == 1} {
+ lappend returnList $element
+ }
+ }
+ if {[info exists returnList]} {
+ return $returnList
+ }
+ return
+}
+
+#
+# Construct a string that consists of the requested sequence of bytes,
+# as opposed to a string of properly formed UTF-8 characters.
+# This allows the tester to
+# 1. Create denormalized or improperly formed strings to pass to C procedures
+# that are supposed to accept strings with embedded NULL bytes.
+# 2. Confirm that a string result has a certain pattern of bytes, for instance
+# to confirm that "\xe0\0" in a Tcl script is stored internally in
+# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
+#
+# Generally, it's a bad idea to examine the bytes in a Tcl string or to
+# construct improperly formed strings in this manner, because it involves
+# exposing that Tcl uses UTF-8 internally.
+
+proc ::tcltest::bytestring {string} {
+ encoding convertfrom identity $string
+}
+
+#
+# Internationalization / ISO support procs -- dl
+#
+proc ::tcltest::set_iso8859_1_locale {} {
+ if {[info commands testlocale] != ""} {
+ set ::tcltest::previousLocale [testlocale ctype]
+ testlocale ctype $::tcltest::isoLocale
+ }
+ return
+}
+
+proc ::tcltest::restore_locale {} {
+ if {[info commands testlocale] != ""} {
+ testlocale ctype $::tcltest::previousLocale
+ }
+ return
+}
+
+# threadReap --
+#
+# Kill all threads except for the main thread.
+# Do nothing if testthread is not defined.
+#
+# Arguments:
+# none.
+#
+# Results:
+# Returns the number of existing threads.
+proc ::tcltest::threadReap {} {
+ if {[info commands testthread] != {}} {
+ testthread errorproc ThreadNullError
+ while {[llength [testthread names]] > 1} {
+ foreach tid [testthread names] {
+ if {$tid != $::tcltest::mainThread} {
+ catch {testthread send -async $tid {testthread exit}}
+ update
+ }
+ }
+ }
+ testthread errorproc ThreadError
+ return [llength [testthread names]]
+ } else {
+ return 1
+ }
+}
+
+# Initialize the constraints and set up command line arguments
+namespace eval tcltest {
+ ::tcltest::initConstraints
+ ::tcltest::processCmdLineArgs
+}
+
+return
diff --git a/library/tcltest1.0/pkgIndex.tcl b/library/tcltest1.0/pkgIndex.tcl
new file mode 100644
index 0000000..f9e2d30
--- /dev/null
+++ b/library/tcltest1.0/pkgIndex.tcl
@@ -0,0 +1,11 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile ::tcltest::normalizeMsg ::tcltest::removeDirectory ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory tcltest:grep}}}]
diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl
new file mode 100644
index 0000000..3375718
--- /dev/null
+++ b/library/tcltest1.0/tcltest.tcl
@@ -0,0 +1,1237 @@
+# tcltest.tcl --
+#
+# This file contains support code for the Tcl test suite. It defines the
+# defines the ::tcltest namespace and finds and defines the output
+# directory, constraints available, output and error channels, etc. used
+# by Tcl tests. See the README file for more details.
+#
+# This design was based on the original Tcl testing approach designed and
+# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
+#
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id: tcltest.tcl,v 1.1 1999/06/26 03:53:45 jenn Exp $
+
+package provide tcltest 1.0
+
+# Ensure that we have a minimal auto_path so we don't pick up extra junk.
+set auto_path [list [info library]]
+
+# create the "tcltest" namespace for all testing variables and procedures
+
+namespace eval tcltest {
+
+ # Export the public tcltest procs
+ set procList [list test cleanupTests dotests saveState restoreState \
+ normalizeMsg makeFile removeFile makeDirectory removeDirectory \
+ viewFile grep bytestring set_iso8859_1_locale restore_locale \
+ safeFetch threadReap]
+ foreach proc $procList {
+ namespace export $proc
+ }
+
+ # ::tcltest::verbose defaults to "b"
+
+ variable verbose "b"
+
+ # match defaults to the empty list
+
+ variable match {}
+
+ # skip defaults to the empty list
+
+ variable skip {}
+
+ # output goes to stdout by default
+
+ variable outputChannel stdout
+
+ # errors go to stderr by default
+
+ variable errorChannel stderr
+
+ # debug output doesn't get printed by default; default debugLevel (1) spits
+ # up only the tets that were skipped because they didn't match or were
+ # specifically skipped. A debugLevel of 2 would spit up the tcltest
+ # variables and flags provided; a debugLevel of 3 causes some additional
+ # output regarding operations of the test harness. The tcltest package
+ # currently implements only up to debugLevel 3.
+
+ variable debug false
+ variable debugLevel 1
+
+ # 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 ::tcltest::numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
+
+ # initialize ::tcltest::skippedBecause array to keep track of
+ # constraints that kept tests from running; a constraint name of
+ # "userSpecifiedSkip" means that the test appeared on the list of tests
+ # that matched the -skip value given to the flag; "userSpecifiedNonMatch"
+ # means that the test didn't match the argument given to the -match flag;
+ # both of these constraints are counted only if ::tcltest::debug is set to
+ # true.
+
+ array set ::tcltest::skippedBecause {}
+
+ # initialize the ::tcltest::testConstraints array to keep track of valid
+ # predefined constraints (see the explanation for the ::tcltest::initConstraints
+ # proc for more details).
+
+ array set ::tcltest::testConstraints {}
+
+ # tests that use thread need to know which is the main thread
+
+ variable mainThread 1
+ if {[info commands testthread] != {}} {
+ set mainThread [testthread names]
+ }
+
+ # save the original environement so that it can be restored later
+
+ array set ::tcltest::originalEnv [array get ::env]
+
+ # TclPro has other variables that need to be set, including the locations
+ # of various directories.
+
+ # Set ::tcltest::workingDirectory to [pwd]. The default output directory
+ # for Tcl tests is the working directory.
+
+ variable workingDirectory [pwd]
+ variable temporaryDirectory $workingDirectory
+
+ # Tests should not rely on the current working directory.
+ # Files that are part of the test suite should be accessed relative to
+ # ::tcltest::testsDirectory.
+
+ variable testsDirectory [pwd]
+
+ variable saveState {}
+
+ # Internationalization support
+ if {![info exists ::tcltest::isoLocale]} {
+ variable isoLocale fr
+ switch $tcl_platform(platform) {
+ "unix" {
+
+ # Try some 'known' values for some platforms:
+
+ switch -exact -- $tcl_platform(os) {
+ "FreeBSD" {
+ set ::tcltest::isoLocale fr_FR.ISO_8859-1
+ }
+ HP-UX {
+ set ::tcltest::isoLocale fr_FR.iso88591
+ }
+ Linux -
+ IRIX {
+ set ::tcltest::isoLocale fr
+ }
+ default {
+
+ # Works on SunOS 4 and Solaris, and maybe others...
+ # define it to something else on your system
+ #if you want to test those.
+
+ set ::tcltest::isoLocale iso_8859_1
+ }
+ }
+ }
+ "windows" {
+ set ::tcltest::isoLocale French
+ }
+ }
+ }
+
+ # Set the location of the execuatble
+ variable tcltest [info nameofexecutable]
+
+ # If there is no "memory" command (because memory debugging isn't
+ # enabled), generate a dummy command that does nothing.
+
+ if {[info commands memory] == {}} {
+ namespace eval :: {
+ proc memory args {}
+ }
+ }
+}
+
+
+proc ::tcltest::AddToSkippedBecause { constraint } {
+ # add the constraint to the list of constraints the kept tests
+ # from running
+
+ if {[info exists ::tcltest::skippedBecause($constraint)]} {
+ incr ::tcltest::skippedBecause($constraint)
+ } else {
+ set ::tcltest::skippedBecause($constraint) 1
+ }
+ return
+}
+
+# ::tcltest::PrintError --
+#
+# Prints errors to ::tcltest::errorChannel and then flushes that
+# channel.
+#
+# Arguments:
+# errorMsg String containing the error to be printed
+#
+
+proc ::tcltest::PrintError {errorMsg} {
+ set InitialMessage "Error: "
+ set InitialMsgLen [string length $InitialMessage]
+ puts -nonewline $::tcltest::errorChannel $InitialMessage
+ set beginningIndex [string wordend $errorMsg 72]
+ puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]
+ set endingIndex [string length $errorMsg]
+ while {$beginningIndex < $endingIndex} {
+ set newEndingIndex [string wordend $errorMsg \
+ [expr {$beginningIndex + 72}]]
+ puts -nonewline $::tcltest::errorChannel \
+ [string repeat " " $InitialMsgLen]
+ puts $::tcltest::errorChannel [string trim \
+ [string range $errorMsg $beginningIndex $newEndingIndex]]
+ set beginningIndex $newEndingIndex
+ }
+ return
+}
+
+proc ::tcltest::initConstraintsHook {} {}
+
+# ::tcltest::initConstraints --
+#
+# Check Constraintsuration information that will determine which tests
+# to run. To do this, create an array ::tcltest::testConstraints. Each
+# element has a 0 or 1 value. If the element is "true" then tests
+# with that constraint will be run, otherwise tests with that constraint
+# will be skipped. See the README file for the list of built-in
+# constraints defined in this procedure.
+#
+# Arguments:
+# none
+#
+# Results:
+# The ::tcltest::testConstraints array is reset to have an index for
+# each built-in test constraint.
+
+proc ::tcltest::initConstraints {} {
+ global tcl_platform tcl_interactive tk_version
+
+ catch {unset ::tcltest::testConstraints}
+
+ # The following trace procedure makes it so that we can safely refer to
+ # non-existent members of the ::tcltest::testConstraints array without causing an
+ # error. Instead, reading a non-existent member will return 0. This is
+ # necessary because tests are allowed to use constraint "X" without ensuring
+ # that ::tcltest::testConstraints("X") is defined.
+
+ trace variable ::tcltest::testConstraints r ::tcltest::safeFetch
+
+ proc ::tcltest::safeFetch {n1 n2 op} {
+ if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} {
+ set ::tcltest::testConstraints($n2) 0
+ }
+ }
+
+ ::tcltest::initConstraintsHook
+
+ set ::tcltest::testConstraints(unixOnly) \
+ [string equal $tcl_platform(platform) "unix"]
+ set ::tcltest::testConstraints(macOnly) \
+ [string equal $tcl_platform(platform) "macintosh"]
+ set ::tcltest::testConstraints(pcOnly) \
+ [string equal $tcl_platform(platform) "windows"]
+
+ set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly)
+ set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly)
+ set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly)
+
+ set ::tcltest::testConstraints(unixOrPc) \
+ [expr {$::tcltest::testConstraints(unix) || $::tcltest::testConstraints(pc)}]
+ set ::tcltest::testConstraints(macOrPc) \
+ [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(pc)}]
+ set ::tcltest::testConstraints(macOrUnix) \
+ [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(unix)}]
+
+ set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) "Windows NT"]
+ set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) "Windows 95"]
+ set ::tcltest::testConstraints(win32s) [string equal $tcl_platform(os) "Win32s"]
+
+ # The following Constraints switches are used to mark tests that should work,
+ # but have been temporarily disabled on certain platforms because they don't
+ # and we haven't gotten around to fixing the underlying problem.
+
+ set ::tcltest::testConstraints(tempNotPc) [expr {!$::tcltest::testConstraints(pc)}]
+ set ::tcltest::testConstraints(tempNotMac) [expr {!$::tcltest::testConstraints(mac)}]
+ set ::tcltest::testConstraints(tempNotUnix) [expr {!$::tcltest::testConstraints(unix)}]
+
+ # The following Constraints switches are used to mark tests that crash on
+ # certain platforms, so that they can be reactivated again when the
+ # underlying problem is fixed.
+
+ set ::tcltest::testConstraints(pcCrash) [expr {!$::tcltest::testConstraints(pc)}]
+ set ::tcltest::testConstraints(win32sCrash) [expr {!$::tcltest::testConstraints(win32s)}]
+ set ::tcltest::testConstraints(macCrash) [expr {!$::tcltest::testConstraints(mac)}]
+ set ::tcltest::testConstraints(unixCrash) [expr {!$::tcltest::testConstraints(unix)}]
+
+ # Skip empty tests
+
+ set ::tcltest::testConstraints(emptyTest) 0
+
+ # By default, tests that expose known bugs are skipped.
+
+ set ::tcltest::testConstraints(knownBug) 0
+
+ # By default, non-portable tests are skipped.
+
+ set ::tcltest::testConstraints(nonPortable) 0
+
+ # Some tests require user interaction.
+
+ set ::tcltest::testConstraints(userInteraction) 0
+
+ # Some tests must be skipped if the interpreter is not in interactive mode
+
+ set ::tcltest::testConstraints(interactive) $tcl_interactive
+
+ # Some tests can only be run if the installation came from a CD image
+ # instead of a web image
+ # Some tests must be skipped if you are running as root on Unix.
+ # Other tests can only be run if you are running as root on Unix.
+
+ set ::tcltest::testConstraints(root) 0
+ set ::tcltest::testConstraints(notRoot) 1
+ set user {}
+ if {[string equal $tcl_platform(platform) "unix"]} {
+ catch {set user [exec whoami]}
+ if {[string equal $user ""]} {
+ catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
+ }
+ if {([string equal $user "root"]) || ([string equal $user ""])} {
+ set ::tcltest::testConstraints(root) 1
+ set ::tcltest::testConstraints(notRoot) 0
+ }
+ }
+
+ # Set nonBlockFiles constraint: 1 means this platform supports
+ # setting files into nonblocking mode.
+
+ if {[catch {set f [open defs r]}]} {
+ set ::tcltest::testConstraints(nonBlockFiles) 1
+ } else {
+ if {[catch {fconfigure $f -blocking off}] == 0} {
+ set ::tcltest::testConstraints(nonBlockFiles) 1
+ } else {
+ set ::tcltest::testConstraints(nonBlockFiles) 0
+ }
+ close $f
+ }
+
+ # Set asyncPipeClose constraint: 1 means this platform supports
+ # async flush and async close on a pipe.
+ #
+ # Test for SCO Unix - cannot run async flushing tests because a
+ # potential problem with select is apparently interfering.
+ # (Mark Diekhans).
+
+ if {[string equal $tcl_platform(platform) "unix"]} {
+ if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
+ set ::tcltest::testConstraints(asyncPipeClose) 0
+ } else {
+ set ::tcltest::testConstraints(asyncPipeClose) 1
+ }
+ } else {
+ set ::tcltest::testConstraints(asyncPipeClose) 1
+ }
+
+ # Test to see if we have a broken version of sprintf with respect
+ # to the "e" format of floating-point numbers.
+
+ set ::tcltest::testConstraints(eformat) 1
+ if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
+ set ::tcltest::testConstraints(eformat) 0
+ }
+
+ # Test to see if execed commands such as cat, echo, rm and so forth are
+ # present on this machine.
+
+ set ::tcltest::testConstraints(unixExecs) 1
+ if {[string equal $tcl_platform(platform) "macintosh"]} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([string equal $tcl_platform(platform) "windows"])} {
+ if {[catch {exec cat defs}] == 1} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec echo hello}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec sh -c echo hello}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec wc defs}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {$::tcltest::testConstraints(unixExecs) == 1} {
+ exec echo hello > removeMe
+ if {[catch {exec rm removeMe}] == 1} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec sleep 1}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec fgrep unixExecs defs}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec ps}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec echo abc > removeMe}] == 0) && \
+ ([catch {exec chmod 644 removeMe}] == 1) && \
+ ([catch {exec rm removeMe}] == 0)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ } else {
+ catch {exec rm -f removeMe}
+ }
+ if {($::tcltest::testConstraints(unixExecs) == 1) && \
+ ([catch {exec mkdir removeMe}] == 1)} {
+ set ::tcltest::testConstraints(unixExecs) 0
+ } else {
+ catch {exec rm -r removeMe}
+ }
+ }
+
+ # Locate tcltest executable
+
+ if {![info exists tk_version]} {
+ set tcltest [info nameofexecutable]
+
+ if {$tcltest == "{}"} {
+ set tcltest {}
+ }
+ }
+
+ set ::tcltest::testConstraints(stdio) 0
+ catch {
+ catch {file delete -force tmp}
+ set f [open tmp w]
+ puts $f {
+ exit
+ }
+ close $f
+
+ set f [open "|[list $tcltest tmp]" r]
+ close $f
+
+ set ::tcltest::testConstraints(stdio) 1
+ }
+ catch {file delete -force tmp}
+
+ # Deliberately call socket with the wrong number of arguments. The error
+ # message you get will indicate whether sockets are available on this system.
+
+ catch {socket} msg
+ set ::tcltest::testConstraints(socket) \
+ [expr {$msg != "sockets are not available on this system"}]
+
+ # Check for internationalization
+
+ if {[info commands testlocale] == ""} {
+ # No testlocale command, no tests...
+ set ::tcltest::testConstraints(hasIsoLocale) 0
+ } else {
+ set ::tcltest::testConstraints(hasIsoLocale) \
+ [string length [::tcltest::set_iso8859_1_locale]]
+ ::tcltest::restore_locale
+ }
+}
+
+proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
+
+proc ::tcltest::processCmdLineArgsHook {flag} {}
+
+# ::tcltest::processCmdLineArgs --
+#
+# Use command line args to set the verbose, skip, and
+# match, outputChannel, errorChannel, debug, and temporaryDirectory
+# variables.
+#
+# This procedure must be run after constraints are initialized, because
+# some constraints can be overridden.
+#
+# Arguments:
+# none
+#
+# Results:
+# Sets the above-named variables in the tcltest namespace.
+
+proc ::tcltest::processCmdLineArgs {} {
+ global argv
+
+ # The "argv" var doesn't exist in some cases, so use {}.
+
+ if {(![info exists argv]) || ([llength $argv] < 2)} {
+ set flagArray {}
+ } else {
+ set flagArray $argv
+ }
+
+ # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
+ # Note that -verbose cannot be abbreviated to -v in wish because it
+ # conflicts with the wish option -visual.
+
+ if {[catch {array set flag $flagArray}]} {
+ ::tcltest::PrintError "odd number of arguments specified on command line: \
+ $argv"
+ exit
+ }
+
+ lappend defaultFlags {-verbose -match -skip -constraints \
+ -outfile -errfile -debug -tmpdir}
+ lappend defaultFlags [ ::tcltest::processCmdLineArgsAddFlagsHook ]
+
+ foreach arg $defaultFlags {
+ set abbrev [string range $arg 0 1]
+ if {([info exists flag($abbrev)]) && \
+ ([lsearch -exact $flagArray $arg] < \
+ [lsearch -exact $flagArray $abbrev])} {
+ set flag($arg) $flag($abbrev)
+ }
+ }
+
+ # 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::testConstraints($elt) 1
+ }
+ }
+
+ # If an alternate error or output files are specified, change the
+ # default channels.
+
+ if {[info exists flag(-outfile)]} {
+ set tmp $flag(-outfile)
+ if {[string compare [file pathtype $tmp] "absolute"] != 0} {
+ set tmp [file join $::tcltest::temporaryDirectory $tmp]
+ }
+ set ::tcltest::outputChannel [open $tmp w]
+ }
+
+ if {[info exists flag(-errfile)]} {
+ set tmp $flag(-errfile)
+ if {[string compare [file pathtype $tmp] "absolute"] != 0} {
+ set tmp [file join $::tcltest::temporaryDirectory $tmp]
+ }
+ set ::tcltest::errorChannel [open $tmp w]
+ }
+
+ # If the user specifies debug testing, print out extra information during
+ # the run.
+ if {[info exists flag(-debug)]} {
+ set ::tcltest::debug true
+ if {$flag(-debug) != {}} {
+ set ::tcltest::debugLevel $flag(-debug)
+ }
+ }
+
+ # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if
+ # given.
+ #
+ # If the path is relative, make it absolute. If the file exists but
+ # is not a dir, then return an error.
+ #
+ # If ::tcltest::temporaryDirectory does not already exist, create it.
+ # If you cannot create it, then return an error.
+
+ set tmpDirError ""
+ if {[info exists flag(-tmpdir)]} {
+ set ::tcltest::temporaryDirectory $flag(-tmpdir)
+
+ if {[string compare \
+ [file pathtype $::tcltest::temporaryDirectory] \
+ "absolute"] != 0} {
+ set ::tcltest::temporaryDirectory [file join [pwd] \
+ $::tcltest::temporaryDirectory]
+ }
+ set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
+ }
+ if {[file exists $::tcltest::temporaryDirectory]} {
+ if {![file isdir $::tcltest::temporaryDirectory]} {
+ ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
+ is not a directory"
+ exit
+ } elseif {![file writable $::tcltest::temporaryDirectory]} {
+ ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
+ is not writeable"
+ exit
+ } elseif {![file readable $::tcltest::temporaryDirectory]} {
+ ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \
+ is not readable"
+ exit
+ }
+ } else {
+ file mkdir $::tcltest::temporaryDirectory
+ }
+
+ # Save the names of files that already exist in
+ # the output directory.
+ foreach file [glob -nocomplain \
+ [file join $::tcltest::temporaryDirectory *]] {
+ lappend ::tcltest::filesExisted [file tail $file]
+ }
+
+ ::tcltest::processCmdLineArgsHook [array get flag]
+
+ # Spit out everything you know if ::tcltest::debug is set.
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} {
+ puts "Flags passed into tcltest:"
+ parray flag
+ puts "::tcltest::debug = $::tcltest::debug"
+ puts "::tcltest::debugLevel = $::tcltest::debugLevel"
+ puts "::tcltest::testsDirectory = $::tcltest::testsDirectory"
+ puts "::tcltest::workingDirectory = $::tcltest::workingDirectory"
+ puts "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
+ puts "::tcltest::outputChannel = $::tcltest::outputChannel"
+ puts "::tcltest::errorChannel = $::tcltest::errorChannel"
+ puts "Original environment (::tcltest::originalEnv):"
+ parray ::tcltest::originalEnv
+ }
+}
+
+# ::tcltest::cleanupTests --
+#
+# Remove files and dirs created using the makeFile and makeDirectory
+# commands since the last time this proc was invoked.
+#
+# Print the names of the files created without the makeFile command
+# since the tests were invoked.
+#
+# Print the number tests (total, passed, failed, and skipped) since the
+# tests were invoked.
+#
+# Restore original environment (as reported by special variable env).
+
+proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
+
+ set testFileName [file tail [info script]]
+
+ # Call the cleanup hook
+ ::tcltest::cleanupTestsHook
+
+ # Remove files and directories created by the :tcltest::makeFile and
+ # ::tcltest::makeDirectory procedures.
+ # Record the names of files in ::tcltest::workingDirectory that were not
+ # pre-existing, and associate them with the test file that created them.
+
+ if {!$calledFromAllFile} {
+ foreach file $::tcltest::filesMade {
+ if {[file exists $file]} {
+ catch {file delete -force $file}
+ }
+ }
+ set currentFiles {}
+ foreach file [glob -nocomplain \
+ [file join $::tcltest::temporaryDirectory *]] {
+ lappend currentFiles [file tail $file]
+ }
+ set newFiles {}
+ foreach file $currentFiles {
+ if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
+ lappend newFiles $file
+ }
+ }
+ set ::tcltest::filesExisted $currentFiles
+ if {[llength $newFiles] > 0} {
+ set ::tcltest::createdNewFiles($testFileName) $newFiles
+ }
+ }
+
+ if {$calledFromAllFile || $::tcltest::testSingleFile} {
+
+ # print stats
+
+ puts -nonewline $::tcltest::outputChannel "$testFileName:"
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ puts -nonewline $::tcltest::outputChannel \
+ "\t$index\t$::tcltest::numTests($index)"
+ }
+ puts $::tcltest::outputChannel ""
+
+ # print number test files sourced
+ # print names of files that ran tests which failed
+
+ if {$calledFromAllFile} {
+ puts $::tcltest::outputChannel \
+ "Sourced $::tcltest::numTestFiles Test Files."
+ set ::tcltest::numTestFiles 0
+ if {[llength $::tcltest::failFiles] > 0} {
+ puts $::tcltest::outputChannel \
+ "Files with failing tests: $::tcltest::failFiles"
+ set ::tcltest::failFiles {}
+ }
+ }
+
+ # if any tests were skipped, print the constraints that kept them
+ # from running.
+
+ set constraintList [array names ::tcltest::skippedBecause]
+ if {[llength $constraintList] > 0} {
+ puts $::tcltest::outputChannel \
+ "Number of tests skipped for each constraint:"
+ foreach constraint [lsort $constraintList] {
+ puts $::tcltest::outputChannel \
+ "\t$::tcltest::skippedBecause($constraint)\t$constraint"
+ unset ::tcltest::skippedBecause($constraint)
+ }
+ }
+
+ # report the names of test files in ::tcltest::createdNewFiles, and
+ # reset the array to be empty.
+
+ set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
+ if {[llength $testFilesThatTurded] > 0} {
+ puts $::tcltest::outputChannel "Warning: files left behind:"
+ foreach testFile $testFilesThatTurded {
+ puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
+ unset ::tcltest::createdNewFiles($testFile)
+ }
+ }
+
+ # reset filesMade, filesExisted, and numTests
+
+ set ::tcltest::filesMade {}
+ foreach index [list "Total" "Passed" "Skipped" "Failed"] {
+ set ::tcltest::numTests($index) 0
+ }
+
+ # restore the environment to the state it was in before this package
+ # was loaded
+
+ set newEnv {}
+ set changedEnv {}
+ set removedEnv {}
+ foreach index [array names env] {
+ if {![info exists ::tcltest::originalEnv($index)]} {
+ lappend newEnv $index
+ unset env($index)
+ } else {
+ if {$env($index) != $::tcltest::originalEnv($index)} {
+ lappend changedEnv $index
+ set env($index) $::tcltest::originalEnv($index)
+ }
+ }
+ }
+ foreach index [array names ::tcltest::originalEnv] {
+ if {![info exists ::env($index)]} {
+ lappend removedEnv $index
+ set env($index) $::tcltest::originalEnv($index)
+ }
+ }
+ if {[llength $newEnv] > 0} {
+ puts $::tcltest::outputChannel \
+ "\t\tenv array elements created:\t$newEnv"
+ }
+ if {[llength $changedEnv] > 0} {
+ puts $::tcltest::outputChannel \
+ "\t\tenv array elements changed:\t$changedEnv"
+ }
+ if {[llength $removedEnv] > 0} {
+ puts $::tcltest::outputChannel \
+ "\t\tenv array elements removed:\t$removedEnv"
+ }
+
+ # exit only if running Tk in non-interactive mode
+
+ global tk_version tcl_interactive
+ if {[info exists tk_version] && !$tcl_interactive} {
+ exit
+ }
+ } else {
+
+ # if we're deferring stat-reporting until all files are sourced,
+ # then add current file to failFile list if any tests in this file
+ # failed
+
+ incr ::tcltest::numTestFiles
+ if {($::tcltest::currentFailure) && \
+ ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} {
+ lappend ::tcltest::failFiles $testFileName
+ }
+ set ::tcltest::currentFailure false
+ }
+}
+
+proc ::tcltest::cleanupTestsHook {} {}
+
+# test --
+#
+# This procedure runs a test and prints an error message if the test fails.
+# If ::tcltest::verbose has been set, it also prints a message even if the
+# test succeeds. The test will be skipped if it doesn't match the
+# ::tcltest::match variable, if it matches an element in
+# ::tcltest::skip, or if one of the elements of "constraints" turns
+# out not to be true.
+#
+# Arguments:
+# name - Name of test, in the form foo-1.2.
+# description - Short textual description of the test, to
+# help humans understand what it does.
+# constraints - A list of one or more keywords, each of
+# which must be the name of an element in
+# the array "::tcltest::testConstraints". If any of these
+# elements is zero, the test is skipped.
+# This argument may be omitted.
+# script - Script to run to carry out the test. It must
+# return a result that can be checked for
+# correctness.
+# expectedAnswer - Expected result from script.
+
+proc ::tcltest::test {name description script expectedAnswer args} {
+ 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)
+ if {$::tcltest::debug} {
+ ::tcltest::AddToSkippedBecause userSpecifiedSkip
+ }
+ return
+ }
+ }
+
+ # skip the test if it's name doesn't match any element of match
+
+ if {[llength $::tcltest::match] > 0} {
+ set ok 0
+ foreach pattern $::tcltest::match {
+ if {[string match $pattern $name]} {
+ set ok 1
+ break
+ }
+ }
+ if {!$ok} {
+ incr ::tcltest::numTests(Skipped)
+ if {$::tcltest::debug} {
+ ::tcltest::AddToSkippedBecause userSpecifiedNonMatch
+ }
+ 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::testConstraints(a) || $::tcltest::testConstraints(b).
+
+ regsub -all {[.a-zA-Z0-9]+} $constraints \
+ {$::tcltest::testConstraints(&)} c
+ catch {set doTest [eval expr $c]}
+ } else {
+
+ # just simple constraints such as {unixOnly fonts}.
+
+ set doTest 1
+ foreach constraint $constraints {
+ if {![info exists ::tcltest::testConstraints($constraint)]
+ || !$::tcltest::testConstraints($constraint)} {
+ set doTest 0
+
+ # store the constraint that kept the test from running
+
+ set constraints $constraint
+ break
+ }
+ }
+ }
+ if {$doTest == 0} {
+ incr ::tcltest::numTests(Skipped)
+ if {[string first s $::tcltest::verbose] != -1} {
+ puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
+ }
+
+ ::tcltest::AddToSkippedBecause $constraints
+ return
+ }
+ } else {
+ error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
+ }
+ memory tag $name
+ set code [catch {uplevel $script} actualAnswer]
+ if {([string compare $actualAnswer $expectedAnswer] == 0) && ($code == 0)} {
+ incr ::tcltest::numTests(Passed)
+ if {[string first p $::tcltest::verbose] != -1} {
+ puts $::tcltest::outputChannel "++++ $name PASSED"
+ }
+ } else {
+ incr ::tcltest::numTests(Failed)
+ set ::tcltest::currentFailure true
+ if {[string first b $::tcltest::verbose] == -1} {
+ set script ""
+ }
+ puts $::tcltest::outputChannel "\n==== $name $description FAILED"
+ if {$script != ""} {
+ puts $::tcltest::outputChannel "==== Contents of test case:"
+ puts $::tcltest::outputChannel $script
+ }
+ if {$code != 0} {
+ if {$code == 1} {
+ puts $::tcltest::outputChannel "==== Test generated error:"
+ puts $::tcltest::outputChannel $actualAnswer
+ } elseif {$code == 2} {
+ puts $::tcltest::outputChannel "==== Test generated return exception; result was:"
+ puts $::tcltest::outputChannel $actualAnswer
+ } elseif {$code == 3} {
+ puts $::tcltest::outputChannel "==== Test generated break exception"
+ } elseif {$code == 4} {
+ puts $::tcltest::outputChannel "==== Test generated continue exception"
+ } else {
+ puts $::tcltest::outputChannel "==== Test generated exception $code; message was:"
+ puts $::tcltest::outputChannel $actualAnswer
+ }
+ } else {
+ puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
+ }
+ puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
+ puts $::tcltest::outputChannel "==== $name FAILED\n"
+ }
+}
+
+# ::tcltest::dotests --
+#
+# takes two arguments--the name of the test file (such
+# as "parse.test"), and a pattern selecting the tests you want to
+# execute. It sets ::tcltest::match to the second argument, calls
+# "source" on the file specified in the first argument, and restores
+# ::tcltest::match 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
+}
+
+proc ::tcltest::saveState {} {
+ uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 1)} {
+ puts "::tcltest::saveState: $::tcltest::saveState"
+ }
+}
+
+proc ::tcltest::restoreState {} {
+ foreach p [info procs] {
+ if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
+ (![string equal ::tcltest::$p [namespace origin $p]])} {
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+ puts "::tcltest::restoreState: Removing proc $p"
+ }
+ rename $p {}
+ }
+ }
+ foreach p [uplevel #0 {info vars}] {
+ if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+ puts "::tcltest::restoreState: Removing variable $p"
+ }
+ uplevel #0 "unset $p"
+ }
+ }
+}
+
+proc ::tcltest::normalizeMsg {msg} {
+ regsub "\n$" [string tolower $msg] "" msg
+ regsub -all "\n\n" $msg "\n" msg
+ regsub -all "\n\}" $msg "\}" msg
+ return $msg
+}
+
+# makeFile --
+#
+# Create a new file with the name <name>, and write <contents> to it.
+#
+# If this file hasn't been created via makeFile since the last time
+# cleanupTests was called, add it to the $filesMade list, so it will
+# be removed by the next call to cleanupTests.
+#
+proc ::tcltest::makeFile {contents name} {
+ global tcl_platform
+
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+ puts "::tcltest::makeFile: putting $contents into $name"
+ }
+ set fd [open $name w]
+
+ # Doing the translation breaks TclPro Checker tests
+ # under Windows
+ if {[string equal $tcl_platform(platform) "unix"]} {
+ fconfigure $fd -translation lf
+ }
+
+ if {[string equal \
+ [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} {
+ if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} {
+ puts "::tcltest::removeFile: removing $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 {([string equal $tcl_platform(platform) "macintosh"]) || \
+ ($::tcltest::testConstraints(unixExecs) == 0)} {
+ set f [open $name]
+ set data [read -nonewline $f]
+ close $f
+ return $data
+ } else {
+ exec cat $name
+ }
+}
+
+# grep --
+#
+# Evaluate a given expression against each element of a list and return all
+# elements for which the expression evaluates to true. For the purposes of
+# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the
+# value of the current element within the expression. This is equivalent to
+# the perl grep command where CURRENT_ELEMENT would be the name for the special
+# variable $_.
+#
+# Examples of usage would be:
+# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers]
+# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings]
+#
+# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is
+# assumed to be the final argument to the expression provided.
+#
+# Example:
+# grep {regexp a} $someList
+#
+proc ::tcltest:grep { expression searchList } {
+ foreach element $searchList {
+ if {[regsub -all CURRENT_ELEMENT $expression $element \
+ newExpression] == 0} {
+ set newExpression "$expression {$element}"
+ }
+ if {[eval $newExpression] == 1} {
+ lappend returnList $element
+ }
+ }
+ if {[info exists returnList]} {
+ return $returnList
+ }
+ return
+}
+
+#
+# Construct a string that consists of the requested sequence of bytes,
+# as opposed to a string of properly formed UTF-8 characters.
+# This allows the tester to
+# 1. Create denormalized or improperly formed strings to pass to C procedures
+# that are supposed to accept strings with embedded NULL bytes.
+# 2. Confirm that a string result has a certain pattern of bytes, for instance
+# to confirm that "\xe0\0" in a Tcl script is stored internally in
+# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
+#
+# Generally, it's a bad idea to examine the bytes in a Tcl string or to
+# construct improperly formed strings in this manner, because it involves
+# exposing that Tcl uses UTF-8 internally.
+
+proc ::tcltest::bytestring {string} {
+ encoding convertfrom identity $string
+}
+
+#
+# Internationalization / ISO support procs -- dl
+#
+proc ::tcltest::set_iso8859_1_locale {} {
+ if {[info commands testlocale] != ""} {
+ set ::tcltest::previousLocale [testlocale ctype]
+ testlocale ctype $::tcltest::isoLocale
+ }
+ return
+}
+
+proc ::tcltest::restore_locale {} {
+ if {[info commands testlocale] != ""} {
+ testlocale ctype $::tcltest::previousLocale
+ }
+ return
+}
+
+# threadReap --
+#
+# Kill all threads except for the main thread.
+# Do nothing if testthread is not defined.
+#
+# Arguments:
+# none.
+#
+# Results:
+# Returns the number of existing threads.
+proc ::tcltest::threadReap {} {
+ if {[info commands testthread] != {}} {
+ testthread errorproc ThreadNullError
+ while {[llength [testthread names]] > 1} {
+ foreach tid [testthread names] {
+ if {$tid != $::tcltest::mainThread} {
+ catch {testthread send -async $tid {testthread exit}}
+ update
+ }
+ }
+ }
+ testthread errorproc ThreadError
+ return [llength [testthread names]]
+ } else {
+ return 1
+ }
+}
+
+# Initialize the constraints and set up command line arguments
+namespace eval tcltest {
+ ::tcltest::initConstraints
+ ::tcltest::processCmdLineArgs
+}
+
+return
generated by cgit v0.12 at 2024-11-14 05:05:28 (GMT)