Re: PATCH: add support for verifying errors in internal unit tests [revised patch]

Ben Elliston wrote:
> On Fri, Dec 07, 2018 at 06:59:01PM -0600, Jacob Bachmeyer wrote:
>   
>> +	if { [string match "$pattern" $result] } {
>> +	    return 1
>> +	} else {
>> +	    return 0
>> +     }
>>     
>
> This can be simplified to:
>      return [string match $pattern $result]
>   

Done.

>> +	if { [regexp -- $regexp $result] } {
>> +	    return 1
>> +	} else {
>> +	    return 0
>> +	}
>>     
>
> Likewise here for [regexp ...].
>   

Done.

>> +	if { $result eq $val } {
>> +	    return 1
>> +	} else {
>> +	    return 0
>> +	}
>>     
>
> This can be simplified to:
>      return [string equal $result $val]
>   

Done.  In practice [expr { $result eq $val }] should also work, but the 
form of booleans expr returns is not documented.  The [string equal] 
command is documented to return 0 or 1.

Those had been left as they were because I saw them as a very clear way 
to write that code, also illustrating what to expect from these 
functions.  A form of self-documenting code, if you will.

>> +	if { $val } {
>> +	    if { $result } { return 1 } else { return 0 }
>> +	} else {
>> +	    if { $result } { return 0 } else { return 1 }
>> +	}
>>     
>
> This could be simplified to:
>
>      if {$val} {
>      	return [expr $result != 0]
>      } else {
>         return [expr $result == 0]
>      }
>   

That is not actually equivalent in Tcl; if it were, I would have used 
that when I wrote lib_bool_test.  See Tcl_GetBoolean(3) for details; in 
short, Tcl booleans can be "0", "false", "no", "off" for a false value 
or "1", "true", "yes", "on" for a true value.  The "if" command is a bit 
more lenient and will also accept any non-zero digit string as true.  
Strictly, there is no guarantee in Tcl that $result will contain a 
number for a procedure that returns a boolean value.  The "==" operator 
is magic, but not that magic.  :-)

That said, Tcl does have the ternary operator, which allows simplifying 
that to a single "return [expr {...}]" that is correct in all cases.  
Done.  Revised patch follows:

----
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 and simplify
	the logic for producing return values.
----
patch:
----
diff --git a/testsuite/runtest.all/default_procs.tcl b/testsuite/runtest.all/default_procs.tcl
index ebb0daf..076c645 100644
--- a/testsuite/runtest.all/default_procs.tcl
+++ b/testsuite/runtest.all/default_procs.tcl
@@ -4,59 +4,117 @@ 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\"."
+	return [string match "$pattern" $result]
+    } 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\"."
+	return [regexp -- $regexp $result]
     } 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"
+	return [string equal $result $val]
+    } 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."
+	# the "odd" spacing is used to help make the operator grouping clear
+	return [expr {  $val  ?   $result ? 1 : 0   :   $result ? 0 : 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