diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2018-01-02 20:34:49 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2018-01-02 20:34:49 (GMT) |
commit | 89c1ac99d375fbd73892aa659f06ef5e2c5ea56e (patch) | |
tree | e76ce80d68d11f1ea137bc33a42f71a1d1f32028 /tcl8.6/library/tcltest/tcltest.tcl | |
parent | 01e4cd2ef2ff59418766b2259fbc99771646aba6 (diff) | |
download | blt-89c1ac99d375fbd73892aa659f06ef5e2c5ea56e.zip blt-89c1ac99d375fbd73892aa659f06ef5e2c5ea56e.tar.gz blt-89c1ac99d375fbd73892aa659f06ef5e2c5ea56e.tar.bz2 |
upgrade to tcl/tk 8.6.8
Diffstat (limited to 'tcl8.6/library/tcltest/tcltest.tcl')
-rw-r--r-- | tcl8.6/library/tcltest/tcltest.tcl | 3420 |
1 files changed, 0 insertions, 3420 deletions
diff --git a/tcl8.6/library/tcltest/tcltest.tcl b/tcl8.6/library/tcltest/tcltest.tcl deleted file mode 100644 index f1b6082..0000000 --- a/tcl8.6/library/tcltest/tcltest.tcl +++ /dev/null @@ -1,3420 +0,0 @@ -# tcltest.tcl -- -# -# This file contains support code for the Tcl test suite. It -# defines the tcltest namespace and finds and defines the output -# directory, constraints available, output and error channels, -# etc. used by Tcl tests. See the tcltest man page for more -# details. -# -# This design was based on the Tcl testing approach designed and -# initially implemented by Mary Ann May-Pumphrey of Sun -# Microsystems. -# -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions -# Contributions from Don Porter, NIST, 2002. (not subject to US copyright) -# All rights reserved. - -package require Tcl 8.5- ;# -verbose line uses [info frame] -namespace eval tcltest { - - # 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.4.1 - - # 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; 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 - } - -##### Verification commands used to test values of variables and options - # - # Verification command that accepts everything - proc AcceptAll {value} { - return $value - } - - # Verification command that accepts valid Tcl lists - proc AcceptList { list } { - return [lrange $list 0 end] - } - - # Verification command that accepts a glob pattern - proc AcceptPattern { pattern } { - return [AcceptAll $pattern] - } - - # Verification command that accepts integers - proc AcceptInteger { level } { - return [incr level 0] - } - - # Verification command that accepts boolean values - proc AcceptBoolean { boolean } { - return [expr {$boolean && $boolean}] - } - - # Verification command that accepts (syntactically) valid Tcl scripts - proc AcceptScript { script } { - if {![info complete $script]} { - return -code error "invalid Tcl script: $script" - } - return $script - } - - # Verification command that accepts (converts to) absolute pathnames - proc AcceptAbsolutePath { path } { - return [file join [pwd] $path] - } - - # 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] - } - -##### 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 - } - - # 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 {} - -##### 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]] - } - } - - # 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 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. - 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. - # 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 - - # Save the names of files that already exist in the scratch directory. - foreach file [glob -nocomplain -directory [temporaryDirectory] *] { - lappend filesExisted [file tail $file] - } - - # After successful filling, turn this into a no-op. - proc FillFilesExisted args {} - } - - # 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] - } - - # 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 ;#}] - - Default workingDirectory [pwd] AcceptAbsolutePath - proc workingDirectory { {dir ""} } { - variable workingDirectory - if {[llength [info level 0]] == 1} { - return $workingDirectory - } - set workingDirectory [AcceptAbsolutePath $dir] - } - - # Set the location of the execuatble - Default tcltest [info nameofexecutable] - trace add variable tcltest write [namespace code {testConstraint stdio \ - [eval [ConstraintInitializer stdio]] ;#}] - - # save the platform information so it can be restored later - Default originalTclPlatform [array get ::tcl_platform] - - # If a core file exists, save its modification time. - if {[file exists [file join [workingDirectory] core]]} { - Default coreModTime \ - [file mtime [file join [workingDirectory] core]] - } - - # stdout and stderr buffers for use when we want to store them - Default outData {} - Default errData {} - - # keep track of test level for nested test commands - variable testLevel 0 - - # the variables and procs that existed when saveState was called are - # stored in a variable of the same name - Default saveState {} - - # Internationalization support -- used in [SetIso8859_1_Locale] and - # [RestoreLocale]. Those commands are used in cmdIL.test. - - if {![info exists [namespace current]::isoLocale]} { - variable isoLocale fr - switch -- $::tcl_platform(platform) { - "unix" { - - # Try some 'known' values for some platforms: - - switch -exact -- $::tcl_platform(os) { - "FreeBSD" { - set isoLocale fr_FR.ISO_8859-1 - } - HP-UX { - set isoLocale fr_FR.iso88591 - } - Linux - - IRIX { - 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. - - set isoLocale iso_8859_1 - } - } - } - "windows" { - set isoLocale French - } - } - } - - 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 - } - - # 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] - }] - } - } - - 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] - set levelMap { - l list - p pass - b body - s skip - t start - e error - l line - m msec - u usec - } - set levelRegexp "^([join [dict values $levelMap] |])\$" - if {[llength $level] == 1} { - if {![regexp $levelRegexp $level]} { - # translate single characters abbreviations to expanded list - set level [string map $levelMap [split $level {}]] - } - } - set valid [list] - foreach v $level { - if {[regexp $levelRegexp $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 -- -# -# 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. -# -# Side effects: -# None. - -proc tcltest::AddToSkippedBecause { constraint {value 1}} { - # add the constraint to the list of constraints that kept tests - # from running - variable skippedBecause - - if {[info exists skippedBecause($constraint)]} { - incr skippedBecause($constraint) $value - } else { - set skippedBecause($constraint) $value - } - return -} - -# tcltest::PrintError -- -# -# Prints errors to tcltest::errorChannel and then flushes that -# channel, making sure that all messages are < 80 characters per -# line. -# -# Arguments: -# errorMsg String containing the error to be printed -# -# Results: -# None. -# -# Side effects: -# None. - -proc tcltest::PrintError {errorMsg} { - set InitialMessage "Error: " - set InitialMsgLen [string length $InitialMessage] - puts -nonewline [errorChannel] $InitialMessage - - # Keep track of where the end of the string is. - set endingIndex [string length $errorMsg] - - if {$endingIndex < (80 - $InitialMsgLen)} { - puts [errorChannel] $errorMsg - } else { - # Print up to 80 characters on the first line, including the - # InitialMessage. - set beginningIndex [string last " " [string range $errorMsg 0 \ - [expr {80 - $InitialMsgLen}]]] - puts [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]] - break - } else { - set newEndingIndex [expr {[string last " " \ - [string range $errorMsg $beginningIndex \ - [expr {$beginningIndex - + (80 - $InitialMsgLen)}] - ]] + $beginningIndex}] - if {($newEndingIndex <= 0) - || ($newEndingIndex <= $beginningIndex)} { - set newEndingIndex end - } - puts [errorChannel] [string trim \ - [string range $errorMsg \ - $beginningIndex $newEndingIndex]] - set beginningIndex $newEndingIndex - } - } - } - flush [errorChannel] - return -} - -# 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 - -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 -- -# -# 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 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 - - ConstraintInitializer emptyTest {format 0} - - # By default, tests that expose known bugs are skipped. - - ConstraintInitializer knownBug {format 0} - - # By default, non-portable tests are skipped. - - ConstraintInitializer nonPortable {format 0} - - # Some tests require user interaction. - - ConstraintInitializer userInteraction {format 0} - - # Some tests must be skipped if the interpreter is not in - # interactive mode - - 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. - - 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. - - 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 - # async flush and async close on a pipe. - # - # Test for SCO Unix - cannot run async flushing tests because a - # potential problem with select is apparently interfering. - # (Mark Diekhans). - - 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. - - 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. - - 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 - } - - 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 - } - } - } - 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 { - set code [string length [SetIso8859_1_Locale]] - RestoreLocale - } - set code - } - -} -##################################################################### - -# Usage and command line arguments processing. - -# 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)] - } -} - -# 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. - -proc tcltest::ProcessFlags {flagArray} { - # Process -help first - if {"-help" in $flagArray} { - PrintUsageInfo - exit 1 - } - - 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 - } - - # 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 - } - } - - # Call the hook - catch { - array set flag $flagArray - processCmdLineArgsHook [array get flag] - } - return -} - -# tcltest::ProcessCmdLineArgs -- -# -# 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 - - # The "argv" var doesn't exist in some cases, so use {}. - if {![info exists ::argv]} { - ProcessFlags {} - } else { - ProcessFlags $::argv - } - - # 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 -- -# -# 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 "" - } - } - } - - 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::Eval -- -# -# 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 -} - -# tcltest::CompareStrings -- -# -# 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: -# 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::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::customMatch -- -# -# registers a command to be called when a particular type of -# matching is required. -# -# Arguments: -# 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: -# None. -# -# Side effects: -# Sets the variable tcltest::CustomMatch - -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 -} - -# 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 {$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 {} - } - } - - # If the last token has not been added to the list then there - # is a problem. - if { [string length $token] } { - error "incomplete token \"$token\"" - } - - 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] - } - - 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" - } - } - - # 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?\"" - } - } - - if {[Skipped $name $constraints]} { - incr testLevel -1 - return - } - - # Save information about the core file. - if {[preserveCore]} { - if {[file exists [file join [workingDirectory] core]]} { - set coreModTime [file mtime [file join [workingDirectory] core]] - } - } - - # 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}] - - # Only run the test body if the setup was successful - if {!$setupFailure} { - - # Register startup time - if {[IsVerbose msec] || [IsVerbose usec]} { - set timeStart [clock microseconds] - } - - # Verbose notification of $body start - if {[IsVerbose start]} { - puts [outputChannel] "---- $name start" - flush [outputChannel] - } - - 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 - } - } - - # check if the return code matched the expected return code - set codeFailure 0 - if {!$setupFailure && ($returnCode ni $returnCodes)} { - set codeFailure 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 - } - } - - 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 - } - - # Always run the cleanup script - set code [catch {uplevel 1 $cleanup} cleanupMsg] - if {$code == 1} { - set errorInfo(cleanup) $::errorInfo - set errorCode(cleanup) $::errorCode - } - 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" - } - } - } - } - - if {[IsVerbose msec] || [IsVerbose usec]} { - set t [expr {[clock microseconds] - $timeStart}] - if {[IsVerbose usec]} { - puts [outputChannel] "++++ $name took $t μs" - } - if {[IsVerbose msec]} { - puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms" - } - } - - # 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" - } - } - 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" - - incr testLevel -1 - return -} - -# 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 {$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 - } - } - # 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 - } - } - 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. - - 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 - - # store the constraint that kept the test from - # running - set constraints $constraint - break - } - } - } - - if {!$doTest} { - if {[IsVerbose skip]} { - puts [outputChannel] "++++ $name SKIPPED: $constraints" - } - - if {$testLevel == 1} { - incr numTests(Skipped) - AddToSkippedBecause $constraints - } - return 1 - } - } - return 0 -} - -# 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. - -proc tcltest::RunTest {name script} { - DebugPuts 3 "Running $name {$script}" - - # 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 -- -# -# Remove files and dirs created using the makeFile and makeDirectory -# commands since the last time this proc was invoked. -# -# Print the names of the files created without the makeFile command -# since the tests were invoked. -# -# Print the number tests (total, passed, failed, and skipped) since the -# tests were invoked. -# -# Restore original environment (as reported by special variable env). -# -# 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 - cleanupTestsHook - - # 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 $filesMade { - if {[file exists $file]} { - DebugDo 1 {Warn "cleanupTests deleting $file..."} - catch {file delete -force -- $file} - } - } - set currentFiles {} - foreach file [glob -nocomplain \ - -directory [temporaryDirectory] *] { - lappend currentFiles [file tail $file] - } - set newFiles {} - foreach file $currentFiles { - if {$file ni $filesExisted} { - lappend newFiles $file - } - } - set filesExisted $currentFiles - if {[llength $newFiles] > 0} { - set createdNewFiles($testFileName) $newFiles - } - } - - if {$calledFromAllFile || $testSingleFile} { - - # print stats - - puts -nonewline [outputChannel] "$testFileName:" - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - puts -nonewline [outputChannel] \ - "\t$index\t$numTests($index)" - } - puts [outputChannel] "" - - # print number test files sourced - # print names of files that ran tests which failed - - if {$calledFromAllFile} { - 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. - - set constraintList [array names skippedBecause] - if {[llength $constraintList] > 0} { - puts [outputChannel] \ - "Number of tests skipped for each constraint:" - foreach constraint [lsort $constraintList] { - puts [outputChannel] \ - "\t$skippedBecause($constraint)\t$constraint" - unset skippedBecause($constraint) - } - } - - # report the names of test files in createdNewFiles, and reset - # the array to be empty. - - set testFilesThatTurded [lsort [array names createdNewFiles]] - if {[llength $testFilesThatTurded] > 0} { - puts [outputChannel] "Warning: files left behind:" - foreach testFile $testFilesThatTurded { - puts [outputChannel] \ - "\t$testFile:\t$createdNewFiles($testFile)" - unset createdNewFiles($testFile) - } - } - - # reset filesMade, filesExisted, and numTests - - set filesMade {} - foreach index [list "Total" "Passed" "Skipped" "Failed"] { - set numTests($index) 0 - } - - # exit only if running Tk in non-interactive mode - # 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 - - if {$currentFailure && ($testFileName ni $failFiles)} { - lappend failFiles $testFileName - } - set currentFailure false - - # restore the environment to the state it was in before this package - # was loaded - - set newEnv {} - set changedEnv {} - set removedEnv {} - foreach index [array names ::env] { - if {![info exists originalEnv($index)]} { - lappend newEnv $index - unset ::env($index) - } - } - foreach index [array names originalEnv] { - if {![info exists ::env($index)]} { - lappend removedEnv $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 [outputChannel] \ - "env array elements created:\t$newEnv" - } - if {[llength $changedEnv] > 0} { - puts [outputChannel] \ - "env array elements changed:\t$changedEnv" - } - if {[llength $removedEnv] > 0} { - puts [outputChannel] \ - "env array elements removed:\t$removedEnv" - } - - set changedTclPlatform {} - foreach index [array names originalTclPlatform] { - if {$::tcl_platform($index) \ - != $originalTclPlatform($index)} { - lappend changedTclPlatform $index - set ::tcl_platform($index) $originalTclPlatform($index) - } - } - if {[llength $changedTclPlatform] > 0} { - puts [outputChannel] "tcl_platform array elements\ - changed:\t$changedTclPlatform" - } - - 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 [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. - - if {[info exists coreModTime]} { - if {$coreModTime != [file mtime \ - [file join [workingDirectory] core]]} { - puts [outputChannel] "A core file was created!" - } - } else { - puts [outputChannel] "A core file was created!" - } - } - } - } - flush [outputChannel] - flush [errorChannel] - return -} - -##################################################################### - -# Procs that determine which tests/test files to run - -# tcltest::GetMatchingFiles -# -# Looks at the patterns given to match and skip files and uses -# them to put together a list of the tests that will be run. -# -# Arguments: -# 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 - -# a lower case version is needed for compatibility with tcltest 1.0 -proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args} - -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]] - } - - set matchingFiles [list] - foreach directory $dirList { - - # 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]] - } - - # 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]] - } - - # 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 {[llength $matchingFiles] == 0} { - PrintError "No test files remain after applying your match and\ - skip patterns!" - } - return $matchingFiles -} - -# 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. - -proc tcltest::GetMatchingDirectories {rootdir} { - - # 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]] - } - - # 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 - } - } - } - } - - if {[llength $matchDirs] == 0} { - DebugPuts 1 "No test directories remain after applying match\ - and skip patterns!" - } - return [lsort $matchDirs] -} - -# tcltest::runAllTests -- -# -# 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: -# shell being tested -# -# Results: -# 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 - } - - if {[singleProcess]} { - puts [outputChannel] \ - "Test files sourced into current interpreter" - } else { - puts [outputChannel] \ - "Test files run in separate interpreters" - } - 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 - } - 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 - } - } - 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 - } - } - } - - # 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" - } - } - - # 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 -} - -##################################################################### - -# 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 -- -# -# Save information regarding what procs and variables exist. -# -# Arguments: -# none -# -# Results: -# Modifies the variable saveState -# -# Side effects: -# None. - -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 -- -# -# Remove procs and variables that didn't exist before the call to -# [saveState]. -# -# Arguments: -# none -# -# Results: -# 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 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 -- -# -# 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} { - regsub "\n$" [string tolower $msg] "" msg - set msg [string map [list "\n\n" "\n"] $msg] - return [string map [list "\n\}" "\}"] $msg] -} - -# 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. -# -# 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 fullName [file join $directory $name] - - DebugPuts 3 "[lindex [info level 0] 0]:\ - putting ``$contents'' into $fullName" - - 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 - - if {$fullName ni $filesMade} { - lappend filesMade $fullName - } - return $fullName -} - -# tcltest::removeFile -- -# -# Removes the named file from the filesystem -# -# Arguments: -# 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 {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" - } - } - return [file delete -- $fullName] -} - -# 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. -# -# 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. - -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 -- -# -# Removes a named directory from the file system. -# -# Arguments: -# 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 {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] -} - -# tcltest::viewFile -- -# -# reads the content of a file and returns it -# -# Arguments: -# name of the file to read -# directory in which file is located -# -# Results: -# content of the named file -# -# Side effects: -# None. - -proc tcltest::viewFile {name {directory ""}} { - FillFilesExisted - if {[llength [info level 0]] == 2} { - set directory [temporaryDirectory] - } - 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". -# -# 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::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 -# - -# 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 previousLocale [testlocale ctype] - testlocale ctype $isoLocale - } - return -} - -# 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 $previousLocale - } - return -} - -# tcltest::threadReap -- -# -# Kill all threads except for the main thread. -# Do nothing if testthread is not defined. -# -# Arguments: -# none. -# -# Results: -# Returns the number of existing threads. -# -# 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 != [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 -namespace eval tcltest { - # 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 - } - - package provide [namespace tail [namespace current]] $Version -} |