diff options
Diffstat (limited to 'library/tcltest1.0/tcltest.tcl')
| -rw-r--r-- | library/tcltest1.0/tcltest.tcl | 1237 |
1 files changed, 1237 insertions, 0 deletions
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 |