diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | doc/tcltest.n | 29 | ||||
| -rw-r--r-- | library/tcltest/pkgIndex.tcl | 2 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 118 | ||||
| -rwxr-xr-x | tests/tcltest.test | 119 |
5 files changed, 233 insertions, 46 deletions
@@ -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 |