diff options
Diffstat (limited to 'library/tcltest/tcltest.tcl')
| -rw-r--r-- | library/tcltest/tcltest.tcl | 3893 |
1 files changed, 2845 insertions, 1048 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 039c560..4b94312 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1,419 +1,1266 @@ # 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 README file for more details. -# +# 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. +# initially implemented by Mary Ann May-Pumphrey of Sun +# Microsystems. # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2000 by Ajuba Solutions +# Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. -# -# RCS: @(#) $Id: tcltest.tcl,v 1.9 1999/07/30 01:35:27 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]] +package require Tcl 8.5 ;# -verbose line uses [info frame] +namespace eval tcltest { -# create the "tcltest" namespace for all testing variables and procedures + # When the version number changes, be sure to update the pkgIndex.tcl file, + # and the install directory in the Makefiles. When the minor version + # changes (new feature) be sure to update the man page as well. + variable Version 2.3.7 -namespace eval tcltest { + # Compatibility support for dumb variables defined in tcltest 1 + # Do not use these. Call [package provide Tcl] and [info patchlevel] + # yourself. You don't need tcltest to wrap it for you. + variable version [package provide Tcl] + variable patchLevel [info patchlevel] - # Export the public tcltest procs - set procList [list test cleanupTests saveState restoreState \ - normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile bytestring safeFetch threadReap getMatchingTestFiles] - foreach proc $procList { - namespace export $proc +##### Export the public tcltest procs; several categories + # + # Export the main functional commands that do useful things + namespace export cleanupTests loadTestedCommands makeDirectory \ + makeFile removeDirectory removeFile runAllTests test + + # Export configuration commands that control the functional commands + namespace export configure customMatch errorChannel interpreter \ + outputChannel testConstraint + + # Export commands that are duplication (candidates for deprecation) + namespace export bytestring ;# dups [encoding convertfrom identity] + namespace export debug ;# [configure -debug] + namespace export errorFile ;# [configure -errfile] + namespace export limitConstraints ;# [configure -limitconstraints] + namespace export loadFile ;# [configure -loadfile] + namespace export loadScript ;# [configure -load] + namespace export match ;# [configure -match] + namespace export matchFiles ;# [configure -file] + namespace export matchDirectories ;# [configure -relateddir] + namespace export normalizeMsg ;# application of [customMatch] + namespace export normalizePath ;# [file normalize] (8.4) + namespace export outputFile ;# [configure -outfile] + namespace export preserveCore ;# [configure -preservecore] + namespace export singleProcess ;# [configure -singleproc] + namespace export skip ;# [configure -skip] + namespace export skipFiles ;# [configure -notfile] + namespace export skipDirectories ;# [configure -asidefromdir] + namespace export temporaryDirectory ;# [configure -tmpdir] + namespace export testsDirectory ;# [configure -testdir] + namespace export verbose ;# [configure -verbose] + namespace export viewFile ;# binary encoding [read] + namespace export workingDirectory ;# [cd] [pwd] + + # Export deprecated commands for tcltest 1 compatibility + namespace export getMatchingFiles mainThread restoreState saveState \ + threadReap + + # 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 - name of variable containing path to modify. + # + # Results + # The path is modified in place. + # + # Side Effects: + # None. + # + proc normalizePath {pathVar} { + upvar 1 $pathVar path + set oldpwd [pwd] + catch {cd $path} + set path [pwd] + cd $oldpwd + return $path } - # ::tcltest::verbose defaults to "b" +##### Verification commands used to test values of variables and options + # + # Verification command that accepts everything + proc AcceptAll {value} { + return $value + } - variable verbose "b" + # Verification command that accepts valid Tcl lists + proc AcceptList { list } { + return [lrange $list 0 end] + } - # Match and skip patterns default to the empty list, except for - # matchFiles, which defaults to all .test files in the testsDirectory + # Verification command that accepts a glob pattern + proc AcceptPattern { pattern } { + return [AcceptAll $pattern] + } - variable match {} - variable skip {} + # Verification command that accepts integers + proc AcceptInteger { level } { + return [incr level 0] + } - variable matchFiles {*.test} - variable skipFiles {} + # Verification command that accepts boolean values + proc AcceptBoolean { boolean } { + return [expr {$boolean && $boolean}] + } - # By default, don't save core files - variable preserveCore 0 + # Verification command that accepts (syntactically) valid Tcl scripts + proc AcceptScript { script } { + if {![info complete $script]} { + return -code error "invalid Tcl script: $script" + } + return $script + } - # output goes to stdout by default + # Verification command that accepts (converts to) absolute pathnames + proc AcceptAbsolutePath { path } { + return [file join [pwd] $path] + } - variable outputChannel stdout + # Verification command that accepts existing readable directories + proc AcceptReadable { path } { + if {![file readable $path]} { + return -code error "\"$path\" is not readable" + } + return $path + } + proc AcceptDirectory { directory } { + set directory [AcceptAbsolutePath $directory] + if {![file exists $directory]} { + return -code error "\"$directory\" does not exist" + } + if {![file isdir $directory]} { + return -code error "\"$directory\" is not a directory" + } + return [AcceptReadable $directory] + } - # errors go to stderr by default +##### Initialize internal arrays of tcltest, but only if the caller + # has not already pre-initialized them. This is done to support + # compatibility with older tests that directly access internals + # rather than go through command interfaces. + # + proc ArrayDefault {varName value} { + variable $varName + if {[array exists $varName]} { + return + } + if {[info exists $varName]} { + # Pre-initialized value is a scalar: destroy it! + unset $varName + } + array set $varName $value + } - variable errorChannel stderr + # save the original environment so that it can be restored later + ArrayDefault originalEnv [array get ::env] + + # initialize numTests array to keep track of the number of tests + # that pass, fail, and are skipped. + ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0] + + # createdNewFiles will store test files as indices and the list of + # files (that should not have been) left behind by the test files + # as values. + ArrayDefault createdNewFiles {} + + # initialize 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. + ArrayDefault skippedBecause {} + + # initialize the testConstraints array to keep track of valid + # predefined constraints (see the explanation for the + # InitConstraints proc for more details). + ArrayDefault testConstraints {} - # debug output doesn't get printed by default; debug level 1 spits - # up only the tets 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. +##### Initialize internal variables of tcltest, but only if the caller + # has not already pre-initialized them. This is done to support + # compatibility with older tests that directly access internals + # rather than go through command interfaces. + # + proc Default {varName value {verify AcceptAll}} { + variable $varName + if {![info exists $varName]} { + variable $varName [$verify $value] + } else { + variable $varName [$verify [set $varName]] + } + } - variable debug 0 + # Save any arguments that we might want to pass through to other + # programs. This is used by the -args flag. + # FINDUSER + Default 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. + # Count the number of files tested (0 if runAllTests wasn't called). + # runAllTests will set testSingleFile to false, so stats will + # not be printed until runAllTests 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 {} + Default numTestFiles 0 AcceptInteger + Default testSingleFile true AcceptBoolean + Default currentFailure false AcceptBoolean + Default failFiles {} AcceptList # 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. + # filesMade keeps track of such files created using the makeFile and + # makeDirectory procedures. filesExisted stores the names of + # pre-existing files. + # + # Note that $filesExisted lists only those files that exist in + # the original [temporaryDirectory]. + Default filesMade {} AcceptList + Default filesExisted {} AcceptList + proc FillFilesExisted {} { + variable filesExisted - array set ::tcltest::numTests [list Total 0 Passed 0 Skipped 0 Failed 0] + # Save the names of files that already exist in the scratch directory. + foreach file [glob -nocomplain -directory [temporaryDirectory] *] { + lappend filesExisted [file tail $file] + } - # 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. + # After successful filling, turn this into a no-op. + proc FillFilesExisted args {} + } - array set ::tcltest::skippedBecause {} + # Kept only for compatibility + Default constraintsSpecified {} AcceptList + trace add variable constraintsSpecified read [namespace code { + set constraintsSpecified [array names testConstraints] ;#}] + + # tests that use threads need to know which is the main thread + Default mainThread 1 + variable mainThread + if {[info commands thread::id] ne {}} { + set mainThread [thread::id] + } elseif {[info commands testthread] ne {}} { + set mainThread [testthread id] + } - # initialize the ::tcltest::testConstraints array to keep track of valid - # predefined constraints (see the explanation for the - # ::tcltest::initConstraints proc for more details). + # Set workingDirectory to [pwd]. The default output directory for + # Tcl tests is the working directory. Whenever this value changes + # change to that directory. + variable workingDirectory + trace add variable workingDirectory write \ + [namespace code {cd $workingDirectory ;#}] - array set ::tcltest::testConstraints {} + Default workingDirectory [pwd] AcceptAbsolutePath + proc workingDirectory { {dir ""} } { + variable workingDirectory + if {[llength [info level 0]] == 1} { + return $workingDirectory + } + set workingDirectory [AcceptAbsolutePath $dir] + } - # Don't run only the constrained tests by default - variable limitConstraints false + # Set the location of the execuatble + Default tcltest [info nameofexecutable] + trace add variable tcltest write [namespace code {testConstraint stdio \ + [eval [ConstraintInitializer stdio]] ;#}] - # tests that use thread need to know which is the main thread + # save the platform information so it can be restored later + Default originalTclPlatform [array get ::tcl_platform] - variable mainThread 1 - if {[info commands testthread] != {}} { - set mainThread [testthread names] + # If a core file exists, save its modification time. + if {[file exists [file join [workingDirectory] core]]} { + Default coreModTime \ + [file mtime [file join [workingDirectory] core]] } - # save the original environment so that it can be restored later - - array set ::tcltest::originalEnv [array get ::env] + # stdout and stderr buffers for use when we want to store them + Default outData {} + Default errData {} - # Set ::tcltest::workingDirectory to [pwd]. The default output directory - # for Tcl tests is the working directory. + # keep track of test level for nested test commands + variable testLevel 0 - variable workingDirectory [pwd] - variable temporaryDirectory $workingDirectory + # the variables and procs that existed when saveState was called are + # stored in a variable of the same name + Default saveState {} - # Tests should not rely on the current working directory. - # Files that are part of the test suite should be accessed relative to - # ::tcltest::testsDirectory. - - set oDir [pwd] - catch {cd [file join [file dirname [info script]] .. .. tests]} - variable testsDirectory [pwd] - cd $oDir - - # the variables and procs that existed when ::tcltest::saveState was - # called are stored in a variable of the same name - variable saveState {} + # Internationalization support -- used in [SetIso8859_1_Locale] and + # [RestoreLocale]. Those commands are used in cmdIL.test. - # Internationalization support - if {![info exists ::tcltest::isoLocale]} { + if {![info exists [namespace current]::isoLocale]} { variable isoLocale fr - switch $tcl_platform(platform) { + switch -- $::tcl_platform(platform) { "unix" { # Try some 'known' values for some platforms: - switch -exact -- $tcl_platform(os) { + switch -exact -- $::tcl_platform(os) { "FreeBSD" { - set ::tcltest::isoLocale fr_FR.ISO_8859-1 + set isoLocale fr_FR.ISO_8859-1 } HP-UX { - set ::tcltest::isoLocale fr_FR.iso88591 + set isoLocale fr_FR.iso88591 } Linux - IRIX { - set ::tcltest::isoLocale fr + set 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. + # 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 + set isoLocale iso_8859_1 } } } "windows" { - set ::tcltest::isoLocale French + set isoLocale French } } } - # Set the location of the execuatble - variable tcltest [info nameofexecutable] + variable ChannelsWeOpened; array set ChannelsWeOpened {} + # output goes to stdout by default + Default outputChannel stdout + proc outputChannel { {filename ""} } { + variable outputChannel + variable ChannelsWeOpened + + # This is very subtle and tricky, so let me try to explain. + # (Hopefully this longer comment will be clear when I come + # back in a few months, unlike its predecessor :) ) + # + # The [outputChannel] command (and underlying variable) have to + # be kept in sync with the [configure -outfile] configuration + # option ( and underlying variable Option(-outfile) ). This is + # accomplished with a write trace on Option(-outfile) that will + # update [outputChannel] whenver a new value is written. That + # much is easy. + # + # The trick is that in order to maintain compatibility with + # version 1 of tcltest, we must allow every configuration option + # to get its inital value from command line arguments. This is + # accomplished by setting initial read traces on all the + # configuration options to parse the command line option the first + # time they are read. These traces are cancelled whenever the + # program itself calls [configure]. + # + # OK, then so to support tcltest 1 compatibility, it seems we want + # to get the return from [outputFile] to trigger the read traces, + # just in case. + # + # BUT! A little known feature of Tcl variable traces is that + # traces are disabled during the handling of other traces. So, + # if we trigger read traces on Option(-outfile) and that triggers + # command line parsing which turns around and sets an initial + # value for Option(-outfile) -- <whew!> -- the write trace that + # would keep [outputChannel] in sync with that new initial value + # would not fire! + # + # SO, finally, as a workaround, instead of triggering read traces + # by invoking [outputFile], we instead trigger the same set of + # read traces by invoking [debug]. Any command that reads a + # configuration option would do. [debug] is just a handy one. + # The end result is that we support tcltest 1 compatibility and + # keep outputChannel and -outfile in sync in all cases. + debug + + if {[llength [info level 0]] == 1} { + return $outputChannel + } + if {[info exists ChannelsWeOpened($outputChannel)]} { + close $outputChannel + unset ChannelsWeOpened($outputChannel) + } + switch -exact -- $filename { + stderr - + stdout { + set outputChannel $filename + } + default { + set outputChannel [open $filename a] + set ChannelsWeOpened($outputChannel) 1 + + # If we created the file in [temporaryDirectory], then + # [cleanupTests] will delete it, unless we claim it was + # already there. + set outdir [normalizePath [file dirname \ + [file join [pwd] $filename]]] + if {$outdir eq [temporaryDirectory]} { + variable filesExisted + FillFilesExisted + set filename [file tail $filename] + if {$filename ni $filesExisted} { + lappend filesExisted $filename + } + } + } + } + return $outputChannel + } - # save the platform information so it can be restored later - variable originalTclPlatform [array get tcl_platform] + # errors go to stderr by default + Default errorChannel stderr + proc errorChannel { {filename ""} } { + variable errorChannel + variable ChannelsWeOpened + + # This is subtle and tricky. See the comment above in + # [outputChannel] for a detailed explanation. + debug + + if {[llength [info level 0]] == 1} { + return $errorChannel + } + if {[info exists ChannelsWeOpened($errorChannel)]} { + close $errorChannel + unset ChannelsWeOpened($errorChannel) + } + switch -exact -- $filename { + stderr - + stdout { + set errorChannel $filename + } + default { + set errorChannel [open $filename a] + set ChannelsWeOpened($errorChannel) 1 + + # If we created the file in [temporaryDirectory], then + # [cleanupTests] will delete it, unless we claim it was + # already there. + set outdir [normalizePath [file dirname \ + [file join [pwd] $filename]]] + if {$outdir eq [temporaryDirectory]} { + variable filesExisted + FillFilesExisted + set filename [file tail $filename] + if {$filename ni $filesExisted} { + lappend filesExisted $filename + } + } + } + } + return $errorChannel + } +##### Set up the configurable options + # + # The configurable options of the package + variable Option; array set Option {} + + # Usage strings for those options + variable Usage; array set Usage {} + + # Verification commands for those options + variable Verify; array set Verify {} + + # Initialize the default values of the configurable options that are + # historically associated with an exported variable. If that variable + # is already set, support compatibility by accepting its pre-set value. + # Use [trace] to establish ongoing connection between the deprecated + # exported variable and the modern option kept as a true internal var. + # Also set up usage string and value testing for the option. + proc Option {option value usage {verify AcceptAll} {varName {}}} { + variable Option + variable Verify + variable Usage + variable OptionControlledVariables + variable DefaultValue + set Usage($option) $usage + set Verify($option) $verify + set DefaultValue($option) $value + if {[catch {$verify $value} msg]} { + return -code error $msg + } else { + set Option($option) $msg + } + if {[string length $varName]} { + variable $varName + if {[info exists $varName]} { + if {[catch {$verify [set $varName]} msg]} { + return -code error $msg + } else { + set Option($option) $msg + } + unset $varName + } + namespace eval [namespace current] \ + [list upvar 0 Option($option) $varName] + # Workaround for Bug (now Feature Request) 572889. Grrrr.... + # Track all the variables tied to options + lappend OptionControlledVariables $varName + # Later, set auto-configure read traces on all + # of them, since a single trace on Option does not work. + proc $varName {{value {}}} [subst -nocommands { + if {[llength [info level 0]] == 2} { + Configure $option [set value] + } + return [Configure $option] + }] + } + } - # If a core file exists, save its modification time. - if {[file exists [file join $::tcltest::workingDirectory core]]} { - variable coreModificationTime [file mtime [file join \ - $::tcltest::workingDirectory core]] + proc MatchingOption {option} { + variable Option + set match [array names Option $option*] + switch -- [llength $match] { + 0 { + set sorted [lsort [array names Option]] + set values [join [lrange $sorted 0 end-1] ", "] + append values ", or [lindex $sorted end]" + return -code error "unknown option $option: should be\ + one of $values" + } + 1 { + return [lindex $match 0] + } + default { + # Exact match trumps ambiguity + if {$option in $match} { + return $option + } + set values [join [lrange $match 0 end-1] ", "] + append values ", or [lindex $match end]" + return -code error "ambiguous option $option:\ + could match $values" + } + } + } + + proc EstablishAutoConfigureTraces {} { + variable OptionControlledVariables + foreach varName [concat $OptionControlledVariables Option] { + variable $varName + trace add variable $varName read [namespace code { + ProcessCmdLineArgs ;#}] + } + } + + proc RemoveAutoConfigureTraces {} { + variable OptionControlledVariables + foreach varName [concat $OptionControlledVariables Option] { + variable $varName + foreach pair [trace info variable $varName] { + lassign $pair op cmd + if {($op eq "read") && + [string match *ProcessCmdLineArgs* $cmd]} { + trace remove variable $varName $op $cmd + } + } + } + # Once the traces are removed, this can become a no-op + proc RemoveAutoConfigureTraces {} {} + } + + proc Configure args { + variable Option + variable Verify + set n [llength $args] + if {$n == 0} { + return [lsort [array names Option]] + } + if {$n == 1} { + if {[catch {MatchingOption [lindex $args 0]} option]} { + return -code error $option + } + return $Option($option) + } + while {[llength $args] > 1} { + if {[catch {MatchingOption [lindex $args 0]} option]} { + return -code error $option + } + if {[catch {$Verify($option) [lindex $args 1]} value]} { + return -code error "invalid $option\ + value \"[lindex $args 1]\": $value" + } + set Option($option) $value + set args [lrange $args 2 end] + } + if {[llength $args]} { + if {[catch {MatchingOption [lindex $args 0]} option]} { + return -code error $option + } + return -code error "missing value for option $option" + } + } + proc configure args { + if {[llength $args] > 1} { + RemoveAutoConfigureTraces + } + set code [catch {Configure {*}$args} msg] + return -code $code $msg + } + + proc AcceptVerbose { level } { + set level [AcceptList $level] + if {[llength $level] == 1} { + if {![regexp {^(pass|body|skip|start|error|line)$} $level]} { + # translate single characters abbreviations to expanded list + set level [string map {p pass b body s skip t start e error l line} \ + [split $level {}]] + } + } + set valid [list] + foreach v $level { + if {[regexp {^(pass|body|skip|start|error|line)$} $v]} { + lappend valid $v + } + } + return $valid + } + + proc IsVerbose {level} { + variable Option + return [expr {[lsearch -exact $Option(-verbose) $level] != -1}] + } + + # Default verbosity is to show bodies of failed tests + Option -verbose {body error} { + Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'. + Test suite will display all passed tests if 'p' is specified, all + skipped tests if 's' is specified, the bodies of failed tests if + 'b' is specified, and when tests start if 't' is specified. + ErrorInfo is displayed if 'e' is specified. Source file line + information of failed tests is displayed if 'l' is specified. + } AcceptVerbose verbose + + # Match and skip patterns default to the empty list, except for + # matchFiles, which defaults to all .test files in the + # testsDirectory and matchDirectories, which defaults to all + # directories. + Option -match * { + Run all tests within the specified files that match one of the + list of glob patterns given. + } AcceptList match + + Option -skip {} { + Skip all tests within the specified tests (via -match) and files + that match one of the list of glob patterns given. + } AcceptList skip + + Option -file *.test { + Run tests in all test files that match the glob pattern given. + } AcceptPattern matchFiles + + # By default, skip files that appear to be SCCS lock files. + Option -notfile l.*.test { + Skip all test files that match the glob pattern given. + } AcceptPattern skipFiles + + Option -relateddir * { + Run tests in directories that match the glob pattern given. + } AcceptPattern matchDirectories + + Option -asidefromdir {} { + Skip tests in directories that match the glob pattern given. + } AcceptPattern skipDirectories + + # By default, don't save core files + Option -preservecore 0 { + If 2, save any core files produced during testing in the directory + specified by -tmpdir. If 1, notify the user if core files are + created. + } AcceptInteger preserveCore + + # 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. + Option -debug 0 { + Internal debug level + } AcceptInteger debug + + proc SetSelectedConstraints args { + variable Option + foreach c $Option(-constraints) { + testConstraint $c 1 + } + } + Option -constraints {} { + Do not skip the listed constraints listed in -constraints. + } AcceptList + trace add variable Option(-constraints) write \ + [namespace code {SetSelectedConstraints ;#}] + + # Don't run only the "-constraint" specified tests by default + proc ClearUnselectedConstraints args { + variable Option + variable testConstraints + if {!$Option(-limitconstraints)} {return} + foreach c [array names testConstraints] { + if {$c ni $Option(-constraints)} { + testConstraint $c 0 + } + } + } + Option -limitconstraints 0 { + whether to run only tests with the constraints + } AcceptBoolean limitConstraints + trace add variable Option(-limitconstraints) write \ + [namespace code {ClearUnselectedConstraints ;#}] + + # A test application has to know how to load the tested commands + # into the interpreter. + Option -load {} { + Specifies the script to load the tested commands. + } AcceptScript loadScript + + # Default is to run each test file in a separate process + Option -singleproc 0 { + whether to run all tests in one process + } AcceptBoolean singleProcess + + proc AcceptTemporaryDirectory { directory } { + set directory [AcceptAbsolutePath $directory] + if {![file exists $directory]} { + file mkdir $directory + } + set directory [AcceptDirectory $directory] + if {![file writable $directory]} { + if {[workingDirectory] eq $directory} { + # Special exception: accept the default value + # even if the directory is not writable + return $directory + } + return -code error "\"$directory\" is not writeable" + } + return $directory + } + + # Directory where files should be created + Option -tmpdir [workingDirectory] { + Save temporary files in the specified directory. + } AcceptTemporaryDirectory temporaryDirectory + trace add variable Option(-tmpdir) write \ + [namespace code {normalizePath Option(-tmpdir) ;#}] + + # Tests should not rely on the current working directory. + # Files that are part of the test suite should be accessed relative + # to [testsDirectory] + Option -testdir [workingDirectory] { + Search tests in the specified directory. + } AcceptDirectory testsDirectory + trace add variable Option(-testdir) write \ + [namespace code {normalizePath Option(-testdir) ;#}] + + proc AcceptLoadFile { file } { + if {$file eq {}} {return $file} + set file [file join [temporaryDirectory] $file] + return [AcceptReadable $file] + } + proc ReadLoadScript {args} { + variable Option + if {$Option(-loadfile) eq {}} {return} + set tmp [open $Option(-loadfile) r] + loadScript [read $tmp] + close $tmp + } + Option -loadfile {} { + Read the script to load the tested commands from the specified file. + } AcceptLoadFile loadFile + trace add variable Option(-loadfile) write [namespace code ReadLoadScript] + + proc AcceptOutFile { file } { + if {[string equal stderr $file]} {return $file} + if {[string equal stdout $file]} {return $file} + return [file join [temporaryDirectory] $file] + } + + # output goes to stdout by default + Option -outfile stdout { + Send output from test runs to the specified file. + } AcceptOutFile outputFile + trace add variable Option(-outfile) write \ + [namespace code {outputChannel $Option(-outfile) ;#}] + + # errors go to stderr by default + Option -errfile stderr { + Send errors from test runs to the specified file. + } AcceptOutFile errorFile + trace add variable Option(-errfile) write \ + [namespace code {errorChannel $Option(-errfile) ;#}] + + proc loadIntoSlaveInterpreter {slave args} { + variable Version + interp eval $slave [package ifneeded tcltest $Version] + interp eval $slave "tcltest::configure {*}{$args}" + interp alias $slave ::tcltest::ReportToMaster \ + {} ::tcltest::ReportedFromSlave + } + proc ReportedFromSlave {total passed skipped failed because newfiles} { + variable numTests + variable skippedBecause + variable createdNewFiles + incr numTests(Total) $total + incr numTests(Passed) $passed + incr numTests(Skipped) $skipped + incr numTests(Failed) $failed + foreach {constraint count} $because { + incr skippedBecause($constraint) $count + } + foreach {testfile created} $newfiles { + lappend createdNewFiles($testfile) {*}$created + } + return + } +} + +##################################################################### + +# 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. +# +# Side Effects: +# None. +# + +proc tcltest::DebugPuts {level string} { + variable debug + if {$debug >= $level} { + puts $string + } + return +} + +# 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. +# +# Side Effects: +# None. +# + +proc tcltest::DebugPArray {level arrayvar} { + variable debug + + if {$debug >= $level} { + catch {upvar 1 $arrayvar $arrayvar} + parray $arrayvar + } + return +} + +# Define our own [parray] in ::tcltest that will inherit use of the [puts] +# defined in ::tcltest. NOTE: Ought to construct with [info args] and +# [info default], but can't be bothered now. If [parray] changes, then +# this will need changing too. +auto_load ::parray +proc tcltest::parray {a {pattern *}} [info body ::parray] + +# 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. +# +# Side Effects: +# None. +# + +proc tcltest::DebugDo {level script} { + variable debug + + if {$debug >= $level} { + uplevel 1 $script + } + return +} + +##################################################################### + +proc tcltest::Warn {msg} { + puts [outputChannel] "WARNING: $msg" +} + +# tcltest::mainThread +# +# Accessor command for tcltest variable mainThread. +# +proc tcltest::mainThread { {new ""} } { + variable mainThread + if {[llength [info level 0]] == 1} { + return $mainThread + } + set mainThread $new +} + +# tcltest::testConstraint -- +# +# sets a test constraint to a value; to do multiple constraints, +# call this proc multiple times. also returns the value of the +# named constraint if no value was supplied. +# +# Arguments: +# constraint - name of the constraint +# value - new value for constraint (should be boolean) - if not +# supplied, this is a query +# +# Results: +# content of tcltest::testConstraints($constraint) +# +# Side effects: +# none + +proc tcltest::testConstraint {constraint {value ""}} { + variable testConstraints + variable Option + DebugPuts 3 "entering testConstraint $constraint $value" + if {[llength [info level 0]] == 2} { + return $testConstraints($constraint) } + # Check for boolean values + if {[catch {expr {$value && $value}} msg]} { + return -code error $msg + } + if {[limitConstraints] && ($constraint ni $Option(-constraints))} { + set value 0 + } + set testConstraints($constraint) $value +} -} +# tcltest::interpreter -- +# +# the interpreter name stored in tcltest::tcltest +# +# Arguments: +# executable name +# +# Results: +# content of tcltest::tcltest +# +# Side effects: +# None. + +proc tcltest::interpreter { {interp ""} } { + variable tcltest + if {[llength [info level 0]] == 1} { + return $tcltest + } + set tcltest $interp +} -# ::tcltest::AddToSkippedBecause -- +##################################################################### + +# tcltest::AddToSkippedBecause -- # -# Increments the variable used to track how many tests were skipped -# because of a particular constraint. +# 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. +# Modifies tcltest::skippedBecause; sets the variable to 1 if +# didn't previously exist - otherwise, it just increments it. +# +# Side effects: +# None. -proc ::tcltest::AddToSkippedBecause { constraint } { - # add the constraint to the list of constraints the kept tests +proc tcltest::AddToSkippedBecause { constraint {value 1}} { + # add the constraint to the list of constraints that kept tests # from running + variable skippedBecause - if {[info exists ::tcltest::skippedBecause($constraint)]} { - incr ::tcltest::skippedBecause($constraint) + if {[info exists skippedBecause($constraint)]} { + incr skippedBecause($constraint) $value } else { - set ::tcltest::skippedBecause($constraint) 1 + set skippedBecause($constraint) $value } return } -# ::tcltest::PrintError -- +# tcltest::PrintError -- # -# Prints errors to ::tcltest::errorChannel and then flushes that -# channel, making sure that all messages are < 80 characters per line. +# 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 # +# Results: +# None. +# +# Side effects: +# None. -proc ::tcltest::PrintError {errorMsg} { +proc tcltest::PrintError {errorMsg} { set InitialMessage "Error: " set InitialMsgLen [string length $InitialMessage] - puts -nonewline $::tcltest::errorChannel $InitialMessage + puts -nonewline [errorChannel] $InitialMessage # Keep track of where the end of the string is. set endingIndex [string length $errorMsg] - if {$endingIndex < 80} { - puts $::tcltest::errorChannel $errorMsg + if {$endingIndex < (80 - $InitialMsgLen)} { + puts [errorChannel] $errorMsg } else { # Print up to 80 characters on the first line, including the - # InitialMessage. + # 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 \ + puts [errorChannel] [string range $errorMsg 0 $beginningIndex] + + while {$beginningIndex ne "end"} { + puts -nonewline [errorChannel] \ + [string repeat " " $InitialMsgLen] + if {($endingIndex - $beginningIndex) + < (80 - $InitialMsgLen)} { + puts [errorChannel] [string trim \ [string range $errorMsg $beginningIndex end]] - set beginningIndex end + break } else { - set newEndingIndex [expr [string last " " [string range \ - $errorMsg $beginningIndex \ - [expr {$beginningIndex + 72}]]] + $beginningIndex] - if {($newEndingIndex <= 0) \ + set newEndingIndex [expr {[string last " " \ + [string range $errorMsg $beginningIndex \ + [expr {$beginningIndex + + (80 - $InitialMsgLen)}] + ]] + $beginningIndex}] + if {($newEndingIndex <= 0) || ($newEndingIndex <= $beginningIndex)} { set newEndingIndex end } - puts $::tcltest::errorChannel [string trim \ + puts [errorChannel] [string trim \ [string range $errorMsg \ - $beginningIndex $newEndingIndex]] + $beginningIndex $newEndingIndex]] set beginningIndex $newEndingIndex } } } - flush $::tcltest::errorChannel + flush [errorChannel] return } -proc ::tcltest::initConstraintsHook {} {} +# tcltest::SafeFetch -- +# +# The following trace procedure makes it so that we can safely +# refer to non-existent members of the 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 +# testConstraints("X") is defined. +# +# Arguments: +# n1 - name of the array (testConstraints) +# n2 - array key value (constraint name) +# op - operation performed on testConstraints (generally r) +# +# Results: +# none +# +# Side effects: +# sets testConstraints($n2) to 0 if it's referenced but never +# before used -# ::tcltest::initConstraints -- +proc tcltest::SafeFetch {n1 n2 op} { + variable testConstraints + DebugPuts 3 "entering SafeFetch $n1 $n2 $op" + if {$n2 eq {}} {return} + if {![info exists testConstraints($n2)]} { + if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} { + testConstraint $n2 0 + } + } +} + +# tcltest::ConstraintInitializer -- # -# 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. +# Get or set a script that when evaluated in the tcltest namespace +# will return a boolean value with which to initialize the +# associated constraint. +# +# Arguments: +# constraint - name of the constraint initialized by the script +# script - the initializer script +# +# Results +# boolean value of the constraint - enabled or disabled +# +# Side effects: +# Constraint is initialized for future reference by [test] +proc tcltest::ConstraintInitializer {constraint {script ""}} { + variable ConstraintInitializer + DebugPuts 3 "entering ConstraintInitializer $constraint $script" + if {[llength [info level 0]] == 2} { + return $ConstraintInitializer($constraint) + } + # Check for boolean values + if {![info complete $script]} { + return -code error "ConstraintInitializer must be complete script" + } + set ConstraintInitializer($constraint) $script +} + +# tcltest::InitConstraints -- +# +# Call all registered constraint initializers to force initialization +# of all known constraints. +# 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 - - 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(98) [string equal $tcl_platform(os) \ - "Windows 98"] - 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)}] +# The testConstraints array is reset to have an index for each +# built-in test constraint. +# +# Side Effects: +# None. +# + +proc tcltest::InitConstraints {} { + variable ConstraintInitializer + initConstraintsHook + foreach constraint [array names ConstraintInitializer] { + testConstraint $constraint + } +} + +proc tcltest::DefineConstraintInitializers {} { + ConstraintInitializer singleTestInterp {singleProcess} + + # All the 'pc' constraints are here for backward compatibility and + # are not documented. They have been replaced with equivalent 'win' + # constraints. + + ConstraintInitializer unixOnly \ + {string equal $::tcl_platform(platform) unix} + ConstraintInitializer macOnly \ + {string equal $::tcl_platform(platform) macintosh} + ConstraintInitializer pcOnly \ + {string equal $::tcl_platform(platform) windows} + ConstraintInitializer winOnly \ + {string equal $::tcl_platform(platform) windows} + + ConstraintInitializer unix {testConstraint unixOnly} + ConstraintInitializer mac {testConstraint macOnly} + ConstraintInitializer pc {testConstraint pcOnly} + ConstraintInitializer win {testConstraint winOnly} + + ConstraintInitializer unixOrPc \ + {expr {[testConstraint unix] || [testConstraint pc]}} + ConstraintInitializer macOrPc \ + {expr {[testConstraint mac] || [testConstraint pc]}} + ConstraintInitializer unixOrWin \ + {expr {[testConstraint unix] || [testConstraint win]}} + ConstraintInitializer macOrWin \ + {expr {[testConstraint mac] || [testConstraint win]}} + ConstraintInitializer macOrUnix \ + {expr {[testConstraint mac] || [testConstraint unix]}} + + ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"} + ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"} + ConstraintInitializer 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. + + ConstraintInitializer tempNotPc {expr {![testConstraint pc]}} + ConstraintInitializer tempNotWin {expr {![testConstraint win]}} + ConstraintInitializer tempNotMac {expr {![testConstraint mac]}} + ConstraintInitializer tempNotUnix {expr {![testConstraint 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. + + ConstraintInitializer pcCrash {expr {![testConstraint pc]}} + ConstraintInitializer winCrash {expr {![testConstraint win]}} + ConstraintInitializer macCrash {expr {![testConstraint mac]}} + ConstraintInitializer unixCrash {expr {![testConstraint unix]}} # Skip empty tests - set ::tcltest::testConstraints(emptyTest) 0 + ConstraintInitializer emptyTest {format 0} # By default, tests that expose known bugs are skipped. - set ::tcltest::testConstraints(knownBug) 0 + ConstraintInitializer knownBug {format 0} # By default, non-portable tests are skipped. - set ::tcltest::testConstraints(nonPortable) 0 + ConstraintInitializer nonPortable {format 0} # Some tests require user interaction. - set ::tcltest::testConstraints(userInteraction) 0 + ConstraintInitializer userInteraction {format 0} - # Some tests must be skipped if the interpreter is not in interactive mode + # Some tests must be skipped if the interpreter is not in + # interactive mode - set ::tcltest::testConstraints(interactive) $tcl_interactive + ConstraintInitializer interactive \ + {expr {[info exists ::tcl_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. + # 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 - } - } + ConstraintInitializer root {expr \ + {($::tcl_platform(platform) eq "unix") && + ($::tcl_platform(user) in {root {}})}} + ConstraintInitializer notRoot {expr {![testConstraint root]}} # 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 + ConstraintInitializer nonBlockFiles { + set code [expr {[catch {set f [open defs r]}] + || [catch {chan configure $f -blocking off}]}] + catch {close $f} + set code } # Set asyncPipeClose constraint: 1 means this platform supports @@ -423,422 +1270,1063 @@ proc ::tcltest::initConstraints {} { # 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 - } + ConstraintInitializer asyncPipeClose {expr { + !([string equal unix $::tcl_platform(platform)] + && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}} # 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 - } + ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} - # Test to see if execed commands such as cat, echo, rm and so forth are - # present on this machine. + # 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 + ConstraintInitializer unixExecs { + set code 1 + if {$::tcl_platform(platform) eq "macintosh"} { + set code 0 + } + if {$::tcl_platform(platform) eq "windows"} { + if {[catch { + set file _tcl_test_remove_me.txt + makeFile {hello} $file + }]} { + set code 0 + } elseif { + [catch {exec cat $file}] || + [catch {exec echo hello}] || + [catch {exec sh -c echo hello}] || + [catch {exec wc $file}] || + [catch {exec sleep 1}] || + [catch {exec echo abc > $file}] || + [catch {exec chmod 644 $file}] || + [catch {exec rm $file}] || + [llength [auto_execok mkdir]] == 0 || + [llength [auto_execok fgrep]] == 0 || + [llength [auto_execok grep]] == 0 || + [llength [auto_execok ps]] == 0 + } { + set code 0 + } + removeFile $file + } + set code } - 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 + + ConstraintInitializer stdio { + set code 0 + if {![catch {set f [open "|[list [interpreter]]" w]}]} { + if {![catch {puts $f exit}]} { + if {![catch {close $f}]} { + set code 1 + } } } - 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 + set code + } + + # Deliberately call socket with the wrong number of arguments. The + # error message you get will indicate whether sockets are available + # on this system. + + ConstraintInitializer socket { + catch {socket} msg + string compare $msg "sockets are not available on this system" + } + + # Check for internationalization + ConstraintInitializer hasIsoLocale { + if {[llength [info commands testlocale]] == 0} { + set code 0 } else { - catch {exec rm -r removeMe} + set code [string length [SetIso8859_1_Locale]] + RestoreLocale } + set code } - # Locate tcltest executable +} +##################################################################### - if {![info exists tk_version]} { - set tcltest [info nameofexecutable] +# Usage and command line arguments processing. - if {$tcltest == "{}"} { - set tcltest {} +# tcltest::PrintUsageInfo +# +# Prints out the usage information for package tcltest. This can +# be customized with the redefinition of [PrintUsageInfoHook]. +# +# Arguments: +# none +# +# Results: +# none +# +# Side Effects: +# none +proc tcltest::PrintUsageInfo {} { + puts [Usage] + PrintUsageInfoHook +} + +proc tcltest::Usage { {option ""} } { + variable Usage + variable Verify + if {[llength [info level 0]] == 1} { + set msg "Usage: [file tail [info nameofexecutable]] script " + append msg "?-help? ?flag value? ... \n" + append msg "Available flags (and valid input values) are:" + + set max 0 + set allOpts [concat -help [Configure]] + foreach opt $allOpts { + set foo [Usage $opt] + lassign $foo x type($opt) usage($opt) + set line($opt) " $opt $type($opt) " + set length($opt) [string length $line($opt)] + if {$length($opt) > $max} {set max $length($opt)} + } + set rest [expr {72 - $max}] + foreach opt $allOpts { + append msg \n$line($opt) + append msg [string repeat " " [expr {$max - $length($opt)}]] + set u [string trim $usage($opt)] + catch {append u " (default: \[[Configure $opt]])"} + regsub -all {\s*\n\s*} $u " " u + while {[string length $u] > $rest} { + set break [string wordstart $u $rest] + if {$break == 0} { + set break [string wordend $u 0] + } + append msg [string range $u 0 [expr {$break - 1}]] + set u [string trim [string range $u $break end]] + append msg \n[string repeat " " $max] + } + append msg $u } + return $msg\n + } elseif {$option eq "-help"} { + return [list -help "" "Display this usage information."] + } else { + set type [lindex [info args $Verify($option)] 0] + return [list $option $type $Usage($option)] } +} - set ::tcltest::testConstraints(stdio) 0 - catch { - catch {file delete -force tmp} - set f [open tmp w] - puts $f { - exit - } - close $f +# tcltest::ProcessFlags -- +# +# process command line arguments supplied in the flagArray - this +# is called by processCmdLineArgs. Modifies tcltest variables +# according to the content of the flagArray. +# +# Arguments: +# flagArray - array containing name/value pairs of flags +# +# Results: +# sets tcltest variables according to their values as defined by +# flagArray +# +# Side effects: +# None. - set f [open "|[list $tcltest tmp]" r] - close $f - - set ::tcltest::testConstraints(stdio) 1 +proc tcltest::ProcessFlags {flagArray} { + # Process -help first + if {"-help" in $flagArray} { + PrintUsageInfo + exit 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. + if {[llength $flagArray] == 0} { + RemoveAutoConfigureTraces + } else { + set args $flagArray + while {[llength $args] > 1 && [catch {configure {*}$args} msg]} { + + # Something went wrong parsing $args for tcltest options + # Check whether the problem is "unknown option" + if {[regexp {^unknown option (\S+):} $msg -> option]} { + # Could be this is an option the Hook knows about + set moreOptions [processCmdLineArgsAddFlagsHook] + if {$option ni $moreOptions} { + # Nope. Report the error, including additional options, + # but keep going + if {[llength $moreOptions]} { + append msg ", " + append msg [join [lrange $moreOptions 0 end-1] ", "] + append msg "or [lindex $moreOptions end]" + } + Warn $msg + } + } else { + # error is something other than "unknown option" + # notify user of the error; and exit + puts [errorChannel] $msg + exit 1 + } - catch {socket} msg - set ::tcltest::testConstraints(socket) \ - [expr {$msg != "sockets are not available on this system"}] - - # Check for internationalization + # To recover, find that unknown option and remove up to it. + # then retry + while {[lindex $args 0] ne $option} { + set args [lrange $args 2 end] + } + set args [lrange $args 2 end] + } + if {[llength $args] == 1} { + puts [errorChannel] \ + "missing value for option [lindex $args 0]" + exit 1 + } + } - 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 + # Call the hook + catch { + array set flag $flagArray + processCmdLineArgsHook [array get flag] } -} + return +} -# ::tcltest::PrintUsageInfoHook +# tcltest::ProcessCmdLineArgs -- # -# Hook used for customization of display of usage information. +# This procedure must be run after constraint initialization is +# set up (by [DefineConstraintInitializers]) because some constraints +# can be overridden. # +# Perform configuration according to the command-line options. +# +# Arguments: +# none +# +# Results: +# Sets the above-named variables in the tcltest namespace. +# +# Side Effects: +# None. +# + +proc tcltest::ProcessCmdLineArgs {} { + variable originalEnv + variable testConstraints -proc ::tcltest::PrintUsageInfoHook {} {} + # The "argv" var doesn't exist in some cases, so use {}. + if {![info exists ::argv]} { + ProcessFlags {} + } else { + ProcessFlags $::argv + } -# ::tcltest::PrintUsageInfo + # Spit out everything you know if we're at a debug level 2 or + # greater + DebugPuts 2 "Flags passed into tcltest:" + if {[info exists ::env(TCLTEST_OPTIONS)]} { + DebugPuts 2 \ + " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" + } + if {[info exists ::argv]} { + DebugPuts 2 " argv: $::argv" + } + DebugPuts 2 "tcltest::debug = [debug]" + DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]" + DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]" + DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]" + DebugPuts 2 "tcltest::outputChannel = [outputChannel]" + DebugPuts 2 "tcltest::errorChannel = [errorChannel]" + DebugPuts 2 "Original environment (tcltest::originalEnv):" + DebugPArray 2 originalEnv + DebugPuts 2 "Constraints:" + DebugPArray 2 testConstraints +} + +##################################################################### + +# Code to run the tests goes here. + +# tcltest::TestPuts -- # -# Prints out the usage information for package tcltest. This can be -# customized with the redefinition of ::tcltest::PrintUsageInfoHook. +# Used to redefine puts in test environment. Stores whatever goes +# out on stdout in tcltest::outData and stderr in errData before +# sending it on to the regular puts. # # Arguments: +# same as standard puts +# +# Results: # none # +# Side effects: +# Intercepts puts; data that would otherwise go to stdout, stderr, +# or file channels specified in outputChannel and errorChannel +# does not get sent to the normal puts function. +namespace eval tcltest::Replace { + namespace export puts +} +proc tcltest::Replace::puts {args} { + variable [namespace parent]::outData + variable [namespace parent]::errData + switch [llength $args] { + 1 { + # Only the string to be printed is specified + append outData [lindex $args 0]\n + return + # return [Puts [lindex $args 0]] + } + 2 { + # Either -nonewline or channelId has been specified + if {[lindex $args 0] eq "-nonewline"} { + append outData [lindex $args end] + return + # return [Puts -nonewline [lindex $args end]] + } else { + set channel [lindex $args 0] + set newline \n + } + } + 3 { + if {[lindex $args 0] eq "-nonewline"} { + # Both -nonewline and channelId are specified, unless + # it's an error. -nonewline is supposed to be argv[0]. + set channel [lindex $args 1] + set newline "" + } + } + } -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\ - -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\ - -debug level \t Internal debug flag."] - ::tcltest::PrintUsageInfoHook - return + if {[info exists channel]} { + if {$channel in [list [[namespace parent]::outputChannel] stdout]} { + append outData [lindex $args end]$newline + return + } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} { + append errData [lindex $args end]$newline + return + } + } + + # If we haven't returned by now, we don't know how to handle the + # input. Let puts handle it. + return [Puts {*}$args] } -# ::tcltest::processCmdLineArgsFlagsHook -- +# tcltest::Eval -- # -# This hook is used to add to the list of command line arguments that are -# processed by ::tcltest::processCmdLineArgs. +# Evaluate the script in the test environment. If ignoreOutput is +# false, store data sent to stderr and stdout in outData and +# errData. Otherwise, ignore this output altogether. # +# Arguments: +# script Script to evaluate +# ?ignoreOutput? Indicates whether or not to ignore output +# sent to stdout & stderr +# +# Results: +# result from running the script +# +# Side effects: +# Empties the contents of outData and errData before running a +# test if ignoreOutput is set to 0. + +proc tcltest::Eval {script {ignoreOutput 1}} { + variable outData + variable errData + DebugPuts 3 "[lindex [info level 0] 0] called" + if {!$ignoreOutput} { + set outData {} + set errData {} + rename ::puts [namespace current]::Replace::Puts + namespace eval :: [list namespace import [namespace origin Replace::puts]] + namespace import Replace::puts + } + set result [uplevel 1 $script] + if {!$ignoreOutput} { + namespace forget puts + namespace eval :: namespace forget puts + rename [namespace current]::Replace::Puts ::puts + } + return $result +} -proc ::tcltest::processCmdLineArgsAddFlagsHook {} {} - -# ::tcltest::processCmdLineArgsHook -- +# tcltest::CompareStrings -- # -# This hook is used to actually process the flags added by -# ::tcltest::processCmdLineArgsAddFlagsHook. +# compares the expected answer to the actual answer, depending on +# the mode provided. Mode determines whether a regexp, exact, +# glob or custom comparison is done. # # Arguments: -# flags The flags that have been pulled out of argv +# actual - string containing the actual result +# expected - pattern to be matched against +# mode - type of comparison to be done +# +# Results: +# result of the match # +# Side effects: +# None. -proc ::tcltest::processCmdLineArgsHook {flag} {} +proc tcltest::CompareStrings {actual expected mode} { + variable CustomMatch + if {![info exists CustomMatch($mode)]} { + return -code error "No matching command registered for `-match $mode'" + } + set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]] + if {[catch {expr {$match && $match}} result]} { + return -code error "Invalid result from `-match $mode' command: $result" + } + return $match +} -# ::tcltest::processCmdLineArgs -- +# tcltest::customMatch -- # -# 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. +# registers a command to be called when a particular type of +# matching is required. # # Arguments: -# none +# nickname - Keyword for the type of matching +# cmd - Incomplete command that implements that type of matching +# when completed with expected string and actual string +# and then evaluated. # # Results: -# Sets the above-named variables in the tcltest namespace. +# None. +# +# Side effects: +# Sets the variable tcltest::CustomMatch -proc ::tcltest::processCmdLineArgs {} { - global argv +proc tcltest::customMatch {mode script} { + variable CustomMatch + if {![info complete $script]} { + return -code error \ + "invalid customMatch script; can't evaluate after completion" + } + set CustomMatch($mode) $script +} - # The "argv" var doesn't exist in some cases, so use {}. +# tcltest::SubstArguments list +# +# This helper function takes in a list of words, then perform a +# substitution on the list as though each word in the list is a separate +# argument to the Tcl function. For example, if this function is +# invoked as: +# +# SubstArguments {$a {$a}} +# +# Then it is as though the function is invoked as: +# +# SubstArguments $a {$a} +# +# This code is adapted from Paul Duffin's function "SplitIntoWords". +# The original function can be found on: +# +# http://purl.org/thecliff/tcl/wiki/858.html +# +# Results: +# a list containing the result of the substitution +# +# Exceptions: +# An error may occur if the list containing unbalanced quote or +# unknown variable. +# +# Side Effects: +# None. +# + +proc tcltest::SubstArguments {argList} { + + # We need to split the argList up into tokens but cannot use list + # operations as they throw away some significant quoting, and + # [split] ignores braces as it should. Therefore what we do is + # gradually build up a string out of whitespace seperated strings. + # We cannot use [split] to split the argList into whitespace + # separated strings as it throws away the whitespace which maybe + # important so we have to do it all by hand. + + set result {} + set token "" + + while {[string length $argList]} { + # Look for the next word containing a quote: " { } + if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \ + $argList all]} { + # Get the text leading up to this word, but not including + # this word, from the argList. + set text [string range $argList 0 \ + [expr {[lindex $all 0] - 1}]] + # Get the word with the quote + set word [string range $argList \ + [lindex $all 0] [lindex $all 1]] + + # Remove all text up to and including the word from the + # argList. + set argList [string range $argList \ + [expr {[lindex $all 1] + 1}] end] + } else { + # Take everything up to the end of the argList. + set text $argList + set word {} + set argList {} + } - if {(![info exists argv]) || ([llength $argv] < 1)} { - set flagArray {} - } else { - set flagArray $argv + if {$token ne {}} { + # If we saw a word with quote before, then there is a + # multi-word token starting with that word. In this case, + # add the text and the current word to this token. + append token $text $word + } else { + # Add the text to the result. There is no need to parse + # the text because it couldn't be a part of any multi-word + # token. Then start a new multi-word token with the word + # because we need to pass this token to the Tcl parser to + # check for balancing quotes + append result $text + set token $word + } + + if { [catch {llength $token} length] == 0 && $length == 1} { + # The token is a valid list so add it to the result. + # lappend result [string trim $token] + append result \{$token\} + set token {} + } } - - # 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 the last token has not been added to the list then there + # is a problem. + if { [string length $token] } { + error "incomplete token \"$token\"" } - if {[catch {array set flag $flagArray}]} { - ::tcltest::PrintError "odd number of arguments specified on command line: \ - $argv" - ::tcltest::PrintUsageInfo - exit 1 + return $result +} + + +# tcltest::test -- +# +# This procedure runs a test and prints an error message if the test +# fails. If 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 +# match variable, if it matches an element in skip, or if one of the +# elements of "constraints" turns out not to be true. +# +# If testLevel is 1, then this is a top level test, and we record +# pass/fail information; otherwise, this information is not logged and +# is not added to running totals. +# +# Attributes: +# Only description is a required attribute. All others are optional. +# Default values are indicated. +# +# constraints - A list of one or more keywords, each of which +# must be the name of an element in the array +# "testConstraints". If any of these elements is +# zero, the test is skipped. This attribute is +# optional; default is {} +# body - Script to run to carry out the test. It must +# return a result that can be checked for +# correctness. This attribute is optional; +# default is {} +# result - Expected result from script. This attribute is +# optional; default is {}. +# output - Expected output sent to stdout. This attribute +# is optional; default is {}. +# errorOutput - Expected output sent to stderr. This attribute +# is optional; default is {}. +# returnCodes - Expected return codes. This attribute is +# optional; default is {0 2}. +# setup - Code to run before $script (above). This +# attribute is optional; default is {}. +# cleanup - Code to run after $script (above). This +# attribute is optional; default is {}. +# match - specifies type of matching to do on result, +# output, errorOutput; this must be a string +# previously registered by a call to [customMatch]. +# The strings exact, glob, and regexp are pre-registered +# by the tcltest package. Default value is exact. +# +# 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. +# +# Results: +# None. +# +# Side effects: +# Just about anything is possible depending on the test. +# + +proc tcltest::test {name description args} { + global tcl_platform + variable testLevel + variable coreModTime + DebugPuts 3 "test $name $args" + DebugDo 1 { + variable TestNames + catch { + puts "test name '$name' re-used; prior use in $TestNames($name)" + } + set TestNames($name) [info script] } - # -help is not listed since it has already been processed - lappend defaultFlags -verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir -file -notfile \ - -preservecore -limitconstraints - set defaultFlags [concat $defaultFlags \ - [ ::tcltest::processCmdLineArgsAddFlagsHook ]] + FillFilesExisted + incr testLevel + + # Pre-define everything to null except output and errorOutput. We + # determine whether or not to trap output based on whether or not + # these variables (output & errorOutput) are defined. + lassign {} constraints setup cleanup body result returnCodes match + + # Set the default match mode + set match exact + + # Set the default match values for return codes (0 is the standard + # expected return value if everything went well; 2 represents + # 'return' being used in the test script). + set returnCodes [list 0 2] + + # The old test format can't have a 3rd argument (constraints or + # script) that starts with '-'. + if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { + if {[llength $args] == 1} { + set list [SubstArguments [lindex $args 0]] + foreach {element value} $list { + set testAttributes($element) $value + } + foreach item {constraints match setup body cleanup \ + result returnCodes output errorOutput} { + if {[info exists testAttributes(-$item)]} { + set testAttributes(-$item) [uplevel 1 \ + ::concat $testAttributes(-$item)] + } + } + } else { + array set testAttributes $args + } + + set validFlags {-setup -cleanup -body -result -returnCodes \ + -match -output -errorOutput -constraints} + + foreach flag [array names testAttributes] { + if {$flag ni $validFlags} { + incr testLevel -1 + set sorted [lsort $validFlags] + set options [join [lrange $sorted 0 end-1] ", "] + append options ", or [lindex $sorted end]" + return -code error "bad option \"$flag\": must be $options" + } + } - 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) + # store whatever the user gave us + foreach item [array names testAttributes] { + set [string trimleft $item "-"] $testAttributes($item) + } + + # Check the values supplied for -match + variable CustomMatch + if {$match ni [array names CustomMatch]} { + incr testLevel -1 + set sorted [lsort [array names CustomMatch]] + set values [join [lrange $sorted 0 end-1] ", "] + append values ", or [lindex $sorted end]" + return -code error "bad -match value \"$match\":\ + must be $values" + } + + # Replace symbolic valies supplied for -returnCodes + foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} { + set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes] + } + } else { + # This is parsing for the old test command format; it is here + # for backward compatibility. + set result [lindex $args end] + if {[llength $args] == 2} { + set body [lindex $args 0] + } elseif {[llength $args] == 3} { + set constraints [lindex $args 0] + set body [lindex $args 1] + } else { + incr testLevel -1 + return -code error "wrong # args:\ + should be \"test name desc ?options?\"" } } - # Set ::tcltest::verbose to the arg of the -verbose flag, if given + if {[Skipped $name $constraints]} { + incr testLevel -1 + return + } - if {[info exists flag(-verbose)]} { - set ::tcltest::verbose $flag(-verbose) + # Save information about the core file. + if {[preserveCore]} { + if {[file exists [file join [workingDirectory] core]]} { + set coreModTime [file mtime [file join [workingDirectory] core]] + } } - # Set ::tcltest::match to the arg of the -match flag, if given. + # First, run the setup script + set code [catch {uplevel 1 $setup} setupMsg] + if {$code == 1} { + set errorInfo(setup) $::errorInfo + set errorCode(setup) $::errorCode + } + set setupFailure [expr {$code != 0}] - if {[info exists flag(-match)]} { - set ::tcltest::match $flag(-match) - } + # Only run the test body if the setup was successful + if {!$setupFailure} { - # Set ::tcltest::skip to the arg of the -skip flag, if given + # Verbose notification of $body start + if {[IsVerbose start]} { + puts [outputChannel] "---- $name start" + flush [outputChannel] + } - if {[info exists flag(-skip)]} { - set ::tcltest::skip $flag(-skip) + set command [list [namespace origin RunTest] $name $body] + if {[info exists output] || [info exists errorOutput]} { + set testResult [uplevel 1 [list [namespace origin Eval] $command 0]] + } else { + set testResult [uplevel 1 [list [namespace origin Eval] $command 1]] + } + lassign $testResult actualAnswer returnCode + if {$returnCode == 1} { + set errorInfo(body) $::errorInfo + set errorCode(body) $::errorCode + } } - # Handle the -file and -notfile flags - if {[info exists flag(-file)]} { - set ::tcltest::matchFiles $flag(-file) + # Always run the cleanup script + set code [catch {uplevel 1 $cleanup} cleanupMsg] + if {$code == 1} { + set errorInfo(cleanup) $::errorInfo + set errorCode(cleanup) $::errorCode } - if {[info exists flag(-notfile)]} { - set ::tcltest::skipFiles $flag(-notfile) + set cleanupFailure [expr {$code != 0}] + + set coreFailure 0 + set coreMsg "" + # check for a core file first - if one was created by the test, + # then the test failed + if {[preserveCore]} { + if {[file exists [file join [workingDirectory] core]]} { + # There's only a test failure 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 [workingDirectory] core]]} { + set coreFailure 1 + } + } else { + set coreFailure 1 + } + + if {([preserveCore] > 1) && ($coreFailure)} { + append coreMsg "\nMoving file to:\ + [file join [temporaryDirectory] core-$name]" + catch {file rename -force -- \ + [file join [workingDirectory] core] \ + [file join [temporaryDirectory] core-$name] + } msg + if {$msg ne {}} { + append coreMsg "\nError:\ + Problem renaming core file: $msg" + } + } + } } - # 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. + # check if the return code matched the expected return code + set codeFailure 0 + if {!$setupFailure && ($returnCode ni $returnCodes)} { + set codeFailure 1 + } - if {[info exists flag(-constraints)]} { - foreach elt $flag(-constraints) { - set ::tcltest::testConstraints($elt) 1 + # If expected output/error strings exist, we have to compare + # them. If the comparison fails, then so did the test. + set outputFailure 0 + variable outData + if {[info exists output] && !$codeFailure} { + if {[set outputCompare [catch { + CompareStrings $outData $output $match + } outputMatch]] == 0} { + set outputFailure [expr {!$outputMatch}] + } else { + set outputFailure 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 errorFailure 0 + variable errData + if {[info exists errorOutput] && !$codeFailure} { + if {[set errorCompare [catch { + CompareStrings $errData $errorOutput $match + } errorMatch]] == 0} { + set errorFailure [expr {!$errorMatch}] + } else { + set errorFailure 1 + } + } + + # check if the answer matched the expected answer + # Only check if we ran the body of the test (no setup failure) + if {$setupFailure || $codeFailure} { + set scriptFailure 0 + } elseif {[set scriptCompare [catch { + CompareStrings $actualAnswer $result $match + } scriptMatch]] == 0} { + set scriptFailure [expr {!$scriptMatch}] + } else { + set scriptFailure 1 + } + + # if we didn't experience any failures, then we passed + variable numTests + if {!($setupFailure || $cleanupFailure || $coreFailure + || $outputFailure || $errorFailure || $codeFailure + || $scriptFailure)} { + if {$testLevel == 1} { + incr numTests(Passed) + if {[IsVerbose pass]} { + puts [outputChannel] "++++ $name PASSED" + } } - set ::tcltest::limitConstraints $flag(-limitconstraints) - foreach elt [array names ::tcltest::testConstraints] { - if {[lsearch -exact $flag(-constraints) $elt] == -1} { - set ::tcltest::testConstraints($elt) 0 + incr testLevel -1 + return + } + + # We know the test failed, tally it... + if {$testLevel == 1} { + incr numTests(Failed) + } + + # ... then report according to the type of failure + variable currentFailure true + if {![IsVerbose body]} { + set body "" + } + puts [outputChannel] "\n" + if {[IsVerbose line]} { + if {![catch {set testFrame [info frame -1]}] && + [dict get $testFrame type] eq "source"} { + set testFile [dict get $testFrame file] + set testLine [dict get $testFrame line] + } else { + set testFile [file normalize [uplevel 1 {info script}]] + if {[file readable $testFile]} { + set testFd [open $testFile r] + set testLine [expr {[lsearch -regexp \ + [split [read $testFd] "\n"] \ + "^\[ \t\]*test [string map {. \\.} $name] "] + 1}] + close $testFd } } + if {[info exists testLine]} { + puts [outputChannel] "$testFile:$testLine: error: test failed:\ + $name [string trim $description]" + } + } + puts [outputChannel] "==== $name\ + [string trim $description] FAILED" + if {[string length $body]} { + puts [outputChannel] "==== Contents of test case:" + puts [outputChannel] $body + } + if {$setupFailure} { + puts [outputChannel] "---- Test setup\ + failed:\n$setupMsg" + if {[info exists errorInfo(setup)]} { + puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)" + puts [outputChannel] "---- errorCode(setup): $errorCode(setup)" + } + } + if {$scriptFailure} { + if {$scriptCompare} { + puts [outputChannel] "---- Error testing result: $scriptMatch" + } else { + puts [outputChannel] "---- Result was:\n$actualAnswer" + puts [outputChannel] "---- Result should have been\ + ($match matching):\n$result" + } + } + if {$codeFailure} { + switch -- $returnCode { + 0 { set msg "Test completed normally" } + 1 { set msg "Test generated error" } + 2 { set msg "Test generated return exception" } + 3 { set msg "Test generated break exception" } + 4 { set msg "Test generated continue exception" } + default { set msg "Test generated exception" } + } + puts [outputChannel] "---- $msg; Return code was: $returnCode" + puts [outputChannel] "---- Return code should have been\ + one of: $returnCodes" + if {[IsVerbose error]} { + if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { + puts [outputChannel] "---- errorInfo: $errorInfo(body)" + puts [outputChannel] "---- errorCode: $errorCode(body)" + } + } + } + if {$outputFailure} { + if {$outputCompare} { + puts [outputChannel] "---- Error testing output: $outputMatch" + } else { + puts [outputChannel] "---- Output was:\n$outData" + puts [outputChannel] "---- Output should have been\ + ($match matching):\n$output" + } + } + if {$errorFailure} { + if {$errorCompare} { + puts [outputChannel] "---- Error testing errorOutput: $errorMatch" + } else { + puts [outputChannel] "---- Error output was:\n$errData" + puts [outputChannel] "---- Error output should have\ + been ($match matching):\n$errorOutput" + } + } + if {$cleanupFailure} { + puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg" + if {[info exists errorInfo(cleanup)]} { + puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)" + puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)" + } + } + if {$coreFailure} { + puts [outputChannel] "---- Core file produced while running\ + test! $coreMsg" } + puts [outputChannel] "==== $name FAILED\n" - # 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. + incr testLevel -1 + return +} - set tmpDirError "" - if {[info exists flag(-tmpdir)]} { - set ::tcltest::temporaryDirectory $flag(-tmpdir) +# Skipped -- +# +# Given a test name and it constraints, returns a boolean indicating +# whether the current configuration says the test should be skipped. +# +# Side Effects: Maintains tally of total tests seen and tests skipped. +# +proc tcltest::Skipped {name constraints} { + variable testLevel + variable numTests + variable testConstraints - if {[string compare \ - [file pathtype $::tcltest::temporaryDirectory] \ - "absolute"] != 0} { - set ::tcltest::temporaryDirectory [file join [pwd] \ - $::tcltest::temporaryDirectory] + if {$testLevel == 1} { + incr numTests(Total) + } + # skip the test if it's name matches an element of skip + foreach pattern [skip] { + if {[string match $pattern $name]} { + if {$testLevel == 1} { + incr numTests(Skipped) + DebugDo 1 {AddToSkippedBecause userSpecifiedSkip} + } + return 1 } - 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 1 - } elseif {![file writable $::tcltest::temporaryDirectory]} { - ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \ - is not writeable" - exit 1 - } elseif {![file readable $::tcltest::temporaryDirectory]} { - ::tcltest::PrintError "$tmpDirError \"$::tcltest::temporaryDirectory\" \ - is not readable" - exit 1 + # skip the test if it's name doesn't match any element of match + set ok 0 + foreach pattern [match] { + if {[string match $pattern $name]} { + set ok 1 + break } - } else { - file mkdir $::tcltest::temporaryDirectory } - set oldpwd [pwd] - cd $::tcltest::temporaryDirectory - set ::tcltest::temporaryDirectory [pwd] - cd $oldpwd - - # 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 {!$ok} { + if {$testLevel == 1} { + incr numTests(Skipped) + DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch} + } + return 1 } + if {$constraints eq {}} { + # If we're limited to the listed constraints and there aren't + # any listed, then we shouldn't run the test. + if {[limitConstraints]} { + AddToSkippedBecause userSpecifiedLimitConstraint + if {$testLevel == 1} { + incr numTests(Skipped) + } + return 1 + } + } else { + # "constraints" argument exists; + # make sure that the constraints are satisfied. - # If an alternate error or output files are specified, change the - # default channels. + set doTest 0 + if {[string match {*[$\[]*} $constraints] != 0} { + # full expression, e.g. {$foo > [info tclversion]} + catch {set doTest [uplevel #0 [list expr $constraints]]} + } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} { + # something like {a || b} should be turned into + # $testConstraints(a) || $testConstraints(b). + regsub -all {[.\w]+} $constraints {$testConstraints(&)} c + catch {set doTest [eval [list expr $c]]} + } elseif {![catch {llength $constraints}]} { + # just simple constraints such as {unixOnly fonts}. + set doTest 1 + foreach constraint $constraints { + if {(![info exists testConstraints($constraint)]) \ + || (!$testConstraints($constraint))} { + set doTest 0 - if {[info exists flag(-outfile)]} { - set tmp $flag(-outfile) - if {[string compare [file pathtype $tmp] "absolute"] != 0} { - set tmp [file join $::tcltest::temporaryDirectory $tmp] + # store the constraint that kept the test from + # running + set constraints $constraint + break + } + } } - set ::tcltest::outputChannel [open $tmp w] - } + + if {!$doTest} { + if {[IsVerbose skip]} { + puts [outputChannel] "++++ $name SKIPPED: $constraints" + } - if {[info exists flag(-errfile)]} { - set tmp $flag(-errfile) - if {[string compare [file pathtype $tmp] "absolute"] != 0} { - set tmp [file join $::tcltest::temporaryDirectory $tmp] + if {$testLevel == 1} { + incr numTests(Skipped) + AddToSkippedBecause $constraints + } + return 1 } - set ::tcltest::errorChannel [open $tmp w] } + return 0 +} - # If the user specifies debug testing, print out extra information during - # the run. - if {[info exists flag(-debug)]} { - set ::tcltest::debug $flag(-debug) - } +# RunTest -- +# +# This is where the body of a test is evaluated. The combination of +# [RunTest] and [Eval] allows the output and error output of the test +# body to be captured for comparison against the expected values. - # Handle -preservecore - if {[info exists flag(-preservecore)]} { - set ::tcltest::preserveCore $flag(-preservecore) - } +proc tcltest::RunTest {name script} { + DebugPuts 3 "Running $name {$script}" - # Call the hook - ::tcltest::processCmdLineArgsHook [array get flag] - - # Spit out everything you know if we're at debug level 2 or greater - if {$::tcltest::debug > 1} { - puts "Flags passed into tcltest:" - parray flag - puts "::tcltest::debug = $::tcltest::debug" - 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 - puts "Constraints:" - parray ::tcltest::testConstraints + # If there is no "memory" command (because memory debugging isn't + # enabled), then don't attempt to use the command. + + if {[llength [info commands memory]] == 1} { + memory tag $name } + + set code [catch {uplevel 1 $script} actualAnswer] + + return [list $actualAnswer $code] +} + +##################################################################### + +# tcltest::cleanupTestsHook -- +# +# This hook allows a harness that builds upon tcltest to specify +# additional things that should be done at cleanup. +# + +if {[llength [info commands tcltest::cleanupTestsHook]] == 0} { + proc tcltest::cleanupTestsHook {} {} } -# ::tcltest::cleanupTests -- +# tcltest::cleanupTests -- # # Remove files and dirs created using the makeFile and makeDirectory # commands since the last time this proc was invoked. @@ -848,120 +2336,157 @@ proc ::tcltest::processCmdLineArgs {} { # # 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}} { - +# +# Arguments: +# calledFromAllFile - if 0, behave as if we are running a single +# test file within an entire suite of tests. if we aren't running +# a single test file, then don't report status. check for new +# files created during the test run and report on them. if 1, +# report collated status from all the test file runs. +# +# Results: +# None. +# +# Side Effects: +# None +# + +proc tcltest::cleanupTests {{calledFromAllFile 0}} { + variable filesMade + variable filesExisted + variable createdNewFiles + variable testSingleFile + variable numTests + variable numTestFiles + variable failFiles + variable skippedBecause + variable currentFailure + variable originalEnv + variable originalTclPlatform + variable coreModTime + + FillFilesExisted set testFileName [file tail [info script]] + # Hook to handle reporting to a parent interpreter + if {[llength [info commands [namespace current]::ReportToMaster]]} { + ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \ + $numTests(Failed) [array get skippedBecause] \ + [array get createdNewFiles] + set testSingleFile false + } + # Call the cleanup hook - ::tcltest::cleanupTestsHook + 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. + # Remove files and directories created by the makeFile and + # makeDirectory procedures. Record the names of files in + # workingDirectory that were not pre-existing, and associate them + # with the test file that created them. if {!$calledFromAllFile} { - foreach file $::tcltest::filesMade { + foreach file $filesMade { if {[file exists $file]} { - catch {file delete -force $file} + DebugDo 1 {Warn "cleanupTests deleting $file..."} + catch {file delete -force -- $file} } } set currentFiles {} foreach file [glob -nocomplain \ - [file join $::tcltest::temporaryDirectory *]] { + -directory [temporaryDirectory] *] { lappend currentFiles [file tail $file] } set newFiles {} foreach file $currentFiles { - if {[lsearch -exact $::tcltest::filesExisted $file] == -1} { + if {$file ni $filesExisted} { lappend newFiles $file } } - set ::tcltest::filesExisted $currentFiles + set filesExisted $currentFiles if {[llength $newFiles] > 0} { - set ::tcltest::createdNewFiles($testFileName) $newFiles + set createdNewFiles($testFileName) $newFiles } } - if {$calledFromAllFile || $::tcltest::testSingleFile} { + if {$calledFromAllFile || $testSingleFile} { # print stats - puts -nonewline $::tcltest::outputChannel "$testFileName:" + puts -nonewline [outputChannel] "$testFileName:" foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline $::tcltest::outputChannel \ - "\t$index\t$::tcltest::numTests($index)" + puts -nonewline [outputChannel] \ + "\t$index\t$numTests($index)" } - puts $::tcltest::outputChannel "" + puts [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 {} + puts [outputChannel] \ + "Sourced $numTestFiles Test Files." + set numTestFiles 0 + if {[llength $failFiles] > 0} { + puts [outputChannel] \ + "Files with failing tests: $failFiles" + set failFiles {} } } - # if any tests were skipped, print the constraints that kept them - # from running. + # if any tests were skipped, print the constraints that kept + # them from running. - set constraintList [array names ::tcltest::skippedBecause] + set constraintList [array names skippedBecause] if {[llength $constraintList] > 0} { - puts $::tcltest::outputChannel \ + puts [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) + puts [outputChannel] \ + "\t$skippedBecause($constraint)\t$constraint" + unset skippedBecause($constraint) } } - # report the names of test files in ::tcltest::createdNewFiles, and - # reset the array to be empty. + # report the names of test files in createdNewFiles, and reset + # the array to be empty. - set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]] + set testFilesThatTurded [lsort [array names createdNewFiles]] if {[llength $testFilesThatTurded] > 0} { - puts $::tcltest::outputChannel "Warning: files left behind:" + puts [outputChannel] "Warning: files left behind:" foreach testFile $testFilesThatTurded { - puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)" - unset ::tcltest::createdNewFiles($testFile) + puts [outputChannel] \ + "\t$testFile:\t$createdNewFiles($testFile)" + unset createdNewFiles($testFile) } } # reset filesMade, filesExisted, and numTests - set ::tcltest::filesMade {} + set filesMade {} foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set ::tcltest::numTests($index) 0 + set numTests($index) 0 } # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {[info exists tk_version] && !$tcl_interactive} { + # This should be changed to determine if an event + # loop is running, which is the real issue. + # Actually, this doesn't belong here at all. A package + # really has no business [exit]-ing an application. + if {![catch {package present Tk}] && ![testConstraint 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 + # 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 + if {$currentFailure && ($testFileName ni $failFiles)} { + lappend failFiles $testFileName } - set ::tcltest::currentFailure false + set currentFailure false # restore the environment to the state it was in before this package # was loaded @@ -970,372 +2495,381 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { set changedEnv {} set removedEnv {} foreach index [array names ::env] { - if {![info exists ::tcltest::originalEnv($index)]} { + if {![info exists 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] { + foreach index [array names originalEnv] { if {![info exists ::env($index)]} { lappend removedEnv $index - set ::env($index) $::tcltest::originalEnv($index) + set ::env($index) $originalEnv($index) + } elseif {$::env($index) ne $originalEnv($index)} { + lappend changedEnv $index + set ::env($index) $originalEnv($index) } } if {[llength $newEnv] > 0} { - puts $::tcltest::outputChannel \ + puts [outputChannel] \ "env array elements created:\t$newEnv" } if {[llength $changedEnv] > 0} { - puts $::tcltest::outputChannel \ + puts [outputChannel] \ "env array elements changed:\t$changedEnv" } if {[llength $removedEnv] > 0} { - puts $::tcltest::outputChannel \ + puts [outputChannel] \ "env array elements removed:\t$removedEnv" } set changedTclPlatform {} - foreach index [array names ::tcltest::originalTclPlatform] { - if {$::tcl_platform($index) != \ - $::tcltest::originalTclPlatform($index)} { + foreach index [array names originalTclPlatform] { + if {$::tcl_platform($index) \ + != $originalTclPlatform($index)} { lappend changedTclPlatform $index - set ::tcl_platform($index) \ - $::tcltest::originalTclPlatform($index) + set ::tcl_platform($index) $originalTclPlatform($index) } } if {[llength $changedTclPlatform] > 0} { - puts $::tcltest::outputChannel \ - "tcl_platform array elements changed:\t$changedTclPlatform" - } + puts [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! \ + if {[file exists [file join [workingDirectory] core]]} { + if {[preserveCore] > 1} { + puts "rename core file (> 1)" + puts [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" + [file join [temporaryDirectory] core-$testFileName]" + catch {file rename -force -- \ + [file join [workingDirectory] core] \ + [file join [temporaryDirectory] core-$testFileName] + } msg + if {$msg ne {}} { + 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. + # 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!" + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join [workingDirectory] core]]} { + puts [outputChannel] "A core file was created!" } } else { - puts $::tcltest::outputChannel "A core file was created!" - } + puts [outputChannel] "A core file was created!" + } } } } + flush [outputChannel] + flush [errorChannel] + return } -# ::tcltest::cleanupTestsHook -- -# -# This hook allows a harness that builds upon tcltest to specify -# additional things that should be done at cleanup. -# +##################################################################### -proc ::tcltest::cleanupTestsHook {} {} +# Procs that determine which tests/test files to run -# test -- +# tcltest::GetMatchingFiles # -# 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. +# 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: -# 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} { - if {$::tcltest::debug > 2} { - puts "Running $name ($description)" - } - - incr ::tcltest::numTests(Total) +# directory to search +# +# Results: +# The constructed list is returned to the user. This will +# primarily be used in 'all.tcl' files. It is used in +# runAllTests. +# +# Side Effects: +# None - # skip the test if it's name matches an element of skip +# a lower case version is needed for compatibility with tcltest 1.0 +proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args} - foreach pattern $::tcltest::skip { - if {[string match $pattern $name]} { - incr ::tcltest::numTests(Skipped) - if {$::tcltest::debug} { - ::tcltest::AddToSkippedBecause userSpecifiedSkip - } - return - } +proc tcltest::GetMatchingFiles { args } { + if {[llength $args]} { + set dirList $args + } else { + # Finding tests only in [testsDirectory] is normal operation. + # This procedure is written to accept multiple directory arguments + # only to satisfy version 1 compatibility. + set dirList [list [testsDirectory]] } - # skip the test if it's name doesn't match any element of match + set matchingFiles [list] + foreach directory $dirList { - 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 + # List files in $directory that match patterns to run. + set matchFileList [list] + foreach match [matchFiles] { + set matchFileList [concat $matchFileList \ + [glob -directory $directory -types {b c f p s} \ + -nocomplain -- $match]] } - } - 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 + # List files in $directory that match patterns to skip. + set skipFileList [list] + foreach skip [skipFiles] { + set skipFileList [concat $skipFileList \ + [glob -directory $directory -types {b c f p s} \ + -nocomplain -- $skip]] } - } 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 - } + # Add to result list all files in match list and not in skip list + foreach file $matchFileList { + if {$file ni $skipFileList} { + lappend matchingFiles $file } } - 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\"" - } + if {[llength $matchingFiles] == 0} { + PrintError "No test files remain after applying your match and\ + skip patterns!" + } + return $matchingFiles +} - # Save information about the core file. You need to restore the original - # tcl_platform environment because some of the tests mess with tcl_platform. +# tcltest::GetMatchingDirectories -- +# +# Looks at the patterns given to match and skip directories and +# uses them to put together a list of the test directories that we +# should attempt to run. (Only subdirectories containing an +# "all.tcl" file are put into the list.) +# +# Arguments: +# root directory from which to search +# +# Results: +# The constructed list is returned to the user. This is used in +# the primary all.tcl file. +# +# Side Effects: +# None. - 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 - } +proc tcltest::GetMatchingDirectories {rootdir} { - # 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 + # Determine the skip list first, to avoid [glob]-ing over subdirectories + # we're going to throw away anyway. Be sure we skip the $rootdir if it + # comes up to avoid infinite loops. + set skipDirs [list $rootdir] + foreach pattern [skipDirectories] { + set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \ + -nocomplain -- $pattern]] } - 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 + # Now step through the matching directories, prune out the skipped ones + # as you go. + set matchDirs [list] + foreach pattern [matchDirectories] { + foreach path [glob -directory $rootdir -types d -nocomplain -- \ + $pattern] { + if {$path ni $skipDirs} { + set matchDirs [concat $matchDirs [GetMatchingDirectories $path]] + if {[file exists [file join $path all.tcl]]} { + lappend matchDirs $path + } } - } 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 + if {[llength $matchDirs] == 0} { + DebugPuts 1 "No test directories remain after applying match\ + and skip patterns!" } + return $matchDirs } -# ::tcltest::getMatchingTestFiles +# tcltest::runAllTests -- # -# 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. +# prints output and sources test files according to the match and +# skip patterns provided. after sourcing test files, it goes on +# to source all.tcl files in matching test subdirectories. # # Arguments: -# none +# shell being tested # # Results: -# The constructed list is returned to the user. This will primarily -# be used in 'all.tcl' files. +# None. +# +# Side effects: +# None. + +proc tcltest::runAllTests { {shell ""} } { + variable testSingleFile + variable numTestFiles + variable numTests + variable failFiles + variable DefaultValue + + FillFilesExisted + if {[llength [info level 0]] == 1} { + set shell [interpreter] + } + + set testSingleFile false + + puts [outputChannel] "Tests running in interp: $shell" + puts [outputChannel] "Tests located in: [testsDirectory]" + puts [outputChannel] "Tests running in: [workingDirectory]" + puts [outputChannel] "Temporary files stored in\ + [temporaryDirectory]" + + # [file system] first available in Tcl 8.4 + if {![catch {file system [testsDirectory]} result] + && ([lindex $result 0] ne "native")} { + # If we aren't running in the native filesystem, then we must + # run the tests in a single process (via 'source'), because + # trying to run then via a pipe will fail since the files don't + # really exist. + singleProcess 1 + } -proc ::tcltest::getMatchingFiles {args} { - set matchingFiles {} - if {[llength $args] > 0} { - set searchDirectory $args + if {[singleProcess]} { + puts [outputChannel] \ + "Test files sourced into current interpreter" } else { - set searchDirectory $::tcltest::testsDirectory + puts [outputChannel] \ + "Test files run in separate interpreters" } - # 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 {$::tcltest::skipFiles != {}} { - set skipFileList {} - foreach skip $::tcltest::skipFiles { - set skipFileList [concat $skipFileList \ - [glob -nocomplain [file join $directory $skip]]] + if {[llength [skip]] > 0} { + puts [outputChannel] "Skipping tests that match: [skip]" + } + puts [outputChannel] "Running tests that match: [match]" + + if {[llength [skipFiles]] > 0} { + puts [outputChannel] \ + "Skipping test files that match: [skipFiles]" + } + if {[llength [matchFiles]] > 0} { + puts [outputChannel] \ + "Only running test files that match: [matchFiles]" + } + + set timeCmd {clock format [clock seconds]} + puts [outputChannel] "Tests began at [eval $timeCmd]" + + # Run each of the specified tests + foreach file [lsort [GetMatchingFiles]] { + set tail [file tail $file] + puts [outputChannel] $tail + flush [outputChannel] + + if {[singleProcess]} { + incr numTestFiles + uplevel 1 [list ::source $file] + } else { + # Pass along our configuration to the child processes. + # EXCEPT for the -outfile, because the parent process + # needs to read and process output of children. + set childargv [list] + foreach opt [Configure] { + if {$opt eq "-outfile"} {continue} + set value [Configure $opt] + # Don't bother passing default configuration options + if {$value eq $DefaultValue($opt)} { + continue + } + lappend childargv $opt $value } - 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 + set cmd [linsert $childargv 0 | $shell $file] + if {[catch { + incr numTestFiles + set pipeFd [open $cmd "r"] + while {[gets $pipeFd line] >= 0} { + if {[regexp [join { + {^([^:]+):\t} + {Total\t([0-9]+)\t} + {Passed\t([0-9]+)\t} + {Skipped\t([0-9]+)\t} + {Failed\t([0-9]+)} + } ""] $line null testFile \ + Total Passed Skipped Failed]} { + foreach index {Total Passed Skipped Failed} { + incr numTests($index) [set $index] + } + if {$Failed > 0} { + lappend failFiles $testFile + } + } elseif {[regexp [join { + {^Number of tests skipped } + {for each constraint:} + {|^\t(\d+)\t(.+)$} + } ""] $line match skipped constraint]} { + if {[string match \t* $match]} { + AddToSkippedBecause $constraint $skipped + } + } else { + puts [outputChannel] $line + } } - } - } else { - set matchingFiles [concat $matchingFiles $matchFileList] + close $pipeFd + } msg]} { + puts [outputChannel] "Test file error: $msg" + # append the name of the test to a list to be reported + # later + lappend testFileFailures $file + } } } - if {$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. + # cleanup + puts [outputChannel] "\nTests ended at [eval $timeCmd]" + cleanupTests 1 + if {[info exists testFileFailures]} { + puts [outputChannel] "\nTest files exiting with errors: \n" + foreach file $testFileFailures { + puts [outputChannel] " [file tail $file]\n" + } + } -proc ::tcltest::openfiles {} { - if {[catch {testchannel open} result]} { - return {} + # Checking for subdirectories in which to run tests + foreach directory [GetMatchingDirectories [testsDirectory]] { + set dir [file tail $directory] + puts [outputChannel] [string repeat ~ 44] + puts [outputChannel] "$dir test began at [eval $timeCmd]\n" + + uplevel 1 [list ::source [file join $directory all.tcl]] + + set endTime [eval $timeCmd] + puts [outputChannel] "\n$dir test ended at $endTime" + puts [outputChannel] "" + puts [outputChannel] [string repeat ~ 44] } - return $result + return } -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 +##################################################################### + +# Test utility procs - not used in tcltest, but may be useful for +# testing. + +# 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 +# +# Side Effects: +# none. + +proc tcltest::loadTestedCommands {} { + return [uplevel 1 [loadScript]] } -# ::tcltest::saveState -- +# tcltest::saveState -- # # Save information regarding what procs and variables exist. # @@ -1343,224 +2877,378 @@ proc ::tcltest::leakfiles {old} { # none # # Results: -# Modifies the variable ::tcltest::saveState +# Modifies the variable saveState +# +# Side effects: +# None. -proc ::tcltest::saveState {} { - uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]} - if {$::tcltest::debug > 1} { - puts "::tcltest::saveState: $::tcltest::saveState" - } +proc tcltest::saveState {} { + variable saveState + uplevel 1 [list ::set [namespace which -variable saveState]] \ + {[::list [::info procs] [::info vars]]} + DebugPuts 2 "[lindex [info level 0] 0]: $saveState" + return } -# ::tcltest::restoreState -- +# tcltest::restoreState -- # # Remove procs and variables that didn't exist before the call to -# ::tcltest::saveState. +# [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]])} { - if {$::tcltest::debug > 2} { - puts "::tcltest::restoreState: Removing proc $p" - } - rename $p {} +# Removes procs and variables from your environment if they don't +# exist in the saveState variable. +# +# Side effects: +# None. + +proc tcltest::restoreState {} { + variable saveState + foreach p [uplevel 1 {::info procs}] { + if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne + [uplevel 1 [list ::namespace origin $p]])} { + + DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p" + uplevel 1 [list ::catch [list ::rename $p {}]] } } - foreach p [uplevel #0 {info vars}] { - if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} { - if {$::tcltest::debug > 2} { - puts "::tcltest::restoreState: Removing variable $p" - } - uplevel #0 "unset $p" + foreach p [uplevel 1 {::info vars}] { + if {$p ni [lindex $saveState 1]} { + DebugPuts 2 "[lindex [info level 0] 0]:\ + Removing variable $p" + uplevel 1 [list ::catch [list ::unset $p]] } } + return } -# ::tcltest::normalizeMsg -- +# tcltest::normalizeMsg -- # # Removes "extra" newlines from a string. # # Arguments: # msg String to be modified # +# Results: +# string with extra newlines removed +# +# Side effects: +# None. -proc ::tcltest::normalizeMsg {msg} { +proc tcltest::normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg - regsub -all "\n\n" $msg "\n" msg - regsub -all "\n\}" $msg "\}" msg - return $msg + set msg [string map [list "\n\n" "\n"] $msg] + return [string map [list "\n\}" "\}"] $msg] } -# makeFile -- +# tcltest::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. +# 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 > 2} { - puts "::tcltest::makeFile: putting $contents into $name" +# Arguments: +# contents content of the new file +# name name of the new file +# directory directory name for new file +# +# Results: +# absolute path to the file created +# +# Side effects: +# None. + +proc tcltest::makeFile {contents name {directory ""}} { + variable filesMade + FillFilesExisted + + if {[llength [info level 0]] == 3} { + set directory [temporaryDirectory] } - set fd [open [file join $::tcltest::temporaryDirectory $name] w] - fconfigure $fd -translation lf + set fullName [file join $directory $name] + + DebugPuts 3 "[lindex [info level 0] 0]:\ + putting ``$contents'' into $fullName" - if {[string equal \ - [string index $contents [expr {[string length $contents] - 1}]] \ - "\n"]} { + set fd [open $fullName w] + chan configure $fd -translation lf + if {[string index $contents end] eq "\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 + if {$fullName ni $filesMade} { + lappend filesMade $fullName } + return $fullName } -# ::tcltest::removeFile -- +# tcltest::removeFile -- # # Removes the named file from the filesystem # # Arguments: -# name file to be removed +# name file to be removed +# directory directory from which to remove file # +# Results: +# return value from [file delete] +# +# Side effects: +# None. -proc ::tcltest::removeFile {name} { - if {$::tcltest::debug > 2} { - puts "::tcltest::removeFile: removing $name" +proc tcltest::removeFile {name {directory ""}} { + variable filesMade + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" + set idx [lsearch -exact $filesMade $fullName] + set filesMade [lreplace $filesMade $idx $idx] + if {$idx == -1} { + DebugDo 1 { + Warn "removeFile removing \"$fullName\":\n not created by makeFile" + } + } + if {![file isfile $fullName]} { + DebugDo 1 { + Warn "removeFile removing \"$fullName\":\n not a file" + } } - file delete [file join $::tcltest::temporaryDirectory $name] + return [file delete -- $fullName] } -# makeDirectory -- +# tcltest::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. +# 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 +# Arguments: +# name name of the new directory +# directory directory in which to create new dir +# +# Results: +# absolute path to the directory created +# +# Side effects: +# None. - set fullName [file join [pwd] $name] - if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} { - lappend ::tcltest::filesMade $fullName +proc tcltest::makeDirectory {name {directory ""}} { + variable filesMade + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] + } + set fullName [file join $directory $name] + DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" + file mkdir $fullName + if {$fullName ni $filesMade} { + lappend filesMade $fullName } + return $fullName } -# ::tcltest::removeDirectory -- +# tcltest::removeDirectory -- # # Removes a named directory from the file system. # # Arguments: -# name Name of the directory to remove +# name Name of the directory to remove +# directory Directory from which to remove # +# Results: +# return value from [file delete] +# +# Side effects: +# None -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] +proc tcltest::removeDirectory {name {directory ""}} { + variable filesMade + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] } + set fullName [file join $directory $name] + DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" + set idx [lsearch -exact $filesMade $fullName] + set filesMade [lreplace $filesMade $idx $idx] + if {$idx == -1} { + DebugDo 1 { + Warn "removeDirectory removing \"$fullName\":\n not created\ + by makeDirectory" + } + } + if {![file isdirectory $fullName]} { + DebugDo 1 { + Warn "removeDirectory removing \"$fullName\":\n not a directory" + } + } + return [file delete -force -- $fullName] } -# grep -- +# tcltest::viewFile -- # -# 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 $_. +# reads the content of a file and returns it # -# Examples of usage would be: -# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers] -# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings] +# Arguments: +# name of the file to read +# directory in which file is located # -# 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 +# Results: +# content of the named file # -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 +# Side effects: +# None. + +proc tcltest::viewFile {name {directory ""}} { + FillFilesExisted + if {[llength [info level 0]] == 2} { + set directory [temporaryDirectory] } - return + set fullName [file join $directory $name] + set f [open $fullName] + set data [read -nonewline $f] + close $f + return $data } +# tcltest::bytestring -- # # 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". +# 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. +# +# Arguments: +# string being converted +# +# Results: +# result fom encoding +# +# Side effects: +# None + +proc tcltest::bytestring {string} { + return [encoding convertfrom identity $string] +} + +# tcltest::OpenFiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. -proc ::tcltest::bytestring {string} { - encoding convertfrom identity $string +proc tcltest::OpenFiles {} { + if {[catch {testchannel open} result]} { + return {} + } + return $result +} + +# tcltest::LeakFiles -- +# +# used in io tests, uses testchannel +# +# Arguments: +# None. +# +# Results: +# ??? +# +# Side effects: +# None. + +proc tcltest::LeakFiles {old} { + if {[catch {testchannel open} new]} { + return {} + } + set leak {} + foreach p $new { + if {$p ni $old} { + lappend leak $p + } + } + return $leak } # # Internationalization / ISO support procs -- dl # -proc ::tcltest::set_iso8859_1_locale {} { + +# tcltest::SetIso8859_1_Locale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::SetIso8859_1_Locale {} { + variable previousLocale + variable isoLocale if {[info commands testlocale] != ""} { - set ::tcltest::previousLocale [testlocale ctype] - testlocale ctype $::tcltest::isoLocale + set previousLocale [testlocale ctype] + testlocale ctype $isoLocale } return } -proc ::tcltest::restore_locale {} { +# tcltest::RestoreLocale -- +# +# used in cmdIL.test, uses testlocale +# +# Arguments: +# None. +# +# Results: +# None. +# +# Side effects: +# None. + +proc tcltest::RestoreLocale {} { + variable previousLocale if {[info commands testlocale] != ""} { - testlocale ctype $::tcltest::previousLocale + testlocale ctype $previousLocale } return } -# threadReap -- +# tcltest::threadReap -- # # Kill all threads except for the main thread. # Do nothing if testthread is not defined. @@ -1570,28 +3258,137 @@ proc ::tcltest::restore_locale {} { # # Results: # Returns the number of existing threads. -proc ::tcltest::threadReap {} { - if {[info commands testthread] != {}} { +# +# Side Effects: +# none. +# + +proc tcltest::threadReap {} { + if {[info commands testthread] ne {}} { + + # 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}} - update + if {$tid != [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] ne {}} { + + # Thread extension + + thread::errorproc ThreadNullError + while {[llength [thread::names]] > 1} { + foreach tid [thread::names] { + if {$tid != [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 } + return 0 } -# Initialize the constraints and set up command line arguments +# Initialize the constraints and set up command line arguments namespace eval tcltest { - ::tcltest::initConstraints - ::tcltest::processCmdLineArgs -} + # Define initializers for all the built-in contraint definitions + DefineConstraintInitializers + + # Set up the constraints in the testConstraints array to be lazily + # initialized by a registered initializer, or by "false" if no + # initializer is registered. + trace add variable testConstraints read [namespace code SafeFetch] + + # Only initialize constraints at package load time if an + # [initConstraintsHook] has been pre-defined. This is only + # for compatibility support. The modern way to add a custom + # test constraint is to just call the [testConstraint] command + # straight away, without all this "hook" nonsense. + if {[namespace current] eq + [namespace qualifiers [namespace which initConstraintsHook]]} { + InitConstraints + } else { + proc initConstraintsHook {} {} + } + + # Define the standard match commands + customMatch exact [list string equal] + customMatch glob [list string match] + customMatch regexp [list regexp --] + + # If the TCLTEST_OPTIONS environment variable exists, configure + # tcltest according to the option values it specifies. This has + # the effect of resetting tcltest's default configuration. + proc ConfigureFromEnvironment {} { + upvar #0 env(TCLTEST_OPTIONS) options + if {[catch {llength $options} msg]} { + Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\ + Tcl list: $msg" + return + } + if {[llength $options] % 2} { + Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\ + -option value ?-option value ...?" + return + } + if {[catch {Configure {*}$options} msg]} { + Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg" + return + } + } + if {[info exists ::env(TCLTEST_OPTIONS)]} { + ConfigureFromEnvironment + } + + proc LoadTimeCmdLineArgParsingRequired {} { + set required false + if {[info exists ::argv] && ("-help" in $::argv)} { + # The command line asks for -help, so give it (and exit) + # right now. ([configure] does not process -help) + set required true + } + foreach hook { PrintUsageInfoHook processCmdLineArgsHook + processCmdLineArgsAddFlagsHook } { + if {[namespace current] eq + [namespace qualifiers [namespace which $hook]]} { + set required true + } else { + proc $hook args {} + } + } + return $required + } + + # Only initialize configurable options from the command line arguments + # at package load time if necessary for backward compatibility. This + # lets the tcltest user call [configure] for themselves if they wish. + # Traces are established for auto-configuration from the command line + # if any configurable options are accessed before the user calls + # [configure]. + if {[LoadTimeCmdLineArgParsingRequired]} { + ProcessCmdLineArgs + } else { + EstablishAutoConfigureTraces + } -return + package provide [namespace tail [namespace current]] $Version +} |