PATCH: add support for verifying errors in internal unit tests

[Jacob Bachmeyer]

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