Attachment "tcltest.patch" to
ticket [513983ffff]
added by
dgp
2002-02-08 08:13:09.
Index: library/tcltest/pkgIndex.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/tcltest/pkgIndex.tcl,v
retrieving revision 1.8
diff -u -r1.8 pkgIndex.tcl
--- library/tcltest/pkgIndex.tcl 9 Aug 2001 01:06:42 -0000 1.8
+++ library/tcltest/pkgIndex.tcl 8 Feb 2002 01:08:36 -0000
@@ -9,4 +9,4 @@
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.3]} {return}
-package ifneeded tcltest 2.0.1 [list source [file join $dir tcltest.tcl]]
+package ifneeded tcltest 2.0.2 [list source [file join $dir tcltest.tcl]]
Index: library/tcltest/tcltest.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/tcltest/tcltest.tcl,v
retrieving revision 1.33
diff -u -r1.33 tcltest.tcl
--- library/tcltest/tcltest.tcl 6 Sep 2001 17:51:00 -0000 1.33
+++ library/tcltest/tcltest.tcl 8 Feb 2002 01:08:37 -0000
@@ -2152,11 +2152,7 @@
# The old test format can't have a 3rd argument (constraints or script)
# that starts with '-'.
- if {[llength $args] == 0} {
- puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}"
- incr tcltest::testLevel -1
- return 1
- } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} {
+ if {([string index [lindex $args 0] 0] == "-") || ([llength $args] <= 1)} {
if {[llength $args] == 1} {
set list [substArguments [lindex $args 0]]
@@ -2179,9 +2175,11 @@
foreach flag [array names testAttributes] {
if {[lsearch -exact $validFlags $flag] == -1} {
- puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test"
incr tcltest::testLevel -1
- return 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"
}
}
@@ -2192,9 +2190,9 @@
# Check the values supplied for -match
if {[lsearch {regexp glob exact} $match] == -1} {
- puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}"
incr tcltest::testLevel -1
- return 1
+ return -code error "bad -match value \"$match\":\
+ must be exact, glob, or regexp"
}
# Replace symbolic valies supplied for -returnCodes
@@ -2213,9 +2211,9 @@
set constraints [lindex $args 0]
set body [lindex $args 1]
} else {
- puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}"
incr tcltest::testLevel -1
- return 1
+ return -code error "wrong # args:\
+ should be \"test name desc ?options?\""
}
}
@@ -2267,13 +2265,15 @@
}
if {($tcltest::preserveCore > 1) && ($coreFailure)} {
- append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]"
+ append coreMsg "\nMoving file to:\
+ [file join $tcltest::temporaryDirectory core-$name]"
catch {file rename -force \
[file join [tcltest::workingDirectory] core] \
[file join $tcltest::temporaryDirectory \
core-$name]} msg
if {[string length $msg] > 0} {
- append coreMsg "\nError: Problem renaming core file: $msg"
+ append coreMsg "\nError:\
+ Problem renaming core file: $msg"
}
}
}
@@ -2331,7 +2331,8 @@
if {![tcltest::isVerbose body]} {
set body ""
}
- puts [outputChannel] "\n==== $name [string trim $description] FAILED"
+ puts [outputChannel] "\n==== $name\
+ [string trim $description] FAILED"
if {$body != ""} {
puts [outputChannel] "==== Contents of test case:"
puts [outputChannel] $body
@@ -2341,7 +2342,8 @@
}
if {$scriptFailure} {
puts [outputChannel] "---- Result was:\n$actualAnswer"
- puts [outputChannel] "---- Result should have been ($match matching):\n$result"
+ puts [outputChannel] "---- Result should have been\
+ ($match matching):\n$result"
}
if {$codeFailure} {
switch -- $code {
@@ -2353,7 +2355,8 @@
default { set msg "Test generated exception" }
}
puts [outputChannel] "---- $msg; Return code was: $code"
- puts [outputChannel] "---- Return code should have been one of: $returnCodes"
+ puts [outputChannel] "---- Return code should have been one of:\
+ $returnCodes"
if {[tcltest::isVerbose error]} {
if {[info exists ::errorInfo]} {
puts [outputChannel] "---- errorInfo: $::errorInfo"
@@ -2363,17 +2366,20 @@
}
if {$outputFailure} {
puts [outputChannel] "---- Output was:\n$tcltest::outData"
- puts [outputChannel] "---- Output should have been ($match matching):\n$output"
+ puts [outputChannel] "---- Output should have been\
+ ($match matching):\n$output"
}
if {$errorFailure} {
puts [outputChannel] "---- Error output was:\n$tcltest::errData"
- puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput"
+ 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"
+ puts [outputChannel] "---- Core file produced while running\
+ test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
@@ -3467,5 +3473,5 @@
}
}
-package provide tcltest 2.0.1
+package provide tcltest 2.0.2
