diff options
Diffstat (limited to 'library/tcltest')
| -rw-r--r-- | library/tcltest/pkgIndex.tcl | 4 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 1209 |
2 files changed, 663 insertions, 550 deletions
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 1ffbceb..c99ad2a 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.3]} {return} -package ifneeded tcltest 2.1 [list source [file join $dir tcltest.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5]} {return} +package ifneeded tcltest 2.3.7 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 0899364..4b94312 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -15,12 +15,14 @@ # Copyright (c) 2000 by Ajuba Solutions # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. -# -# RCS: @(#) $Id: tcltest.tcl,v 1.59 2002/06/27 17:31:05 dgp Exp $ -package require Tcl 8.3 ;# uses [glob -directory] +package require Tcl 8.5 ;# -verbose line uses [info frame] namespace eval tcltest { - variable Version 2.1 + + # When the version number changes, be sure to update the pkgIndex.tcl file, + # and the install directory in the Makefiles. When the minor version + # changes (new feature) be sure to update the man page as well. + variable Version 2.3.7 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -59,7 +61,7 @@ namespace eval tcltest { namespace export temporaryDirectory ;# [configure -tmpdir] namespace export testsDirectory ;# [configure -testdir] namespace export verbose ;# [configure -verbose] - namespace export viewFile ;# bizarre [read]-ish thing + namespace export viewFile ;# binary encoding [read] namespace export workingDirectory ;# [cd] [pwd] # Export deprecated commands for tcltest 1 compatibility @@ -82,7 +84,7 @@ namespace eval tcltest { # None. # proc normalizePath {pathVar} { - upvar $pathVar path + upvar 1 $pathVar path set oldpwd [pwd] catch {cd $path} set path [pwd] @@ -168,12 +170,13 @@ namespace eval tcltest { # save the original environment so that it can be restored later ArrayDefault originalEnv [array get ::env] - # initialize numTests array to keep track fo the number of tests + # 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] - # numTests will store test files as indices and the list of files - # (that should not have been) left behind by the test files. + # 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 @@ -225,32 +228,34 @@ namespace eval tcltest { # 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 - variable FilesExistedFilled 0 proc FillFilesExisted {} { - variable FilesExistedFilled - if {$FilesExistedFilled} {return} 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] } - set FilesExistedFilled 1 + + # After successful filling, turn this into a no-op. + proc FillFilesExisted args {} } # Kept only for compatibility Default constraintsSpecified {} AcceptList - trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \ - [array names ::tcltest::testConstraints] ;# } + 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] != {}} { + if {[info commands thread::id] ne {}} { set mainThread [thread::id] - } elseif {[info commands testthread] != {}} { + } elseif {[info commands testthread] ne {}} { set mainThread [testthread id] } @@ -258,7 +263,7 @@ namespace eval tcltest { # Tcl tests is the working directory. Whenever this value changes # change to that directory. variable workingDirectory - trace variable workingDirectory w \ + trace add variable workingDirectory write \ [namespace code {cd $workingDirectory ;#}] Default workingDirectory [pwd] AcceptAbsolutePath @@ -272,9 +277,11 @@ namespace eval tcltest { # 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] + Default originalTclPlatform [array get ::tcl_platform] # If a core file exists, save its modification time. if {[file exists [file join [workingDirectory] core]]} { @@ -298,12 +305,12 @@ namespace eval tcltest { if {![info exists [namespace current]::isoLocale]} { variable isoLocale fr - switch -- $tcl_platform(platform) { + switch -- $::tcl_platform(platform) { "unix" { # Try some 'known' values for some platforms: - switch -exact -- $tcl_platform(os) { + switch -exact -- $::tcl_platform(os) { "FreeBSD" { set isoLocale fr_FR.ISO_8859-1 } @@ -330,20 +337,59 @@ namespace eval tcltest { } } + variable ChannelsWeOpened; array set ChannelsWeOpened {} # output goes to stdout by default Default outputChannel stdout proc outputChannel { {filename ""} } { variable outputChannel - - # Trigger auto-configuration of -outfile option, if needed. - # This is tricky because we have to trigger a trace on $debug - # so that traces attached to $outputFile are not disabled. - # We need them enabled to reflect changes back to outputChannel - set dummy [debug] + 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 { @@ -351,6 +397,21 @@ namespace eval tcltest { } 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 @@ -360,16 +421,19 @@ namespace eval tcltest { Default errorChannel stderr proc errorChannel { {filename ""} } { variable errorChannel + variable ChannelsWeOpened - # Trigger auto-configuration of -errfile option, if needed. - # This is tricky because we have to trigger a trace on $debug - # so that traces attached to $outputFile are not disabled. - # We need them enabled to reflect changes back to outputChannel - set dummy [debug] + # 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 { @@ -377,6 +441,21 @@ namespace eval tcltest { } 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 @@ -404,18 +483,28 @@ namespace eval tcltest { variable Verify variable Usage variable OptionControlledVariables + variable DefaultValue set Usage($option) $usage set Verify($option) $verify - set Option($option) [$verify $value] + 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]} { - set Option($option) [$verify [set $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 572889. Grrrr.... + # 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 @@ -445,7 +534,7 @@ namespace eval tcltest { } default { # Exact match trumps ambiguity - if {[lsearch -exact $match $option] >= 0} { + if {$option in $match} { return $option } set values [join [lrange $match 0 end-1] ", "] @@ -460,7 +549,8 @@ namespace eval tcltest { variable OptionControlledVariables foreach varName [concat $OptionControlledVariables Option] { variable $varName - trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}] + trace add variable $varName read [namespace code { + ProcessCmdLineArgs ;#}] } } @@ -468,15 +558,15 @@ namespace eval tcltest { variable OptionControlledVariables foreach varName [concat $OptionControlledVariables Option] { variable $varName - foreach pair [trace vinfo $varName] { - foreach {op cmd} $pair break - if {[string equal r $op] - && [string match *ProcessCmdLineArgs* $cmd]} { - trace vdelete $varName $op $cmd + foreach pair [trace info variable $varName] { + lassign $pair op cmd + if {($op eq "read") && + [string match *ProcessCmdLineArgs* $cmd]} { + trace remove variable $varName $op $cmd } } } - # One the traces are removed, this can become a no-op + # Once the traces are removed, this can become a no-op proc RemoveAutoConfigureTraces {} {} } @@ -512,23 +602,25 @@ namespace eval tcltest { } } proc configure args { - RemoveAutoConfigureTraces - set code [catch {eval Configure $args} msg] + if {[llength $args] > 1} { + RemoveAutoConfigureTraces + } + set code [catch {Configure {*}$args} msg] return -code $code $msg } proc AcceptVerbose { level } { set level [AcceptList $level] if {[llength $level] == 1} { - if {![regexp {^(pass|body|skip|start|error)$} $level]} { + if {![regexp {^(pass|body|skip|start|error|line)$} $level]} { # translate single characters abbreviations to expanded list - set level [string map {p pass b body s skip t start e error} \ + set level [string map {p pass b body s skip t start e error l line} \ [split $level {}]] } } set valid [list] foreach v $level { - if {[regexp {^(pass|body|skip|start|error)$} $v]} { + if {[regexp {^(pass|body|skip|start|error|line)$} $v]} { lappend valid $v } } @@ -541,19 +633,20 @@ namespace eval tcltest { } # Default verbosity is to show bodies of failed tests - Option -verbose body { - Takes any combination of the values 'p', 's', 'b', 't' and 'e'. + 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. + 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 {} { + Option -match * { Run all tests within the specified files that match one of the list of glob patterns given. } AcceptList match @@ -567,7 +660,8 @@ namespace eval tcltest { Run tests in all test files that match the glob pattern given. } AcceptPattern matchFiles - Option -notfile {} { + # 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 @@ -605,7 +699,7 @@ namespace eval tcltest { Option -constraints {} { Do not skip the listed constraints listed in -constraints. } AcceptList - trace variable Option(-constraints) w \ + trace add variable Option(-constraints) write \ [namespace code {SetSelectedConstraints ;#}] # Don't run only the "-constraint" specified tests by default @@ -614,15 +708,15 @@ namespace eval tcltest { variable testConstraints if {!$Option(-limitconstraints)} {return} foreach c [array names testConstraints] { - if {[lsearch -exact $Option(-constraints) $c] == -1} { - testConstraint $elt 0 + if {$c ni $Option(-constraints)} { + testConstraint $c 0 } } } - Option -limitconstraints false { + Option -limitconstraints 0 { whether to run only tests with the constraints } AcceptBoolean limitConstraints - trace variable Option(-limitconstraints) w \ + trace add variable Option(-limitconstraints) write \ [namespace code {ClearUnselectedConstraints ;#}] # A test application has to know how to load the tested commands @@ -643,6 +737,11 @@ namespace eval tcltest { } 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 @@ -652,26 +751,26 @@ namespace eval tcltest { Option -tmpdir [workingDirectory] { Save temporary files in the specified directory. } AcceptTemporaryDirectory temporaryDirectory - trace variable Option(-tmpdir) w \ + 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 [file join [file dirname [info script]] .. .. tests] { + Option -testdir [workingDirectory] { Search tests in the specified directory. } AcceptDirectory testsDirectory - trace variable Option(-testdir) w \ + trace add variable Option(-testdir) write \ [namespace code {normalizePath Option(-testdir) ;#}] proc AcceptLoadFile { file } { - if {[string equal "" $file]} {return $file} + if {$file eq {}} {return $file} set file [file join [temporaryDirectory] $file] return [AcceptReadable $file] } proc ReadLoadScript {args} { variable Option - if {[string equal "" $Option(-loadfile)]} {return} + if {$Option(-loadfile) eq {}} {return} set tmp [open $Option(-loadfile) r] loadScript [read $tmp] close $tmp @@ -679,7 +778,7 @@ namespace eval tcltest { Option -loadfile {} { Read the script to load the tested commands from the specified file. } AcceptLoadFile loadFile - trace variable Option(-loadfile) w [namespace code ReadLoadScript] + trace add variable Option(-loadfile) write [namespace code ReadLoadScript] proc AcceptOutFile { file } { if {[string equal stderr $file]} {return $file} @@ -691,16 +790,39 @@ namespace eval tcltest { Option -outfile stdout { Send output from test runs to the specified file. } AcceptOutFile outputFile - trace variable Option(-outfile) w \ + 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 variable Option(-errfile) w \ + 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 + } } ##################################################################### @@ -756,7 +878,7 @@ proc tcltest::DebugPArray {level arrayvar} { variable debug if {$debug >= $level} { - catch {upvar $arrayvar $arrayvar} + catch {upvar 1 $arrayvar $arrayvar} parray $arrayvar } return @@ -796,6 +918,10 @@ proc tcltest::DebugDo {level script} { ##################################################################### +proc tcltest::Warn {msg} { + puts [outputChannel] "WARNING: $msg" +} + # tcltest::mainThread # # Accessor command for tcltest variable mainThread. @@ -827,6 +953,7 @@ proc tcltest::mainThread { {new ""} } { proc tcltest::testConstraint {constraint {value ""}} { variable testConstraints + variable Option DebugPuts 3 "entering testConstraint $constraint $value" if {[llength [info level 0]] == 2} { return $testConstraints($constraint) @@ -835,7 +962,7 @@ proc tcltest::testConstraint {constraint {value ""}} { if {[catch {expr {$value && $value}} msg]} { return -code error $msg } - if {[limitConstraints]} { + if {[limitConstraints] && ($constraint ni $Option(-constraints))} { set value 0 } set testConstraints($constraint) $value @@ -859,11 +986,7 @@ proc tcltest::interpreter { {interp ""} } { if {[llength [info level 0]] == 1} { return $tcltest } - if {[string equal {} $interp]} { - set tcltest {} - } else { - set tcltest $interp - } + set tcltest $interp } ##################################################################### @@ -928,7 +1051,7 @@ proc tcltest::PrintError {errorMsg} { [expr {80 - $InitialMsgLen}]]] puts [errorChannel] [string range $errorMsg 0 $beginningIndex] - while {![string equal end $beginningIndex]} { + while {$beginningIndex ne "end"} { puts -nonewline [errorChannel] \ [string repeat " " $InitialMsgLen] if {($endingIndex - $beginningIndex) @@ -981,7 +1104,7 @@ proc tcltest::PrintError {errorMsg} { proc tcltest::SafeFetch {n1 n2 op} { variable testConstraints DebugPuts 3 "entering SafeFetch $n1 $n2 $op" - if {[string equal {} $n2]} {return} + if {$n2 eq {}} {return} if {![info exists testConstraints($n2)]} { if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} { testConstraint $n2 0 @@ -1075,9 +1198,9 @@ proc tcltest::DefineConstraintInitializers {} { 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"} + 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 @@ -1126,9 +1249,8 @@ proc tcltest::DefineConstraintInitializers {} { # are running as root on Unix. ConstraintInitializer root {expr \ - {[string equal unix $::tcl_platform(platform)] - && ([string equal root $::tcl_platform(user)] - || [string equal "" $::tcl_platform(user)])}} + {($::tcl_platform(platform) eq "unix") && + ($::tcl_platform(user) in {root {}})}} ConstraintInitializer notRoot {expr {![testConstraint root]}} # Set nonBlockFiles constraint: 1 means this platform supports @@ -1136,7 +1258,7 @@ proc tcltest::DefineConstraintInitializers {} { ConstraintInitializer nonBlockFiles { set code [expr {[catch {set f [open defs r]}] - || [catch {fconfigure $f -blocking off}]}] + || [catch {chan configure $f -blocking off}]}] catch {close $f} set code } @@ -1162,10 +1284,10 @@ proc tcltest::DefineConstraintInitializers {} { ConstraintInitializer unixExecs { set code 1 - if {[string equal macintosh $::tcl_platform(platform)]} { + if {$::tcl_platform(platform) eq "macintosh"} { set code 0 } - if {[string equal windows $::tcl_platform(platform)]} { + if {$::tcl_platform(platform) eq "windows"} { if {[catch { set file _tcl_test_remove_me.txt makeFile {hello} $file @@ -1259,7 +1381,7 @@ proc tcltest::Usage { {option ""} } { set allOpts [concat -help [Configure]] foreach opt $allOpts { set foo [Usage $opt] - foreach [list x type($opt) usage($opt)] $foo break + 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)} @@ -1283,7 +1405,7 @@ proc tcltest::Usage { {option ""} } { append msg $u } return $msg\n - } elseif {[string equal -help $option]} { + } elseif {$option eq "-help"} { return [list -help "" "Display this usage information."] } else { set type [lindex [info args $Verify($option)] 0] @@ -1309,7 +1431,7 @@ proc tcltest::Usage { {option ""} } { proc tcltest::ProcessFlags {flagArray} { # Process -help first - if {[lsearch -exact $flagArray {-help}] != -1} { + if {"-help" in $flagArray} { PrintUsageInfo exit 1 } @@ -1318,22 +1440,22 @@ proc tcltest::ProcessFlags {flagArray} { RemoveAutoConfigureTraces } else { set args $flagArray - while {[llength $args] && [catch {eval configure $args} msg]} { + 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 [processCmdLineArgsAddFlagHook] - if {[lsearch -exact $moreOptions $option] == -1} { + 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 [join [lrange $moreOptions 0 end-1] ", "] append msg "or [lindex $moreOptions end]" } - puts [errorChannel] "WARNING: $msg" + Warn $msg } } else { # error is something other than "unknown option" @@ -1344,16 +1466,23 @@ proc tcltest::ProcessFlags {flagArray} { # To recover, find that unknown option and remove up to it. # then retry - while {![string equal [lindex $args 0] $option]} { + 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 - array set flag $flagArray - processCmdLineArgsHook [array get flag] + catch { + array set flag $flagArray + processCmdLineArgsHook [array get flag] + } return } @@ -1393,8 +1522,8 @@ proc tcltest::ProcessCmdLineArgs {} { DebugPuts 2 \ " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)" } - if {[info exists argv]} { - DebugPuts 2 " argv: $argv" + if {[info exists ::argv]} { + DebugPuts 2 " argv: $::argv" } DebugPuts 2 "tcltest::debug = [debug]" DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]" @@ -1443,38 +1572,38 @@ proc tcltest::Replace::puts {args} { } 2 { # Either -nonewline or channelId has been specified - if {[string equal -nonewline [lindex $args 0]]} { + 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 {[string equal -nonewline [lindex $args 0]]} { + 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 {[string equal $channel [[namespace parent]::outputChannel]] - || [string equal $channel stdout]} { - append outData [lindex $args end]\n + if {$channel in [list [[namespace parent]::outputChannel] stdout]} { + append outData [lindex $args end]$newline return - } elseif {[string equal $channel [[namespace parent]::errorChannel]] - || [string equal $channel stderr]} { - append errData [lindex $args end]\n + } 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 [eval Puts $args] + return [Puts {*}$args] } # tcltest::Eval -- @@ -1502,26 +1631,15 @@ proc tcltest::Eval {script {ignoreOutput 1}} { if {!$ignoreOutput} { set outData {} set errData {} - set callerHasPuts [llength [uplevel 1 { - ::info commands [::namespace current]::puts - }]] - if {$callerHasPuts} { - uplevel 1 [list ::rename puts [namespace current]::Replace::Puts] - } else { - interp alias {} [namespace current]::Replace::Puts {} ::puts - } - uplevel 1 [list ::namespace import [namespace origin Replace::puts]] + 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 - uplevel 1 ::namespace forget puts - if {$callerHasPuts} { - uplevel 1 [list ::rename [namespace current]::Replace::Puts puts] - } else { - interp alias {} [namespace current]::Replace::Puts {} - } + namespace eval :: namespace forget puts + rename [namespace current]::Replace::Puts ::puts } return $result } @@ -1646,7 +1764,7 @@ proc tcltest::SubstArguments {argList} { set argList {} } - if {$token != {}} { + 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. @@ -1737,7 +1855,15 @@ proc tcltest::SubstArguments {argList} { 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 @@ -1745,10 +1871,7 @@ proc tcltest::test {name description args} { # 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. - foreach item {constraints setup cleanup body result returnCodes - match} { - set $item {} - } + lassign {} constraints setup cleanup body result returnCodes match # Set the default match mode set match exact @@ -1760,8 +1883,7 @@ proc tcltest::test {name description args} { # 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 {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { if {[llength $args] == 1} { set list [SubstArguments [lindex $args 0]] foreach {element value} $list { @@ -1782,8 +1904,8 @@ proc tcltest::test {name description args} { -match -output -errorOutput -constraints} foreach flag [array names testAttributes] { - if {[lsearch -exact $validFlags $flag] == -1} { - incr tcltest::testLevel -1 + 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]" @@ -1798,8 +1920,8 @@ proc tcltest::test {name description args} { # Check the values supplied for -match variable CustomMatch - if {[lsearch [array names CustomMatch] $match] == -1} { - incr tcltest::testLevel -1 + 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]" @@ -1808,11 +1930,9 @@ proc tcltest::test {name description args} { } # Replace symbolic valies supplied for -returnCodes - regsub -nocase normal $returnCodes 0 returnCodes - regsub -nocase error $returnCodes 1 returnCodes - regsub -nocase return $returnCodes 2 returnCodes - regsub -nocase break $returnCodes 3 returnCodes - regsub -nocase continue $returnCodes 4 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. @@ -1823,272 +1943,277 @@ proc tcltest::test {name description args} { set constraints [lindex $args 0] set body [lindex $args 1] } else { - incr tcltest::testLevel -1 + incr testLevel -1 return -code error "wrong # args:\ should be \"test name desc ?options?\"" } } - set setupFailure 0 - set cleanupFailure 0 + 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]] + } + } - # Run the setup script - if {[catch {uplevel 1 $setup} setupMsg]} { - set setupFailure 1 + # 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}] - # run the test script - set command [list [namespace origin RunTest] $name $description \ - $body $result $constraints] + # Only run the test body if the setup was successful if {!$setupFailure} { + + # 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]] + set testResult [uplevel 1 [list [namespace origin Eval] $command 0]] } else { - set testResult [uplevel 1 \ - [list [namespace origin Eval] $command 1]] + set testResult [uplevel 1 [list [namespace origin Eval] $command 1]] } - } else { - set testResult setupFailure - } - - # Run the cleanup code - if {[catch {uplevel 1 $cleanup} cleanupMsg]} { - set cleanupFailure 1 - } - - # If testResult is an empty list, then the test was skipped - if {$testResult != {}} { - set coreFailure 0 - set coreMsg "" - # check for a core file first - if one was created by the test, - # then the test failed - if {[preserveCore]} { - set currentTclPlatform [array get tcl_platform] - 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. - variable coreModTime - 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 {[string length $msg] > 0} { - append coreMsg "\nError:\ - Problem renaming core file: $msg" - } - } - } - array set tcl_platform $currentTclPlatform + lassign $testResult actualAnswer returnCode + if {$returnCode == 1} { + set errorInfo(body) $::errorInfo + set errorCode(body) $::errorCode } + } - set actualAnswer [lindex $testResult 0] - set code [lindex $testResult end] + # 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}] - # 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]} { - if {[set outputCompare [catch { - CompareStrings $outData $output $match - } outputMatch]] == 0} { - set outputFailure [expr {!$outputMatch}] + 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 outputFailure 1 + set coreFailure 1 } - } - set errorFailure 0 - variable errData - if {[info exists errorOutput]} { - if {[set errorCompare [catch { - CompareStrings $errData $errorOutput $match - } errorMatch]] == 0} { - set errorFailure [expr {!$errorMatch}] - } else { - set errorFailure 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" + } } } + } + + # check if the return code matched the expected return code + set codeFailure 0 + if {!$setupFailure && ($returnCode ni $returnCodes)} { + set codeFailure 1 + } - # check if the return code matched the expected return code - set codeFailure 0 - if {[lsearch -exact $returnCodes $code] == -1} { - 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 } + } - # check if the answer matched the expected answer - if {[set scriptCompare [catch { - CompareStrings $actualAnswer $result $match - } scriptMatch]] == 0} { - set scriptFailure [expr {!$scriptMatch}] + 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 scriptFailure 1 + set errorFailure 1 } + } - # if we didn't experience any failures, then we passed - set testFailed 1 - variable numTests - if {!($setupFailure || $cleanupFailure || $coreFailure - || $outputFailure || $errorFailure || $codeFailure - || $scriptFailure)} { - if {$testLevel == 1} { - incr numTests(Passed) - if {[IsVerbose pass]} { - puts [outputChannel] "++++ $name PASSED" - } + # check if the answer matched the expected answer + # Only check if we ran the body of the test (no setup failure) + if {$setupFailure || $codeFailure} { + set scriptFailure 0 + } elseif {[set scriptCompare [catch { + CompareStrings $actualAnswer $result $match + } scriptMatch]] == 0} { + set scriptFailure [expr {!$scriptMatch}] + } else { + set scriptFailure 1 + } + + # if we didn't experience any failures, then we passed + variable numTests + if {!($setupFailure || $cleanupFailure || $coreFailure + || $outputFailure || $errorFailure || $codeFailure + || $scriptFailure)} { + if {$testLevel == 1} { + incr numTests(Passed) + if {[IsVerbose pass]} { + puts [outputChannel] "++++ $name PASSED" } - set testFailed 0 } + incr testLevel -1 + return + } - if {$testFailed} { - if {$testLevel == 1} { - incr numTests(Failed) - } - variable currentFailure true - if {![IsVerbose body]} { - set body "" - } - puts [outputChannel] "\n==== $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 {$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 -- $code { - 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: $code" - puts [outputChannel] "---- Return code should have been\ - one of: $returnCodes" - if {[IsVerbose error]} { - if {[info exists ::errorInfo]} { - puts [outputChannel] "---- errorInfo:\ - $::errorInfo" - puts [outputChannel] "---- errorCode:\ - $::errorCode" - } - } - } - 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 {$coreFailure} { - puts [outputChannel] "---- Core file produced while\ - running test! $coreMsg" + # 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)" } - puts [outputChannel] "==== $name FAILED\n" - } } + 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 } - -# RunTest -- +# Skipped -- # -# This is the defnition of the version 1.0 test routine for tcltest. It -# is provided here for backward compatibility. It is also used as the -# 'backbone' of the test procedure, as in, this is where all the work -# really gets done. 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. +# Given a test name and it constraints, returns a boolean indicating +# whether the current configuration says the test should be skipped. # -# Arguments: -# name - Name of test, in the form foo-1.2. -# description - Short textual description of the test, to help -# humans understand what it does. -# constraints - A list of one or more keywords, each of which -# must be the name of an element in the array -# "testConstraints". If any of these elements is -# zero, the test is skipped. This argument may be -# omitted. -# script - Script to run to carry out the test. It must -# return a result that can be checked for -# correctness. -# expectedAnswer - Expected result from script. -# -# Behavior depends on the value of testLevel; if testLevel is 1 (top -# level), then events are logged and we track the number of tests -# run/skipped and why. Otherwise, we don't track this information. +# Side Effects: Maintains tally of total tests seen and tests skipped. # -# Results: -# empty list if test is skipped; otherwise returns list containing -# actual returned value from the test and the return code. -# -# Side Effects: -# none. -# - -proc tcltest::RunTest { - name description script expectedAnswer constraints -} { +proc tcltest::Skipped {name constraints} { variable testLevel variable numTests variable testConstraints - variable originalTclPlatform - variable coreModTime 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]} { @@ -2096,32 +2221,25 @@ proc tcltest::RunTest { incr numTests(Skipped) DebugDo 1 {AddToSkippedBecause userSpecifiedSkip} } - return + return 1 } } - # skip the test if it's name doesn't match any element of match - if {[llength [match]] > 0} { - 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 + set ok 0 + foreach pattern [match] { + if {[string match $pattern $name]} { + set ok 1 + break } } - - DebugPuts 3 "Running $name ($description) {$script}\ - {$expectedAnswer} $constraints" - - if {[string equal {} $constraints]} { + 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]} { @@ -2129,7 +2247,7 @@ proc tcltest::RunTest { if {$testLevel == 1} { incr numTests(Skipped) } - return + return 1 } } else { # "constraints" argument exists; @@ -2138,12 +2256,12 @@ proc tcltest::RunTest { set doTest 0 if {[string match {*[$\[]*} $constraints] != 0} { # full expression, e.g. {$foo > [info tclversion]} - catch {set doTest [uplevel #0 expr $constraints]} - } elseif {[regexp {[^.a-zA-Z0-9 \n\r\t]+} $constraints] != 0} { + 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 expr $c]} + catch {set doTest [eval [list expr $c]]} } elseif {![catch {llength $constraints}]} { # just simple constraints such as {unixOnly fonts}. set doTest 1 @@ -2160,38 +2278,29 @@ proc tcltest::RunTest { } } - if {$doTest == 0} { + if {!$doTest} { if {[IsVerbose skip]} { - if {[string equal [namespace current]::Replace::puts \ - [namespace origin puts]]} { - Replace::Puts [outputChannel] \ - "++++ $name SKIPPED: $constraints" - } else { - puts [outputChannel] "++++ $name SKIPPED: $constraints" - } + puts [outputChannel] "++++ $name SKIPPED: $constraints" } if {$testLevel == 1} { incr numTests(Skipped) AddToSkippedBecause $constraints } - return + return 1 } } + return 0 +} - # Save information about the core file. You need to restore the - # original tcl_platform environment because some of the tests mess - # with tcl_platform. +# 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. - if {[preserveCore]} { - set currentTclPlatform [array get tcl_platform] - array set tcl_platform $originalTclPlatform - if {[file exists [file join [workingDirectory] core]]} { - set coreModTime \ - [file mtime [file join [workingDirectory] core]] - } - array set tcl_platform $currentTclPlatform - } +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. @@ -2200,16 +2309,6 @@ proc tcltest::RunTest { memory tag $name } - if {[IsVerbose start]} { - if {[string equal [namespace current]::Replace::puts \ - [namespace origin puts]]} { - Replace::Puts [outputChannel] "---- $name start" - } else { - puts [outputChannel] "---- $name start" - } - flush [outputChannel] - } - set code [catch {uplevel 1 $script} actualAnswer] return [list $actualAnswer $code] @@ -2271,6 +2370,14 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { 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 @@ -2282,7 +2389,8 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { if {!$calledFromAllFile} { foreach file $filesMade { if {[file exists $file]} { - catch {file delete -force $file} + DebugDo 1 {Warn "cleanupTests deleting $file..."} + catch {file delete -force -- $file} } } set currentFiles {} @@ -2292,7 +2400,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { } set newFiles {} foreach file $currentFiles { - if {[lsearch -exact $filesExisted $file] == -1} { + if {$file ni $filesExisted} { lappend newFiles $file } } @@ -2362,10 +2470,11 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { } # exit only if running Tk in non-interactive mode - - global tk_version tcl_interactive - if {![catch {package present Tk}] - && ![info exists tcl_interactive]} { + # This should be changed to determine if an event + # loop is running, which is the real issue. + # Actually, this doesn't belong here at all. A package + # really has no business [exit]-ing an application. + if {![catch {package present Tk}] && ![testConstraint interactive]} { exit } } else { @@ -2374,9 +2483,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { # then add current file to failFile list if any tests in this # file failed - incr numTestFiles - if {$currentFailure \ - && ([lsearch -exact $failFiles $testFileName] == -1)} { + if {$currentFailure && ($testFileName ni $failFiles)} { lappend failFiles $testFileName } set currentFailure false @@ -2391,17 +2498,15 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { if {![info exists originalEnv($index)]} { lappend newEnv $index unset ::env($index) - } else { - if {$::env($index) != $originalEnv($index)} { - lappend changedEnv $index - set ::env($index) $originalEnv($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} { @@ -2435,12 +2540,12 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { puts "rename core file (> 1)" puts [outputChannel] "produced core file! \ Moving file to: \ - [file join [temporaryDirectory] core-$name]" - catch {file rename -force \ + [file join [temporaryDirectory] core-$testFileName]" + catch {file rename -force -- \ [file join [workingDirectory] core] \ - [file join [temporaryDirectory] core-$name] + [file join [temporaryDirectory] core-$testFileName] } msg - if {[string length $msg] > 0} { + if {$msg ne {}} { PrintError "Problem renaming file: $msg" } } else { @@ -2485,44 +2590,46 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { # None # a lower case version is needed for compatibility with tcltest 1.0 -proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args} +proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args} -proc tcltest::GetMatchingFiles { {searchDirectory ""} } { - if {[llength [info level 0]] == 1} { - set searchDirectory [testsDirectory] +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 {} - # Find the matching files in the list of directories and then remove - # the ones that match the skip pattern. Passing a list to foreach is - # required so that a patch like D:\Foo\Bar does not get munged into - # D:FooBar. - foreach directory [list $searchDirectory] { - set matchFileList {} + 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 -nocomplain -- $match]] - } - if {[string compare {} [skipFiles]]} { - set skipFileList {} - foreach skip [skipFiles] { - set skipFileList [concat $skipFileList \ - [glob -directory $directory \ - -nocomplain -- $skip]] - } - foreach file $matchFileList { - # Only include files that don't match the skip pattern - # and aren't SCCS lock files. - if {([lsearch -exact $skipFileList $file] == -1) && \ - (![string match l.*.test [file tail $file]])} { - lappend matchingFiles $file - } + [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 } - } else { - set matchingFiles [concat $matchingFiles $matchFileList] } } - if {[string equal $matchingFiles {}]} { + + if {[llength $matchingFiles] == 0} { PrintError "No test files remain after applying your match and\ skip patterns!" } @@ -2547,42 +2654,36 @@ proc tcltest::GetMatchingFiles { {searchDirectory ""} } { # None. proc tcltest::GetMatchingDirectories {rootdir} { - set matchingDirs {} - set matchDirList {} - # Find the matching directories in testsDirectory and then remove - # the ones that match the skip pattern - foreach match [matchDirectories] { - foreach file [glob -directory $rootdir -nocomplain -- $match] { - if {[file isdirectory $file] - && [string compare $file $rootdir]} { - set matchDirList [concat $matchDirList \ - [GetMatchingDirectories $file]] - if {[file exists [file join $file all.tcl]]} { - lappend matchDirList $file + + # 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 [skipDirectories]]} { - set skipDirs {} - foreach skip [skipDirectories] { - set skipDirs [concat $skipDirs \ - [glob -nocomplain -directory [testsDirectory] $skip]] - } - foreach dir $matchDirList { - # Only include directories that don't match the skip pattern - if {[lsearch -exact $skipDirs $dir] == -1} { - lappend matchingDirs $dir - } - } - } else { - set matchingDirs $matchDirList - } - if {[llength $matchingDirs] == 0} { + + if {[llength $matchDirs] == 0} { DebugPuts 1 "No test directories remain after applying match\ and skip patterns!" } - return $matchingDirs + return $matchDirs } # tcltest::runAllTests -- @@ -2605,6 +2706,7 @@ proc tcltest::runAllTests { {shell ""} } { variable numTestFiles variable numTests variable failFiles + variable DefaultValue FillFilesExisted if {[llength [info level 0]] == 1} { @@ -2621,7 +2723,7 @@ proc tcltest::runAllTests { {shell ""} } { # [file system] first available in Tcl 8.4 if {![catch {file system [testsDirectory]} result] - && ![string equal native [lindex $result 0]]} { + && ([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 @@ -2639,9 +2741,7 @@ proc tcltest::runAllTests { {shell ""} } { if {[llength [skip]] > 0} { puts [outputChannel] "Skipping tests that match: [skip]" } - if {[llength [match]] > 0} { - puts [outputChannel] "Only running tests that match: [match]" - } + puts [outputChannel] "Running tests that match: [match]" if {[llength [skipFiles]] > 0} { puts [outputChannel] \ @@ -2670,8 +2770,13 @@ proc tcltest::runAllTests { {shell ""} } { # needs to read and process output of children. set childargv [list] foreach opt [Configure] { - if {[string equal $opt -outfile]} {continue} - lappend childargv $opt [Configure $opt] + 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 { @@ -2720,7 +2825,7 @@ proc tcltest::runAllTests { {shell ""} } { if {[info exists testFileFailures]} { puts [outputChannel] "\nTest files exiting with errors: \n" foreach file $testFileFailures { - puts " [file tail $file]\n" + puts [outputChannel] " [file tail $file]\n" } } @@ -2761,11 +2866,6 @@ proc tcltest::runAllTests { {shell ""} } { # none. proc tcltest::loadTestedCommands {} { - variable l - if {[string equal {} [loadScript]]} { - return - } - return [uplevel 1 [loadScript]] } @@ -2808,16 +2908,15 @@ proc tcltest::saveState {} { proc tcltest::restoreState {} { variable saveState foreach p [uplevel 1 {::info procs}] { - if {([lsearch [lindex $saveState 0] $p] < 0) - && ![string equal [namespace current]::$p \ - [uplevel 1 [list ::namespace origin $p]]]} { + 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 {[lsearch [lindex $saveState 1] $p] < 0} { + if {$p ni [lindex $saveState 1]} { DebugPuts 2 "[lindex [info level 0] 0]:\ Removing variable $p" uplevel 1 [list ::catch [list ::unset $p]] @@ -2841,9 +2940,8 @@ proc tcltest::restoreState {} { proc tcltest::normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg - regsub -all "\n\n" $msg "\n" msg - regsub -all "\n\}" $msg "\}" msg - return $msg + set msg [string map [list "\n\n" "\n"] $msg] + return [string map [list "\n\}" "\}"] $msg] } # tcltest::makeFile -- @@ -2866,7 +2964,6 @@ proc tcltest::normalizeMsg {msg} { # None. proc tcltest::makeFile {contents name {directory ""}} { - global tcl_platform variable filesMade FillFilesExisted @@ -2877,20 +2974,18 @@ proc tcltest::makeFile {contents name {directory ""}} { set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]:\ - putting $contents into $fullName" + putting ``$contents'' into $fullName" set fd [open $fullName w] - - fconfigure $fd -translation lf - - if {[string equal [string index $contents end] "\n"]} { + chan configure $fd -translation lf + if {[string index $contents end] eq "\n"} { puts -nonewline $fd $contents } else { puts $fd $contents } close $fd - if {[lsearch -exact $filesMade $fullName] == -1} { + if {$fullName ni $filesMade} { lappend filesMade $fullName } return $fullName @@ -2911,13 +3006,26 @@ proc tcltest::makeFile {contents name {directory ""}} { # 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" - return [file delete $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 -- @@ -2947,7 +3055,7 @@ proc tcltest::makeDirectory {name {directory ""}} { set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" file mkdir $fullName - if {[lsearch -exact $filesMade $fullName] == -1} { + if {$fullName ni $filesMade} { lappend filesMade $fullName } return $fullName @@ -2968,13 +3076,27 @@ proc tcltest::makeDirectory {name {directory ""}} { # 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" - return [file delete -force $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 -- @@ -2992,22 +3114,15 @@ proc tcltest::removeDirectory {name {directory ""}} { # None. proc tcltest::viewFile {name {directory ""}} { - global tcl_platform FillFilesExisted if {[llength [info level 0]] == 2} { set directory [temporaryDirectory] } set fullName [file join $directory $name] - if {[string equal $tcl_platform(platform) macintosh] - || ![testConstraint unixExecs]} { - set f [open $fullName] - set data [read -nonewline $f] - close $f - return $data - } else { - return [exec cat $fullName] - } - return + set f [open $fullName] + set data [read -nonewline $f] + close $f + return $data } # tcltest::bytestring -- @@ -3078,7 +3193,7 @@ proc tcltest::LeakFiles {old} { } set leak {} foreach p $new { - if {[lsearch $old $p] < 0} { + if {$p ni $old} { lappend leak $p } } @@ -3149,7 +3264,7 @@ proc tcltest::RestoreLocale {} { # proc tcltest::threadReap {} { - if {[info commands testthread] != {}} { + if {[info commands testthread] ne {}} { # testthread built into tcltest @@ -3169,7 +3284,7 @@ proc tcltest::threadReap {} { } testthread errorproc ThreadError return [llength [testthread names]] - } elseif {[info commands thread::id] != {}} { + } elseif {[info commands thread::id] ne {}} { # Thread extension @@ -3201,15 +3316,15 @@ namespace eval tcltest { # 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 variable testConstraints r [namespace code SafeFetch] + 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 {[string equal [namespace current] \ - [namespace qualifiers [namespace which initConstraintsHook]]]} { + if {[namespace current] eq + [namespace qualifiers [namespace which initConstraintsHook]]} { InitConstraints } else { proc initConstraintsHook {} {} @@ -3226,19 +3341,17 @@ namespace eval tcltest { proc ConfigureFromEnvironment {} { upvar #0 env(TCLTEST_OPTIONS) options if {[catch {llength $options} msg]} { - puts [errorChannel] "WARNING: invalid\ - TCLTEST_OPTIONS \"$options\":\n invalid Tcl list: $msg" + Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\ + Tcl list: $msg" return } - if {[llength $::env(TCLTEST_OPTIONS)] < 2} { - puts [errorChannel] "WARNING: invalid\ - TCLTEST_OPTIONS: \"$options\":\n should be\ + if {[llength $options] % 2} { + Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\ -option value ?-option value ...?" return } - if {[catch {eval Configure $::env(TCLTEST_OPTIONS)} msg]} { - puts [errorChannel] "WARNING: invalid\ - TCLTEST_OPTIONS: \"$options\":\n $msg" + if {[catch {Configure {*}$options} msg]} { + Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg" return } } @@ -3248,15 +3361,15 @@ namespace eval tcltest { proc LoadTimeCmdLineArgParsingRequired {} { set required false - if {[info exists ::argv] && [lsearch -exact $::argv -help]} { + 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 - processCmdLineArgsAddFlagHook } { - if {[string equal [namespace current] [namespace qualifiers \ - [namespace which $hook]]]} { + processCmdLineArgsAddFlagsHook } { + if {[namespace current] eq + [namespace qualifiers [namespace which $hook]]} { set required true } else { proc $hook args {} |