summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog11
-rw-r--r--doc/tcltest.n29
-rw-r--r--library/tcltest/pkgIndex.tcl2
-rw-r--r--library/tcltest/tcltest.tcl118
-rwxr-xr-xtests/tcltest.test119
5 files changed, 233 insertions, 46 deletions
diff --git a/ChangeLog b/ChangeLog
index 1f2d68c..8cb311c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2002-06-03 Don Porter <dgp@users.sourceforge.net>
+
+ * doc/tcltest.n:
+ * library/tcltest/tcltest.tcl:
+ * library/tcltest/pkgIndex.tcl:
+ * tests/tcltest.test: Implementation of TIP 85. Allows tcltest
+ users to add new legal values of the -match option to [test],
+ associating each with a Tcl command that does the matching of
+ expected results with actual results of tests. Thanks to
+ Arjen Markus. [Patch 521362]
+
2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
* doc/namespace.n: added description of [namepace forget]
diff --git a/doc/tcltest.n b/doc/tcltest.n
index db5d485..35eb110 100644
--- a/doc/tcltest.n
+++ b/doc/tcltest.n
@@ -7,7 +7,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: tcltest.n,v 1.16 2002/04/18 00:00:19 dgp Exp $
+'\" RCS: @(#) $Id: tcltest.n,v 1.17 2002/06/03 23:44:32 dgp Exp $
'\"
.so man.macros
.TH "tcltest" n 8.4 Tcl "Tcl Built-In Commands"
@@ -16,7 +16,7 @@
.SH NAME
tcltest \- Test harness support code and utilities
.SH SYNOPSIS
-\fBpackage require tcltest ?2.0?\fR
+\fBpackage require tcltest ?2.1?\fR
.sp
\fBtcltest::test \fIname desc ?option value? ?option value? ...\fR
.br
@@ -36,6 +36,8 @@ tcltest \- Test harness support code and utilities
.sp
\fBtcltest::preserveCore \fI?level?\fR
.sp
+\fBtcltest::customMatch \fImode command\fR
+.sp
\fBtcltest::testConstraint \fIconstraint ?value?\fR
.sp
\fBtcltest::limitConstraints \fI?constraintList?\fR
@@ -214,6 +216,18 @@ tcltest::cleanupTests is called from all.tcl. Save any core files
produced in tcltest::temporaryDirectory.
.RE
.TP
+\fBtcltest::customMatch \fImode script\fR
+Registers \fImode\fR as a new legal value of the \fB-match\fR option
+to \fItcltest::test\fR. When the \fB-match \fImode\fR option is
+passed to \fItcltest::test\fR, the script \fIscript\fR will be evaluted
+to compare the actual result of the test script against the expected result.
+To perform the match, the \fIscript\fR is completed with two additional
+words, the expected result, and the actual result, and the completed script
+is evaluated in the global namespace.
+The completed script is expected to return a boolean value indicating
+whether or not the results match. The built-in matching modes of
+\fItcltest::test\fR are \fBexact\fR, \fBglob\fR, and \fBregexp\fR.
+.TP
\fBtcltest::testConstraint \fIconstraint ?value?\fR
Sets or returns the value associated with the named \fIconstraint\fR.
See the section \fI"Test constraints"\fR for more information.
@@ -405,7 +419,7 @@ test \fIname\fR \fIdescription\fR
?-output \fIexpectedOutput\fR?
?-errorOutput \fIexpectedError\fR?
?-returnCodes \fIcodeList\fR?
- ?-match \fIexact|glob|regexp\fR?
+ ?-match \fImode\fR?
.DE
.PP
The second form for the \fBtest\fR command (adds brace grouping):
@@ -419,7 +433,7 @@ test \fIname\fR \fIdescription\fR {
?-output\fIexpectedOutput\fR?
?-errorOutput \fIexpectedError\fR?
?-returnCodes \fIcodeList\fR?
- ?-match \fIexact|glob|regexp\fR?
+ ?-match \fImode\fR?
}
.DE
The \fIname\fR argument should follow the pattern:
@@ -468,11 +482,12 @@ The optional \fIcleanup\fR attribute indicates a script that will be
run after the script indicated by the \fIscript\fR attribute. If
cleanup fails, the test will fail.
.TP
-\fB-match \fIregexp|glob|exact\fR
+\fB-match \fImode\fR
The \fImatch\fR attribute determines how expected answers supplied in
\fIresult\fR, \fIoutput\fR, and \fIerrorOutput\fR are compared. Valid
-options for the value supplied are ``regexp'', ``glob'', and
-``exact''. If \fImatch\fR is not specified, the comparisons will be
+options for the value supplied are ``regexp'', ``glob'', ``exact'',
+and any value registered by a prior call to \fItcltest::customMatch\fR.
+If \fImatch\fR is not specified, the comparisons will be
done in ``exact'' mode by default.
.TP
\fB-result \fIexpectedValue\fR
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
index db46a52..1ffbceb 100644
--- a/library/tcltest/pkgIndex.tcl
+++ b/library/tcltest/pkgIndex.tcl
@@ -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.2 [list source [file join $dir tcltest.tcl]]
+package ifneeded tcltest 2.1 [list source [file join $dir tcltest.tcl]]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 404aca5..5bc73a3 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.50 2002/05/08 05:50:24 dgp Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.51 2002/06/03 23:44:32 dgp Exp $
# create the "tcltest" namespace for all testing variables and
# procedures
@@ -25,7 +25,7 @@ package require Tcl 8.3
namespace eval tcltest {
# Export the public tcltest procs
- namespace export bytestring cleanupTests debug errorChannel \
+ namespace export bytestring cleanupTests customMatch debug errorChannel \
errorFile interpreter limitConstraints loadFile loadScript \
loadTestedCommands mainThread makeDirectory makeFile match \
matchDirectories matchFiles normalizeMsg normalizePath \
@@ -1649,8 +1649,8 @@ proc tcltest::Eval {script {ignoreOutput 1}} {
# tcltest::CompareStrings --
#
# compares the expected answer to the actual answer, depending on
-# the mode provided. Mode determines whether a regexp, exact, or
-# glob comparison is done.
+# the mode provided. Mode determines whether a regexp, exact,
+# glob or custom comparison is done.
#
# Arguments:
# actual - string containing the actual result
@@ -1664,20 +1664,42 @@ proc tcltest::Eval {script {ignoreOutput 1}} {
# None.
proc tcltest::CompareStrings {actual expected mode} {
- switch -- $mode {
- exact {
- set retval [string equal $actual $expected]
- }
- glob {
- set retval [string match $expected $actual]
- }
- regexp {
- set retval [regexp -- $expected $actual]
- }
+ variable CustomMatch
+ if {![info exists CustomMatch($mode)]} {
+ return -code error "No matching command registered for `-match $mode'"
+ }
+ set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
+ if {[catch {expr {$match && $match}} result]} {
+ return -code error "Invalid result from `-match $mode' command: $result"
}
- return $retval
+ return $match
}
+# tcltest::customMatch --
+#
+# registers a command to be called when a particular type of
+# matching is required.
+#
+# Arguments:
+# nickname - Keyword for the type of matching
+# cmd - Incomplete command that implements that type of matching
+# when completed with expected string and actual string
+# and then evaluated.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Sets the variable tcltest::CustomMatch
+
+proc tcltest::customMatch {mode script} {
+ variable CustomMatch
+ if {![info complete $script]} {
+ return -code error \
+ "invalid customMatch script; can't evaluate after completion"
+ }
+ set CustomMatch($mode) $script
+}
# tcltest::SubstArguments list
#
@@ -1815,8 +1837,10 @@ proc tcltest::SubstArguments {argList} {
# cleanup - Code to run after $script (above). This
# attribute is optional; default is {}.
# match - specifies type of matching to do on result,
-# output, errorOutput; this must be one of: exact,
-# glob, regexp. default is exact.
+# output, errorOutput; this must be a string
+# previously registered by a call to [customMatch].
+# The strings exact, glob, and regexp are pre-registered
+# by the tcltest package. Default value is exact.
#
# Arguments:
# name - Name of test, in the form foo-1.2.
@@ -1892,10 +1916,14 @@ proc tcltest::test {name description args} {
}
# Check the values supplied for -match
- if {[lsearch {regexp glob exact} $match] == -1} {
+ variable CustomMatch
+ if {[lsearch [array names CustomMatch] $match] == -1} {
incr tcltest::testLevel -1
+ set sorted [lsort [array names CustomMatch]]
+ set values [join [lrange $sorted 0 end-1] ", "]
+ append values ", or [lindex $sorted end]"
return -code error "bad -match value \"$match\":\
- must be exact, glob, or regexp"
+ must be $values"
}
# Replace symbolic valies supplied for -returnCodes
@@ -1992,33 +2020,45 @@ proc tcltest::test {name description args} {
# If expected output/error strings exist, we have to compare
# them. If the comparison fails, then so did the test.
set outputFailure 0
- set errorFailure 0
variable outData
if {[info exists output]} {
- set outputFailure [expr \
- {![CompareStrings $outData $output $match]}]
+ if {[set outputCompare [catch {
+ CompareStrings $outData $output $match
+ } outputMatch]] == 0} {
+ set outputFailure [expr {!$outputMatch}]
+ } else {
+ set outputFailure 1
+ }
}
+ set errorFailure 0
variable errData
if {[info exists errorOutput]} {
- set errorFailure [expr \
- {![CompareStrings $errData $errorOutput $match]}]
+ if {[set errorCompare [catch {
+ CompareStrings $errData $errorOutput $match
+ } errorMatch]] == 0} {
+ set errorFailure [expr {!$errorMatch}]
+ } else {
+ set errorFailure 1
+ }
}
- set testFailed 1
- set codeFailure 0
- set scriptFailure 0
-
# check if the return code matched the expected return code
+ set codeFailure 0
if {[lsearch -exact $returnCodes $code] == -1} {
set codeFailure 1
}
# check if the answer matched the expected answer
- if {[CompareStrings $actualAnswer $result $match] == 0} {
+ if {[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
+ set testFailed 1
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
|| $outputFailure || $errorFailure || $codeFailure
@@ -2051,10 +2091,14 @@ proc tcltest::test {name description args} {
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 {
@@ -2078,14 +2122,23 @@ proc tcltest::test {name description args} {
}
}
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\
@@ -3247,8 +3300,13 @@ namespace eval tcltest {
foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
lappend filesExisted [file tail $file]
}
+
+ # Define the standard match commands
+ customMatch exact [list ::string equal]
+ customMatch glob [list ::string match]
+ customMatch regexp [list ::regexp --]
unset file
}
-package provide tcltest 2.0.2
+package provide tcltest 2.1
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 736ef27..dca7cea 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -6,17 +6,13 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.test,v 1.21 2002/05/10 18:47:11 dgp Exp $
+# RCS: @(#) $Id: tcltest.test,v 1.22 2002/06/03 23:44:32 dgp Exp $
-set tcltestVersion [package require tcltest]
-namespace import -force ::tcltest::*
-
-if {[package vcompare $tcltestVersion 1.0] < 1} {
- puts "Tests require that version 2.0 of tcltest be loaded."
- puts "$tcltestVersion was loaded instead - tests will be skipped."
- tcltest::cleanupTests
+if {[catch {package require tcltest 2.1}]} {
+ puts "Skipping tests in [info script]. tcltest 2.1 required."
return
}
+namespace import -force ::tcltest::*
makeFile {
package require tcltest
@@ -1314,6 +1310,113 @@ test tcltest-23.5 {viewFile} {
}
}
+# customMatch
+test tcltest-24.0 {
+ tcltest::customMatch: syntax
+} -body {
+ list [catch {customMatch} result] $result
+} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
+
+test tcltest-24.1 {
+ tcltest::customMatch: syntax
+} -body {
+ list [catch {customMatch foo} result] $result
+} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
+
+test tcltest-24.2 {
+ tcltest::customMatch: syntax
+} -body {
+ list [catch {customMatch foo bar baz} result] $result
+} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
+
+test tcltest-24.3 {
+ tcltest::customMatch: syntax
+} -body {
+ list [catch {customMatch bad "a \{ b"} result] $result
+} -result [list 1 "invalid customMatch script; can't evaluate after completion"]
+
+test tcltest-24.4 {
+ tcltest::test: valid -match values
+} -body {
+ list [catch {
+ test tcltest-24.4.0 {} \
+ -match ReallyBadMatchValueThatNoTestWillUse
+ } result] $result
+} -match glob -result {1 *bad -match value*}
+
+test tcltest-24.5 {
+ tcltest::test: valid -match values
+} -setup {
+ customMatch alwaysMatch "format 1 ;#"
+} -body {
+ list [catch {
+ test tcltest-24.5.0 {} \
+ -match ReallyBadMatchValueThatNoTestWillUse
+ } result] $result
+} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}
+
+test tcltest-24.6 {
+ tcltest::customMatch: -match script that always matches
+} -setup {
+ customMatch alwaysMatch "format 1 ;#"
+ set v [verbose]
+ verbose {}
+} -body {
+ test tcltest-24.6.0 {} -match alwaysMatch -body {format 1} -result 0
+} -cleanup {
+ verbose $v
+} -result {} -output {} -errorOutput {}
+
+test tcltest-24.7 {
+ tcltest::customMatch: replace default -exact matching
+} -setup {
+ set saveExactMatchScript $::tcltest::CustomMatch(exact)
+ customMatch exact "format 1 ;#"
+ set v [verbose]
+ verbose {}
+} -body {
+ test tcltest-24.7.0 {} -body {format 1} -result 0
+} -cleanup {
+ verbose $v
+ customMatch exact $saveExactMatchScript
+ unset saveExactMatchScript
+} -result {} -output {}
+
+test tcltest-24.8 {
+ tcltest::customMatch: default -exact matching
+} -setup {
+ set saveExactMatchScript $::tcltest::CustomMatch(exact)
+ customMatch exact [list ::string equal]
+ set v [verbose]
+ verbose {}
+} -body {
+ test tcltest-24.8.0 {} -body {format 1} -result 0
+} -cleanup {
+ verbose $v
+ customMatch exact $saveExactMatchScript
+ unset saveExactMatchScript
+} -match glob -result {} -output {*FAILED*Result was:
+1*(exact matching):
+0*}
+
+test tcltest-24.9 {
+ tcltest::customMatch: error during match
+} -setup {
+ proc errorDuringMatch args {return -code error "match returned error"}
+ customMatch errorDuringMatch [namespace code errorDuringMatch]
+} -body {
+ test tcltest-24.9.0 {} -match errorDuringMatch
+} -match glob -result {} -output {*FAILED*match returned error*}
+
+test tcltest-24.10 {
+ tcltest::customMatch: bad return from match command
+} -setup {
+ proc nonBooleanReturn args {return foo}
+ customMatch nonBooleanReturn [namespace code nonBooleanReturn]
+} -body {
+ test tcltest-24.10.0 {} -match nonBooleanReturn
+} -match glob -result {} -output {*FAILED*expected boolean value*}
+
# cleanup
if {[file exists a.tmp]} {
file delete -force a.tmp