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

[Jacob Bachmeyer]

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