* 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]

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