diff options
Diffstat (limited to 'library/tcltest/tcltest.tcl')
| -rw-r--r-- | library/tcltest/tcltest.tcl | 82 |
1 files changed, 67 insertions, 15 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 4ae1480c..02da62f 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -16,13 +16,13 @@ # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. -package require Tcl 8.3 ;# uses [glob -directory] +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.2.10 + variable Version 2.3.4 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -602,22 +602,22 @@ namespace eval tcltest { } proc configure args { RemoveAutoConfigureTraces - set code [catch {eval Configure $args} msg] + 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 } } @@ -631,11 +631,12 @@ namespace eval tcltest { # Default verbosity is to show bodies of failed tests Option -verbose {body error} { - Takes any combination of the values 'p', 's', 'b', 't' and 'e'. + 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 @@ -796,6 +797,29 @@ namespace eval tcltest { trace variable Option(-errfile) w \ [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 + } } ##################################################################### @@ -1419,7 +1443,7 @@ proc tcltest::ProcessFlags {flagArray} { RemoveAutoConfigureTraces } else { set args $flagArray - while {[llength $args]>1 && [catch {eval [linsert $args 0 configure]} msg]} { + while {[llength $args]>1 && [catch {configure {*}$args} msg]} { # Something went wrong parsing $args for tcltest options # Check whether the problem is "unknown option" @@ -1584,7 +1608,7 @@ proc tcltest::Replace::puts {args} { # 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 -- @@ -1613,8 +1637,7 @@ proc tcltest::Eval {script {ignoreOutput 1}} { set outData {} set errData {} rename ::puts [namespace current]::Replace::Puts - namespace eval :: \ - [list namespace import [namespace origin Replace::puts]] + namespace eval :: [list namespace import [namespace origin Replace::puts]] namespace import Replace::puts } set result [uplevel 1 $script] @@ -2087,7 +2110,28 @@ proc tcltest::test {name description args} { if {![IsVerbose body]} { set body "" } - puts [outputChannel] "\n==== $name\ + 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:" @@ -2335,6 +2379,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 @@ -2550,7 +2602,7 @@ 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 { args } { if {[llength $args]} { @@ -3316,7 +3368,7 @@ namespace eval tcltest { -option value ?-option value ...?" return } - if {[catch {eval [linsert $options 0 Configure]} msg]} { + if {[catch {Configure {*}$options} msg]} { Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg" return } |