PATCH: add support for verifying errors in internal unit tests

This patch adds new procedures for verifying that errors are raised when 
appropriate.  This patch also fixes some bugs introduced in previous 
work, including finally getting a very tricky quoting bit right for 
using eval in lib_*_test with lists of arguments.  The proper quoting 
inhibits command and variable substitutions when "eval" is called.

----
*ChangeLog entry:
	* testsuite/runtest.all/default_procs.tcl:
	(lib_errpat_test, lib_errregexp_test, lib_err_test): New.
	(lib_regexp_test): Fix copy-paste-edit error.
	(lib_pat_test, lib_regexp_test, lib_ret_test, lib_bool_test):
	Fix handling of errors raised by tested procedure.  Also ensure
	proper quoting of argument lists passed to eval.
----
patch:
----
diff --git a/testsuite/runtest.all/default_procs.tcl b/testsuite/runtest.all/default_procs.tcl
index ebb0daf..d5ff88a 100644
--- a/testsuite/runtest.all/default_procs.tcl
+++ b/testsuite/runtest.all/default_procs.tcl
@@ -4,59 +4,132 @@ set errno ""
 
 # this tests a proc for a returned pattern
 proc lib_pat_test { cmd arglist pattern } {
-    catch { eval [list $cmd] $arglist } result
-    puts "CMD(lib_pat_test) was: $cmd $arglist"
-    puts "RESULT(lib_pat_test) was: \"${result}\" for pattern \"$pattern\"."
-
-    if { [regexp -- "with too many" $result] } {
+    puts "CMD(lib_pat_test) is: $cmd $arglist"
+    if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 0 } {
+	puts "RESULT(lib_pat_test) was: \"${result}\"\
+		for pattern \"$pattern\"."
+	if { [string match "$pattern" $result] } {
+	    return 1
+	} else {
+	    return 0
+	}
+    } else {
+	puts "RESULT(lib_pat_test) was error \"${result}\""
 	return -1
     }
-    if { [string match "$pattern" $result] } {
-	return 1
+}
+
+# this tests a proc for a returned regexp
+proc lib_regexp_test { cmd arglist regexp } {
+    puts "CMD(lib_regexp_test) is: $cmd $arglist"
+    if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 0 } {
+	puts "RESULT(lib_regexp_test) was: \"${result}\"\
+		for regexp \"$regexp\"."
+	if { [regexp -- $regexp $result] } {
+	    return 1
+	} else {
+	    return 0
+	}
     } else {
-	return 0
+	puts "RESULT(lib_regexp_test) was error \"${result}\""
+	return -1
     }
 }
 
-# this tests a proc for a returned regexp
-proc lib_regexp_test { cmd arglist pattern } {
-    catch { eval [list $cmd] $arglist } result
-    puts "CMD(lib_pat_test) was: $cmd $arglist"
-    puts "RESULT(lib_pat_test) was: \"${result}\" for pattern \"$pattern\"."
+# this tests a proc for a returned value
+proc lib_ret_test { cmd arglist val } {
+    puts "CMD(lib_ret_test) is: $cmd $arglist"
+    if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 0 } {
+	puts "RESULT(lib_ret_test) was: $result"
+	if { $result eq $val } {
+	    return 1
+	} else {
+	    return 0
+	}
+    } else {
+	puts "RESULT(lib_ret_test) was error \"${result}\""
+	return -1
+    }
+}
 
-    if { [regexp -- "with too many" $result] } {
+# this tests a proc for an expected boolean result
+proc lib_bool_test { cmd arglist val } {
+    puts "CMD(lib_bool_test) is: $cmd $arglist"
+    if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 0 } {
+	puts "RESULT(lib_bool_test) was: \"$result\" expecting $val."
+	if { $val } {
+	    if { $result } { return 1 } else { return 0 }
+	} else {
+	    if { $result } { return 0 } else { return 1 }
+	}
+    } else {
+	puts "RESULT(lib_bool_test) was error \"${result}\""
 	return -1
     }
-    if { [regexp -- "$pattern" $result] } {
-	return 1
+}
+
+# this tests that a proc raises an error matching a pattern
+proc lib_errpat_test { cmd arglist pattern } {
+    puts "CMD(lib_errpat_test) is: $cmd $arglist"
+    if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 1 } {
+	# caught exception code 1 (TCL_ERROR) as expected
+	puts "RESULT(lib_errpat_test) was error\
+		\"${result}\" for pattern \"$pattern\"."
+	if { [string match $pattern $result] } {
+	    # the expected error
+	    return 1
+	} else {
+	    # an unexpected error
+	    return -1
+	}
     } else {
+	# no error -> fail
+	puts "RESULT(lib_errpat_test) was: \"${result}\"\
+		without error; failing."
 	return 0
     }
 }
 
-# this tests a proc for a returned value
-proc lib_ret_test { cmd arglist val } {
-    catch { eval [list $cmd] $arglist } result
-    puts "CMD(lib_ret_test) was: $cmd $arglist"
-    puts "RESULT(lib_ret_test) was: $result"
-
-    if { $result eq $val } {
-	return 1
+# this tests that a proc raises an error matching a regexp
+proc lib_errregexp_test { cmd arglist regexp } {
+    puts "CMD(lib_errregexp_test) is: $cmd $arglist"
+    if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 1 } {
+	# caught exception code 1 (TCL_ERROR) as expected
+	puts "RESULT(lib_errregexp_test) was error\
+		\"${result}\" for regexp \"$regexp\"."
+	if { [regexp -- $regexp $result] } {
+	    # the expected error
+	    return 1
+	} else {
+	    # an unexpected error
+	    return -1
+	}
     } else {
+	# no error -> fail
+	puts "RESULT(lib_errregexp_test) was: \"${result}\"\
+		without error; failing."
 	return 0
     }
 }
 
-# this tests a proc for an expected boolean result
-proc lib_bool_test { cmd arglist val } {
-    catch { eval [list $cmd] $arglist } result
-    puts "CMD(lib_bool_test) was: $cmd $arglist"
-    puts "RESULT(lib_bool_test) was: \"$result\" expecting \"$val\"."
-
-    if { $val } {
-	if { $result } { return 1 } else { return 0 }
+# this tests that a proc raises an error matching an exact string
+proc lib_err_test { cmd arglist val } {
+    puts "CMD(lib_err_test) is: $cmd $arglist"
+    if { [catch { eval [list $cmd] [lrange $arglist 0 end] } result] == 1 } {
+	# caught exception code 1 (TCL_ERROR) as expected
+	puts "RESULT(lib_err_test) was error: $result"
+	if { $result eq $val } {
+	    # the expected error
+	    return 1
+	} else {
+	    # an unexpected error
+	    return -1
+	}
     } else {
-	if { $result } { return 0 } else { return 1 }
+	# no error -> fail
+	puts "RESULT(lib_err_test) was: \"${result}\"\
+		without error; failing."
+	return 0
     }
 }
 
----


-- Jacob