diff options
Diffstat (limited to 'library/tcltest/tcltest.tcl')
| -rw-r--r-- | library/tcltest/tcltest.tcl | 51 |
1 files changed, 36 insertions, 15 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 8e70628..15b7293 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.2 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -600,22 +600,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 } } @@ -629,11 +629,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 @@ -1417,7 +1418,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" @@ -1582,7 +1583,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 -- @@ -1611,8 +1612,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] @@ -2085,7 +2085,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:" @@ -2548,7 +2569,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]} { @@ -3308,7 +3329,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 } |