summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2002-04-15 17:04:29 (GMT)
committerdgp <dgp@users.sourceforge.net>2002-04-15 17:04:29 (GMT)
commitce15514b339bfae56c6b2c81da04653c4dff772a (patch)
tree9f16e2991fb5d7c253e867949f00afdcead2e61b /library
parent0634a8c40f890db10df91a2e23e592bbba39c71c (diff)
downloadtcl-ce15514b339bfae56c6b2c81da04653c4dff772a.zip
tcl-ce15514b339bfae56c6b2c81da04653c4dff772a.tar.gz
tcl-ce15514b339bfae56c6b2c81da04653c4dff772a.tar.bz2
* Revised [tcltest::test] to return errors
when called with invalid syntax and to accept exactly two arguments as documented. Improved error messages. [Bug 497446, Patch 513983] ***POTENTIAL INCOMPATIBILITY***: Incompatible with previous tcltest 2.* releases, found only in alpha releases of Tcl 8.4.
Diffstat (limited to 'library')
-rw-r--r--library/tcltest/tcltest.tcl35
1 files changed, 14 insertions, 21 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index ee56e7a..d2535be 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -15,7 +15,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.47 2002/04/08 18:35:51 dgp Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.48 2002/04/15 17:04:29 dgp Exp $
# create the "tcltest" namespace for all testing variables and
# procedures
@@ -1823,10 +1823,10 @@ proc tcltest::SubstArguments {argList} {
# help humans understand what it does.
#
# Results:
-# 0 if the command ran successfully; 1 otherwise.
+# None.
#
# Side effects:
-# None.
+# Just about anything is possible depending on the test.
#
proc tcltest::test {name description args} {
@@ -1854,13 +1854,8 @@ proc tcltest::test {name description args} {
# 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 testLevel -1
- return 1
- } elseif {[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 {
@@ -1882,10 +1877,11 @@ proc tcltest::test {name description args} {
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"
}
}
@@ -1896,10 +1892,9 @@ proc tcltest::test {name description args} {
# 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
@@ -1918,11 +1913,9 @@ proc tcltest::test {name description args} {
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?\""
}
}
@@ -2107,7 +2100,7 @@ proc tcltest::test {name description args} {
}
incr testLevel -1
- return 0
+ return
}