summaryrefslogtreecommitdiff
path: root/tcl/library/tcltest1.0/tcltest.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tcl/library/tcltest1.0/tcltest.tcl')
-rw-r--r--tcl/library/tcltest1.0/tcltest.tcl1906
1 files changed, 1906 insertions, 0 deletions
diff --git a/tcl/library/tcltest1.0/tcltest.tcl b/tcl/library/tcltest1.0/tcltest.tcl
new file mode 100644
index 00000000000..a2fc5a7f0ac
--- /dev/null
+++ b/tcl/library/tcltest1.0/tcltest.tcl
@@ -0,0 +1,1906 @@
+# tcltest.tcl --
+#
+# This file contains support code for the Tcl test suite. It
+# defines the ::tcltest namespace and finds and defines the output
+# directory, constraints available, output and error channels, etc. used
+# by Tcl tests. See the tcltest man page for more details.
+#
+# This design was based on the Tcl testing approach designed and
+# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
+#
+# Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id$
+
+package provide tcltest 1.0
+
+# create the "tcltest" namespace for all testing variables and procedures
+
+namespace eval tcltest {
+
+ # Export the public tcltest procs
+ set procList [list test cleanupTests saveState restoreState \
+ normalizeMsg makeFile removeFile makeDirectory removeDirectory \
+ viewFile bytestring safeFetch threadReap getMatchingFiles \
+ loadTestedCommands normalizePath]
+ foreach proc $procList {
+ namespace export $proc
+ }
+
+ # ::tcltest::verbose defaults to "b"
+ if {![info exists verbose]} {
+ variable verbose "b"
+ }
+
+ # Match and skip patterns default to the empty list, except for
+ # matchFiles, which defaults to all .test files in the testsDirectory
+
+ if {![info exists match]} {
+ variable match {}
+ }
+ if {![info exists skip]} {
+ variable skip {}
+ }
+ if {![info exists matchFiles]} {
+ variable matchFiles {*.test}
+ }
+ if {![info exists skipFiles]} {
+ variable skipFiles {}
+ }
+
+ # By default, don't save core files
+ if {![info exists preserveCore]} {
+ variable preserveCore 0
+ }
+
+ # output goes to stdout by default
+ if {![info exists outputChannel]} {
+ variable outputChannel stdout
+ }
+
+ # errors go to stderr by default
+ if {![info exists errorChannel]} {
+ variable errorChannel stderr
+ }
+
+ # debug output doesn't get printed by default; debug level 1 spits
+ # up only the tests that were skipped because they didn't match or were
+ # specifically skipped. A debug level of 2 would spit up the tcltest
+ # variables and flags provided; a debug level of 3 causes some additional
+ # output regarding operations of the test harness. The tcltest package
+ # currently implements only up to debug level 3.
+ if {![info exists debug]} {
+ variable debug 0
+ }
+
+ # Save any arguments that we might want to pass through to other programs.
+ # This is used by the -args flag.
+ if {![info exists parameters]} {
+ variable parameters {}
+ }
+
+ # 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.
+
+ if {![info exists numTestFiles]} {
+ variable numTestFiles 0
+ }
+ if {![info exists testSingleFile]} {
+ variable testSingleFile true
+ }
+ if {![info exists currentFailure]} {
+ variable currentFailure false
+ }
+ if {![info exists failFiles]} {
+ 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.
+
+ if {![info exists filesMade]} {
+ variable filesMade {}
+ }
+ if {![info exists filesExisted]} {
+ 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.
+
+ if {![info exists createdNewFiles]} {
+ variable createdNewFiles
+ array set ::tcltest::createdNewFiles {}
+ }
+
+ # initialize ::tcltest::numTests array to keep track fo the number of
+ # tests that pass, fail, and are skipped.
+
+ if {![info exists numTests]} {
+ variable numTests
+ 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.
+
+ if {![info exists skippedBecause]} {
+ variable skippedBecause
+ 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).
+
+ if {![info exists testConstraints]} {
+ variable testConstraints
+ array set ::tcltest::testConstraints {}
+ }
+
+ # Don't run only the constrained tests by default
+
+ if {![info exists limitConstraints]} {
+ variable limitConstraints false
+ }
+
+ # A test application has to know how to load the tested commands into
+ # the interpreter.
+
+ if {![info exists loadScript]} {
+ variable loadScript {}
+ }
+
+ # tests that use threads need to know which is the main thread
+
+ if {![info exists mainThread]} {
+ variable mainThread 1
+ if {[info commands thread::id] != {}} {
+ set mainThread [thread::id]
+ } elseif {[info commands testthread] != {}} {
+ set mainThread [testthread id]
+ }
+ }
+
+ # save the original environment so that it can be restored later
+
+ if {![info exists originalEnv]} {
+ variable originalEnv
+ array set ::tcltest::originalEnv [array get ::env]
+ }
+
+ # Set ::tcltest::workingDirectory to [pwd]. The default output directory
+ # for Tcl tests is the working directory.
+
+ if {![info exists workingDirectory]} {
+ variable workingDirectory [pwd]
+ }
+ if {![info exists temporaryDirectory]} {
+ 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.
+
+ if {![info exists testsDirectory]} {
+ set oldpwd [pwd]
+ catch {cd [file join [file dirname [info script]] .. .. tests]}
+ variable testsDirectory [pwd]
+ cd $oldpwd
+ unset oldpwd
+ }
+
+ # the variables and procs that existed when ::tcltest::saveState was
+ # called are stored in a variable of the same name
+ if {![info exists saveState]} {
+ variable saveState {}
+ }
+
+ # Internationalization support
+ if {![info exists 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
+ if {![info exists tcltest]} {
+ variable tcltest [info nameofexecutable]
+ }
+
+ # save the platform information so it can be restored later
+ if {![info exists originalTclPlatform]} {
+ variable originalTclPlatform [array get tcl_platform]
+ }
+
+ # If a core file exists, save its modification time.
+ if {![info exists coreModificationTime]} {
+ if {[file exists [file join $::tcltest::workingDirectory core]]} {
+ variable coreModificationTime [file mtime [file join \
+ $::tcltest::workingDirectory core]]
+ }
+ }
+
+ # Tcl version numbers
+ if {![info exists version]} {
+ variable version 8.3
+ }
+ if {![info exists patchLevel]} {
+ variable patchLevel 8.3.0
+ }
+}
+
+# ::tcltest::Debug* --
+#
+# Internal helper procedures to write out debug information
+# dependent on the chosen level. A test shell may overide
+# them, f.e. to redirect the output into a different
+# channel, or even into a GUI.
+
+# ::tcltest::DebugPuts --
+#
+# Prints the specified string if the current debug level is
+# higher than the provided level argument.
+#
+# Arguments:
+# level The lowest debug level triggering the output
+# string The string to print out.
+#
+# Results:
+# Prints the string. Nothing else is allowed.
+#
+
+proc ::tcltest::DebugPuts {level string} {
+ variable debug
+ if {$debug >= $level} {
+ puts $string
+ }
+}
+
+# ::tcltest::DebugPArray --
+#
+# Prints the contents of the specified array if the current
+# debug level is higher than the provided level argument
+#
+# Arguments:
+# level The lowest debug level triggering the output
+# arrayvar The name of the array to print out.
+#
+# Results:
+# Prints the contents of the array. Nothing else is allowed.
+#
+
+proc ::tcltest::DebugPArray {level arrayvar} {
+ variable debug
+
+ if {$debug >= $level} {
+ catch {upvar $arrayvar $arrayvar}
+ parray $arrayvar
+ }
+}
+
+# ::tcltest::DebugDo --
+#
+# Executes the script if the current debug level is greater than
+# the provided level argument
+#
+# Arguments:
+# level The lowest debug level triggering the execution.
+# script The tcl script executed upon a debug level high enough.
+#
+# Results:
+# Arbitrary side effects, dependent on the executed script.
+#
+
+proc ::tcltest::DebugDo {level script} {
+ variable debug
+
+ if {$debug >= $level} {
+ uplevel $script
+ }
+}
+
+# ::tcltest::AddToSkippedBecause --
+#
+# Increments the variable used to track how many tests were skipped
+# because of a particular constraint.
+#
+# Arguments:
+# constraint The name of the constraint to be modified
+#
+# Results:
+# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't
+# previously exist - otherwise, it just increments it.
+
+proc ::tcltest::AddToSkippedBecause { constraint } {
+ # add the constraint to the list of constraints that 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, making sure that all messages are < 80 characters per line.
+#
+# 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
+
+ # Keep track of where the end of the string is.
+ set endingIndex [string length $errorMsg]
+
+ if {$endingIndex < 80} {
+ puts $::tcltest::errorChannel $errorMsg
+ } else {
+ # Print up to 80 characters on the first line, including the
+ # InitialMessage.
+ set beginningIndex [string last " " [string range $errorMsg 0 \
+ [expr {80 - $InitialMsgLen}]]]
+ puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]
+
+ while {$beginningIndex != "end"} {
+ puts -nonewline $::tcltest::errorChannel \
+ [string repeat " " $InitialMsgLen]
+ if {[expr {$endingIndex - $beginningIndex}] < 72} {
+ puts $::tcltest::errorChannel [string trim \
+ [string range $errorMsg $beginningIndex end]]
+ set beginningIndex end
+ } else {
+ set newEndingIndex [expr [string last " " [string range \
+ $errorMsg $beginningIndex \
+ [expr {$beginningIndex + 72}]]] + $beginningIndex]
+ if {($newEndingIndex <= 0) \
+ || ($newEndingIndex <= $beginningIndex)} {
+ set newEndingIndex end
+ }
+ puts $::tcltest::errorChannel [string trim \
+ [string range $errorMsg \
+ $beginningIndex $newEndingIndex]]
+ set beginningIndex $newEndingIndex
+ }
+ }
+ }
+ flush $::tcltest::errorChannel
+ return
+}
+
+if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} {
+ 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 tcltest man page 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
+
+ # 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(98) [string equal $tcl_platform(os) \
+ "Windows 98"]
+
+ # The following Constraints switches are used to mark tests that should
+ # work, but have been temporarily disabled on certain platforms because
+ # they don't and we haven't gotten around to fixing the underlying
+ # problem.
+
+ 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(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
+
+ if {[info exists tcl_interactive]} {
+ set ::tcltest::testConstraints(interactive) $::tcl_interactive
+ } else {
+ set ::tcltest::testConstraints(interactive) 0
+ }
+
+ # 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 equal "[format %g 5e-5]" "5e-05"]} {
+ 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
+ }
+}
+
+# ::tcltest::PrintUsageInfoHook
+#
+# Hook used for customization of display of usage information.
+#
+
+if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} {
+ proc ::tcltest::PrintUsageInfoHook {} {}
+}
+
+# ::tcltest::PrintUsageInfo
+#
+# Prints out the usage information for package tcltest. This can be
+# customized with the redefinition of ::tcltest::PrintUsageInfoHook.
+#
+# Arguments:
+# none
+#
+
+proc ::tcltest::PrintUsageInfo {} {
+ puts [format "Usage: [file tail [info nameofexecutable]] \
+ script ?-help? ?flag value? ... \n\
+ Available flags (and valid input values) are: \n\
+ -help \t Display this usage information. \n\
+ -verbose level \t Takes any combination of the values \n\
+ \t 'p', 's' and 'b'. Test suite will \n\
+ \t display all passed tests if 'p' is \n\
+ \t specified, all skipped tests if 's' \n\
+ \t is specified, and the bodies of \n\
+ \t failed tests if 'b' is specified. \n\
+ \t The default value is 'b'. \n\
+ -constraints list\t Do not skip the listed constraints\n\
+ -limitconstraints bool\t Only run tests with the constraints\n\
+ \t listed in -constraints.\n\
+ -match pattern \t Run all tests within the specified \n\
+ \t files that match the glob pattern \n\
+ \t given. \n\
+ -skip pattern \t Skip all tests within the set of \n\
+ \t specified tests (via -match) and \n\
+ \t files that match the glob pattern \n\
+ \t given. \n\
+ -file pattern \t Run tests in all test files that \n\
+ \t match the glob pattern given. \n\
+ -notfile pattern\t Skip all test files that match the \n\
+ \t glob pattern given. \n\
+ -preservecore level \t If 2, save any core files produced \n\
+ \t during testing in the directory \n\
+ \t specified by -tmpdir. If 1, notify the\n\
+ \t user if core files are created. The default \n\
+ \t is $::tcltest::preserveCore. \n\
+ -tmpdir directory\t Save temporary files in the specified\n\
+ \t directory. The default value is \n\
+ \t $::tcltest::temporaryDirectory. \n\
+ -testdir directories\t Search tests in the specified\n\
+ \t directories. The default value is \n\
+ \t $::tcltest::testsDirectory. \n\
+ -outfile file \t Send output from test runs to the \n\
+ \t specified file. The default is \n\
+ \t stdout. \n\
+ -errfile file \t Send errors from test runs to the \n\
+ \t specified file. The default is \n\
+ \t stderr. \n\
+ -loadfile file \t Read the script to load the tested \n\
+ \t commands from the specified file. \n\
+ -load script \t Specifies the script to load the tested \n\
+ \t commands. \n\
+ -debug level \t Internal debug flag."]
+ ::tcltest::PrintUsageInfoHook
+ return
+}
+
+# ::tcltest::CheckDirectory --
+#
+# This procedure checks whether the specified path is a readable
+# and/or writable directory. If one of the conditions is not
+# satisfied an error is printed and the application aborted. The
+# procedure assumes that the caller already checked the existence
+# of the path.
+#
+# Arguments
+# rw Information what attributes to check. Allowed values:
+# r, w, rw, wr. If 'r' is part of the value the directory
+# must be readable. 'w' associates to 'writable'.
+# dir The directory to check.
+# errMsg The string to prepend to the actual error message before
+# printing it.
+#
+# Results
+# none
+#
+
+proc ::tcltest::CheckDirectory {rw dir errMsg} {
+ # Allowed values for 'rw': r, w, rw, wr
+
+ if {![file isdir $dir]} {
+ ::tcltest::PrintError "$errMsg \"$dir\" is not a directory"
+ exit 1
+ } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
+ ::tcltest::PrintError "$errMsg \"$dir\" is not writeable"
+ exit 1
+ } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
+ ::tcltest::PrintError "$errMsg \"$dir\" is not readable"
+ exit 1
+ }
+}
+
+# ::tcltest::normalizePath --
+#
+# This procedure resolves any symlinks in the path thus creating a
+# path without internal redirection. It assumes that the incoming
+# path is absolute.
+#
+# Arguments
+# pathVar contains the name of the variable containing the path to modify.
+#
+# Results
+# The path is modified in place.
+#
+
+proc ::tcltest::normalizePath {pathVar} {
+ upvar $pathVar path
+
+ set oldpwd [pwd]
+ catch {cd $path}
+ set path [pwd]
+ cd $oldpwd
+}
+
+# ::tcltest::MakeAbsolutePath --
+#
+# This procedure checks whether the incoming path is absolute or not.
+# Makes it absolute if it was not.
+#
+# Arguments
+# pathVar contains the name of the variable containing the path to modify.
+# prefix is optional, contains the path to use to make the other an
+# absolute one. The current working directory is used if it was
+# not specified.
+#
+# Results
+# The path is modified in place.
+#
+
+proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
+ upvar $pathVar path
+
+ if {![string equal [file pathtype $path] "absolute"]} {
+ if {$prefix == {}} {
+ set prefix [pwd]
+ }
+
+ set path [file join $prefix $path]
+ }
+}
+
+# ::tcltest::processCmdLineArgsFlagsHook --
+#
+# This hook is used to add to the list of command line arguments that are
+# processed by ::tcltest::processCmdLineArgs.
+#
+
+if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
+ proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
+}
+
+# ::tcltest::processCmdLineArgsHook --
+#
+# This hook is used to actually process the flags added by
+# ::tcltest::processCmdLineArgsAddFlagsHook.
+#
+# Arguments:
+# flags The flags that have been pulled out of argv
+#
+
+if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} {
+ 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] < 1)} {
+ set flagArray {}
+ } else {
+ set flagArray $argv
+ }
+
+ # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
+ # Note that -verbose cannot be abbreviated to -v in wish because it
+ # conflicts with the wish option -visual.
+
+ # Process -help first
+ if {([lsearch -exact $flagArray {-help}] != -1) || \
+ ([lsearch -exact $flagArray {-h}] != -1)} {
+ ::tcltest::PrintUsageInfo
+ exit 1
+ }
+
+ if {[catch {array set flag $flagArray}]} {
+ ::tcltest::PrintError "odd number of arguments specified on command line: \
+ $argv"
+ ::tcltest::PrintUsageInfo
+ exit 1
+ }
+
+ # -help is not listed since it has already been processed
+ lappend defaultFlags -verbose -match -skip -constraints \
+ -outfile -errfile -debug -tmpdir -file -notfile \
+ -preservecore -limitconstraints -args -testdir \
+ -load -loadfile
+ set defaultFlags [concat $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::parameters to the arg of the -args flag, if given
+ if {[info exists flag(-args)]} {
+ set ::tcltest::parameters $flag(-args)
+ }
+
+ # 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)
+ }
+
+ # Handle the -file and -notfile flags
+ if {[info exists flag(-file)]} {
+ set ::tcltest::matchFiles $flag(-file)
+ }
+ if {[info exists flag(-notfile)]} {
+ set ::tcltest::skipFiles $flag(-notfile)
+ }
+
+ # Use the -constraints flag, if given, to turn on constraints that are
+ # turned off by default: userInteractive knownBug nonPortable. This
+ # code fragment must be run after constraints are initialized.
+
+ if {[info exists flag(-constraints)]} {
+ foreach elt $flag(-constraints) {
+ set ::tcltest::testConstraints($elt) 1
+ }
+ }
+
+ # Use the -limitconstraints flag, if given, to tell the harness to limit
+ # tests run to those that were specified using the -constraints flag. If
+ # the -constraints flag was not specified, print out an error and exit.
+ if {[info exists flag(-limitconstraints)]} {
+ if {![info exists flag(-constraints)]} {
+ puts "You can only use the -limitconstraints flag with \
+ -constraints"
+ exit 1
+ }
+ set ::tcltest::limitConstraints $flag(-limitconstraints)
+ foreach elt [array names ::tcltest::testConstraints] {
+ if {[lsearch -exact $flag(-constraints) $elt] == -1} {
+ set ::tcltest::testConstraints($elt) 0
+ }
+ }
+ }
+
+ # 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)
+
+ MakeAbsolutePath ::tcltest::temporaryDirectory
+ set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
+ }
+ if {[file exists $::tcltest::temporaryDirectory]} {
+ ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError
+ } else {
+ file mkdir $::tcltest::temporaryDirectory
+ }
+
+ normalizePath ::tcltest::temporaryDirectory
+
+ # Set the ::tcltest::testsDirectory to the arg of -testdir, 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 return an error.
+
+ set testDirError ""
+ if {[info exists flag(-testdir)]} {
+ set ::tcltest::testsDirectory $flag(-testdir)
+
+ MakeAbsolutePath ::tcltest::testsDirectory
+ set testDirError "bad argument \"$flag(-testdir)\" to -testdir: "
+ }
+ if {[file exists $::tcltest::testsDirectory]} {
+ ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError
+ } else {
+ ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \
+ does not exist"
+ exit 1
+ }
+
+ normalizePath ::tcltest::testsDirectory
+
+ # 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]
+ }
+
+ # If an alternate error or output files are specified, change the
+ # default channels.
+
+ if {[info exists flag(-outfile)]} {
+ set tmp $flag(-outfile)
+ MakeAbsolutePath tmp $::tcltest::temporaryDirectory
+ set ::tcltest::outputChannel [open $tmp w]
+ }
+
+ if {[info exists flag(-errfile)]} {
+ set tmp $flag(-errfile)
+ MakeAbsolutePath tmp $::tcltest::temporaryDirectory
+ set ::tcltest::errorChannel [open $tmp w]
+ }
+
+ # If a load script was specified, either directly or through
+ # a file, remember it for later usage.
+
+ if {[info exists flag(-load)] && \
+ ([lsearch -exact $flagArray -load] > \
+ [lsearch -exact $flagArray -loadfile])} {
+ set ::tcltest::loadScript $flag(-load)
+ }
+
+ if {[info exists flag(-loadfile)] && \
+ ([lsearch -exact $flagArray -loadfile] > \
+ [lsearch -exact $flagArray -load]) } {
+ set tmp $flag(-loadfile)
+ MakeAbsolutePath tmp $::tcltest::temporaryDirectory
+ set tmp [open $tmp r]
+ set ::tcltest::loadScript [read $tmp]
+ close $tmp
+ }
+
+ # If the user specifies debug testing, print out extra information during
+ # the run.
+ if {[info exists flag(-debug)]} {
+ set ::tcltest::debug $flag(-debug)
+ }
+
+ # Handle -preservecore
+ if {[info exists flag(-preservecore)]} {
+ set ::tcltest::preserveCore $flag(-preservecore)
+ }
+
+ # Call the hook
+ ::tcltest::processCmdLineArgsHook [array get flag]
+
+ # Spit out everything you know if we're at a debug level 2 or greater
+
+ DebugPuts 2 "Flags passed into tcltest:"
+ DebugPArray 2 flag
+ DebugPuts 2 "::tcltest::debug = $::tcltest::debug"
+ DebugPuts 2 "::tcltest::testsDirectory = $::tcltest::testsDirectory"
+ DebugPuts 2 "::tcltest::workingDirectory = $::tcltest::workingDirectory"
+ DebugPuts 2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
+ DebugPuts 2 "::tcltest::outputChannel = $::tcltest::outputChannel"
+ DebugPuts 2 "::tcltest::errorChannel = $::tcltest::errorChannel"
+ DebugPuts 2 "Original environment (::tcltest::originalEnv):"
+ DebugPArray 2 ::tcltest::originalEnv
+ DebugPuts 2 "Constraints:"
+ DebugPArray 2 ::tcltest::testConstraints
+}
+
+# ::tcltest::loadTestedCommands --
+#
+# Uses the specified script to load the commands to test. Allowed to
+# be empty, as the tested commands could have been compiled into the
+# interpreter.
+#
+# Arguments
+# none
+#
+# Results
+# none
+
+proc ::tcltest::loadTestedCommands {} {
+ if {$::tcltest::loadScript == {}} {
+ return
+ }
+
+ uplevel #0 $::tcltest::loadScript
+}
+
+# ::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 $::tcltest::outputChannel \
+ "\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] && ![info exists tcl_interactive]} {
+ exit
+ }
+ } else {
+
+ # if we're deferring stat-reporting until all files are sourced,
+ # then add current file to failFile list if any tests in this file
+ # failed
+
+ incr ::tcltest::numTestFiles
+ if {($::tcltest::currentFailure) && \
+ ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} {
+ lappend ::tcltest::failFiles $testFileName
+ }
+ set ::tcltest::currentFailure false
+
+ # restore the environment to the state it was in before this package
+ # was loaded
+
+ set newEnv {}
+ set changedEnv {}
+ set removedEnv {}
+ foreach index [array names ::env] {
+ if {![info exists ::tcltest::originalEnv($index)]} {
+ lappend newEnv $index
+ unset ::env($index)
+ } else {
+ if {$::env($index) != $::tcltest::originalEnv($index)} {
+ lappend changedEnv $index
+ set ::env($index) $::tcltest::originalEnv($index)
+ }
+ }
+ }
+ foreach index [array names ::tcltest::originalEnv] {
+ if {![info exists ::env($index)]} {
+ lappend removedEnv $index
+ set ::env($index) $::tcltest::originalEnv($index)
+ }
+ }
+ if {[llength $newEnv] > 0} {
+ puts $::tcltest::outputChannel \
+ "env array elements created:\t$newEnv"
+ }
+ if {[llength $changedEnv] > 0} {
+ puts $::tcltest::outputChannel \
+ "env array elements changed:\t$changedEnv"
+ }
+ if {[llength $removedEnv] > 0} {
+ puts $::tcltest::outputChannel \
+ "env array elements removed:\t$removedEnv"
+ }
+
+ set changedTclPlatform {}
+ foreach index [array names ::tcltest::originalTclPlatform] {
+ if {$::tcl_platform($index) != \
+ $::tcltest::originalTclPlatform($index)} {
+ lappend changedTclPlatform $index
+ set ::tcl_platform($index) \
+ $::tcltest::originalTclPlatform($index)
+ }
+ }
+ if {[llength $changedTclPlatform] > 0} {
+ puts $::tcltest::outputChannel \
+ "tcl_platform array elements changed:\t$changedTclPlatform"
+ }
+
+ if {[file exists [file join $::tcltest::workingDirectory core]]} {
+ if {$::tcltest::preserveCore > 1} {
+ puts $::tcltest::outputChannel "produced core file! \
+ Moving file to: \
+ [file join $::tcltest::temporaryDirectory core-$name]"
+ flush $::tcltest::outputChannel
+ catch {file rename -force \
+ [file join $::tcltest::workingDirectory core] \
+ [file join $::tcltest::temporaryDirectory \
+ core-$name]} msg
+ if {[string length $msg] > 0} {
+ ::tcltest::PrintError "Problem renaming file: $msg"
+ }
+ } else {
+ # Print a message if there is a core file and (1) there
+ # previously wasn't one or (2) the new one is different from
+ # the old one.
+
+ if {[info exists ::tcltest::coreModificationTime]} {
+ if {$::tcltest::coreModificationTime != [file mtime \
+ [file join $::tcltest::workingDirectory core]]} {
+ puts $::tcltest::outputChannel "A core file was created!"
+ }
+ } else {
+ puts $::tcltest::outputChannel "A core file was created!"
+ }
+ }
+ }
+ }
+}
+
+# ::tcltest::cleanupTestsHook --
+#
+# This hook allows a harness that builds upon tcltest to specify
+# additional things that should be done at cleanup.
+#
+
+if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
+ 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} {
+
+ DebugPuts 3 "Running $name ($description)"
+
+ 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)
+ DebugDo 1 {::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)
+ DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
+ return
+ }
+ }
+
+ set i [llength $args]
+ if {$i == 0} {
+ set constraints {}
+ # If we're limited to the listed constraints and there aren't any
+ # listed, then we shouldn't run the test.
+ if {$::tcltest::limitConstraints} {
+ ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint
+ incr ::tcltest::numTests(Skipped)
+ return
+ }
+ } elseif {$i == 1} {
+
+ # "constraints" argument exists; shuffle arguments down, then
+ # make sure that the constraints are satisfied.
+
+ set constraints $script
+ set script $expectedAnswer
+ set expectedAnswer [lindex $args 0]
+ set doTest 0
+ if {[string match {*[$\[]*} $constraints] != 0} {
+ # full expression, e.g. {$foo > [info tclversion]}
+ catch {set doTest [uplevel #0 expr $constraints]}
+ } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
+ # something like {a || b} should be turned into
+ # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b).
+ regsub -all {[.\w]+} $constraints \
+ {$::tcltest::testConstraints(&)} c
+ catch {set doTest [eval expr $c]}
+ } else {
+ # just simple constraints such as {unixOnly fonts}.
+ set doTest 1
+ foreach constraint $constraints {
+ if {(![info exists ::tcltest::testConstraints($constraint)]) \
+ || (!$::tcltest::testConstraints($constraint))} {
+ set doTest 0
+
+ # store the constraint that kept the test from running
+ set constraints $constraint
+ break
+ }
+ }
+ }
+ if {$doTest == 0} {
+ if {[string first s $::tcltest::verbose] != -1} {
+ puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
+ }
+
+ incr ::tcltest::numTests(Skipped)
+ ::tcltest::AddToSkippedBecause $constraints
+ return
+ }
+ } else {
+ error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
+ }
+
+ # Save information about the core file. You need to restore the original
+ # tcl_platform environment because some of the tests mess with tcl_platform.
+
+ if {$::tcltest::preserveCore} {
+ set currentTclPlatform [array get tcl_platform]
+ array set tcl_platform $::tcltest::originalTclPlatform
+ if {[file exists [file join $::tcltest::workingDirectory core]]} {
+ set coreModTime [file mtime [file join \
+ $::tcltest::workingDirectory core]]
+ }
+ array set tcl_platform $currentTclPlatform
+ }
+
+ # If there is no "memory" command (because memory debugging isn't
+ # enabled), then don't attempt to use the command.
+
+ if {[info commands memory] != {}} {
+ memory tag $name
+ }
+
+ set code [catch {uplevel $script} actualAnswer]
+ if {([string equal $actualAnswer $expectedAnswer]) && ($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"
+ }
+ if {$::tcltest::preserveCore} {
+ set currentTclPlatform [array get tcl_platform]
+ if {[file exists [file join $::tcltest::workingDirectory core]]} {
+ if {$::tcltest::preserveCore > 1} {
+ puts $::tcltest::outputChannel "==== $name produced core file! \
+ Moving file to: \
+ [file join $::tcltest::temporaryDirectory core-$name]"
+ catch {file rename -force \
+ [file join $::tcltest::workingDirectory core] \
+ [file join $::tcltest::temporaryDirectory \
+ core-$name]} msg
+ if {[string length $msg] > 0} {
+ ::tcltest::PrintError "Problem renaming file: $msg"
+ }
+ } else {
+ # Print a message if there is a core file and (1) there
+ # previously wasn't one or (2) the new one is different from
+ # the old one.
+
+ if {[info exists coreModTime]} {
+ if {$coreModTime != [file mtime \
+ [file join $::tcltest::workingDirectory core]]} {
+ puts $::tcltest::outputChannel "==== $name produced core file!"
+ }
+ } else {
+ puts $::tcltest::outputChannel "==== $name produced core file!"
+ }
+ }
+ }
+ array set tcl_platform $currentTclPlatform
+ }
+}
+
+# ::tcltest::getMatchingFiles
+#
+# Looks at the patterns given to match and skip files
+# and uses them to put together a list of the tests that will be run.
+#
+# Arguments:
+# none
+#
+# Results:
+# The constructed list is returned to the user. This will primarily
+# be used in 'all.tcl' files.
+
+proc ::tcltest::getMatchingFiles {args} {
+ set matchingFiles {}
+ if {[llength $args]} {
+ set searchDirectory $args
+ } else {
+ set searchDirectory [list $::tcltest::testsDirectory]
+ }
+ # Find the matching files in the list of directories and then remove the
+ # ones that match the skip pattern
+ foreach directory $searchDirectory {
+ set matchFileList {}
+ foreach match $::tcltest::matchFiles {
+ set matchFileList [concat $matchFileList \
+ [glob -nocomplain [file join $directory $match]]]
+ }
+ if {[string compare {} $::tcltest::skipFiles]} {
+ set skipFileList {}
+ foreach skip $::tcltest::skipFiles {
+ set skipFileList [concat $skipFileList \
+ [glob -nocomplain [file join $directory $skip]]]
+ }
+ foreach file $matchFileList {
+ # Only include files that don't match the skip pattern and
+ # aren't SCCS lock files.
+ if {([lsearch -exact $skipFileList $file] == -1) && \
+ (![string match l.*.test [file tail $file]])} {
+ lappend matchingFiles $file
+ }
+ }
+ } else {
+ set matchingFiles [concat $matchingFiles $matchFileList]
+ }
+ }
+ if {[string equal $matchingFiles {}]} {
+ ::tcltest::PrintError "No test files remain after applying \
+ your match and skip patterns!"
+ }
+ return $matchingFiles
+}
+
+# The following two procs are used in the io tests.
+
+proc ::tcltest::openfiles {} {
+ if {[catch {testchannel open} result]} {
+ return {}
+ }
+ return $result
+}
+
+proc ::tcltest::leakfiles {old} {
+ if {[catch {testchannel open} new]} {
+ return {}
+ }
+ set leak {}
+ foreach p $new {
+ if {[lsearch $old $p] < 0} {
+ lappend leak $p
+ }
+ }
+ return $leak
+}
+
+# ::tcltest::saveState --
+#
+# Save information regarding what procs and variables exist.
+#
+# Arguments:
+# none
+#
+# Results:
+# Modifies the variable ::tcltest::saveState
+
+proc ::tcltest::saveState {} {
+ uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
+ DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState"
+}
+
+# ::tcltest::restoreState --
+#
+# Remove procs and variables that didn't exist before the call to
+# ::tcltest::saveState.
+#
+# Arguments:
+# none
+#
+# Results:
+# Removes procs and variables from your environment if they don't exist
+# in the ::tcltest::saveState variable.
+
+proc ::tcltest::restoreState {} {
+ foreach p [info procs] {
+ if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
+ (![string equal ::tcltest::$p [namespace origin $p]])} {
+
+ DebugPuts 3 "::tcltest::restoreState: Removing proc $p"
+ rename $p {}
+ }
+ }
+ foreach p [uplevel #0 {info vars}] {
+ if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
+ DebugPuts 3 "::tcltest::restoreState: Removing variable $p"
+ uplevel #0 "catch {unset $p}"
+ }
+ }
+}
+
+# ::tcltest::normalizeMsg --
+#
+# Removes "extra" newlines from a string.
+#
+# Arguments:
+# msg String to be modified
+#
+
+proc ::tcltest::normalizeMsg {msg} {
+ regsub "\n$" [string tolower $msg] "" msg
+ regsub -all "\n\n" $msg "\n" msg
+ regsub -all "\n\}" $msg "\}" msg
+ return $msg
+}
+
+# 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
+
+ DebugPuts 3 "::tcltest::makeFile: putting $contents into $name"
+
+ set fullName [file join $::tcltest::temporaryDirectory $name]
+ set fd [open $fullName w]
+
+ fconfigure $fd -translation lf
+
+ if {[string equal [string index $contents end] "\n"]} {
+ puts -nonewline $fd $contents
+ } else {
+ puts $fd $contents
+ }
+ close $fd
+
+ if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
+ lappend ::tcltest::filesMade $fullName
+ }
+ return $fullName
+}
+
+# ::tcltest::removeFile --
+#
+# Removes the named file from the filesystem
+#
+# Arguments:
+# name file to be removed
+#
+
+proc ::tcltest::removeFile {name} {
+ DebugPuts 3 "::tcltest::removeFile: removing $name"
+ file delete [file join $::tcltest::temporaryDirectory $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
+ }
+}
+
+# ::tcltest::removeDirectory --
+#
+# Removes a named directory from the file system.
+#
+# Arguments:
+# name Name of the directory to remove
+#
+
+proc ::tcltest::removeDirectory {name} {
+ file delete -force $name
+}
+
+proc ::tcltest::viewFile {name} {
+ global tcl_platform
+ if {([string equal $tcl_platform(platform) "macintosh"]) || \
+ ($::tcltest::testConstraints(unixExecs) == 0)} {
+ set f [open [file join $::tcltest::temporaryDirectory $name]]
+ set data [read -nonewline $f]
+ close $f
+ return $data
+ } else {
+ exec cat [file join $::tcltest::temporaryDirectory $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 built into tcltest
+
+ testthread errorproc ThreadNullError
+ while {[llength [testthread names]] > 1} {
+ foreach tid [testthread names] {
+ if {$tid != $::tcltest::mainThread} {
+ catch {testthread send -async $tid {testthread exit}}
+ }
+ }
+ ## Enter a bit a sleep to give the threads enough breathing
+ ## room to kill themselves off, otherwise the end up with a
+ ## massive queue of repeated events
+ after 1
+ }
+ testthread errorproc ThreadError
+ return [llength [testthread names]]
+ } elseif {[info commands thread::id] != {}} {
+
+ # Thread extension
+
+ thread::errorproc ThreadNullError
+ while {[llength [thread::names]] > 1} {
+ foreach tid [thread::names] {
+ if {$tid != $::tcltest::mainThread} {
+ catch {thread::send -async $tid {thread::exit}}
+ }
+ }
+ ## Enter a bit a sleep to give the threads enough breathing
+ ## room to kill themselves off, otherwise the end up with a
+ ## massive queue of repeated events
+ after 1
+ }
+ thread::errorproc ThreadError
+ return [llength [thread::names]]
+ } else {
+ return 1
+ }
+}
+
+# Initialize the constraints and set up command line arguments
+namespace eval tcltest {
+ # Ensure that we have a minimal auto_path so we don't pick up extra junk.
+ set ::auto_path [list [info library]]
+
+ ::tcltest::initConstraints
+ if {[namespace children ::tcltest] == {}} {
+ ::tcltest::processCmdLineArgs
+ }
+}
+
View Lorry Controller Status