PATCH: More improvements for DejaGnu internal unit tests

[Jacob Bachmeyer]

This patch adds two procedures for use with the run_tests procedure in 
default_procs.tcl and adjusts the DejaGnu internal unit tests to 
actually use run_tests where applicable.  The new procedures allow 
run_tests to verify return values against regexps and to verify boolean 
return values.  The use of [subst {...}] as the parameter to run_tests 
allows variable and command substitutions to be performed on the list of 
tests in the calling context.

There was a FIXME comment in config.test that has been there since the 
code was imported in 2001 that this patch finally fixes.  ChangeLog-1992 
suggests that it may go all the way back to January 1996 when 
config.test was added.  There is no mention of default_procs.tcl in 
ChangeLog-1992.  I will say:  Fixed after 22 years.  :-)

This also fixes the "getdirs" tests that have actually been failing for 
who-knows-how-long, but were reported as passing because the testing 
logic had the sense of the result from lib_pat_test inverted.  :-)

ChangeLog entries:
----
        * testsuite/runtest.all/default_procs.tcl (lib_bool_test): New.
        (lib_regexp_test): New.
        (lib_pat_test): Brace "if" conditions.
        (lib_pat_test): Remove spurious quotes in debugging output.
        (run_tests): Add support for comments in lists of procedure tests.

        * testsuite/runtest.all/config.test: Adjust to use run_tests
        procedure.  Fixes issue cited in FIXME comment.

        * testsuite/runtest.all/utils.test (getdirs tests): Fix these.
        The old tests had the sense of the return value from lib_pat_test
        inverted and were actually failing but reported "PASS" anyway.
        (find tests, relative_filename tests, runtest_file_p tests):
        Adjust to use run_tests procedure.
----
patch:
----
diff --git a/testsuite/runtest.all/config.test 
b/testsuite/runtest.all/config.test
index 55af4d4..6443cb4 100644
--- a/testsuite/runtest.all/config.test
+++ b/testsuite/runtest.all/config.test
@@ -28,132 +28,65 @@ set target_cpu i586
set target_os linux
set build_triplet i586-unknown-linux

-# FIXME: should use run_tests here, but due to Tcl's weird scoping rules, I get
-# problems.
-
#
# Tests for a native configuration
#
-if [isbuild $build_triplet] {
-    puts "PASSED: isbuild, native"
-} else {
-    puts "FAILED: isbuild, native"
-}
-
-if [isbuild $target_cpu-*-$target_os ] {
-    puts "PASSED: isbuild, native regexp"
-} else {
-    puts "FAILED: isbuild, native regexp"
-}
-
-if [isbuild hppa-ibm-macos ] {
-    puts "FAILED: isbuild, native bogus config string"
-} else {
-    puts "PASSED: isbuild, native bogus config string"
-}
-
-# test default argument for isbuild
-if {[isbuild] ne $build_triplet} {
-   puts "FAILED: isbuild with no arguments"
-} else {
-   puts "PASSED: isbuild with no arguments"
-}
-
-# ishost tests
-if [ishost $host_triplet] {
-    puts "PASSED: ishost, native"
-} else {
-    puts "FAILED: ishost, native"
-}
-
-if [ishost $target_cpu-*-$target_os] {
-    puts "PASSED: ishost, native regexp"
-} else {
-    puts "FAILED: ishost, native regexp"
-}
-
-if [ishost hppa-ibm-macos] {
-    puts "FAILED: ishost, native bogus config string"
-} else {
-    puts "PASSED: ishost, native bogus config string"
-}
-
-# test default argument for ishost
-if {[ishost] ne $host_triplet} {
-   puts "FAILED: ishost with no arguments"
-} else {
-   puts "PASSED: ishost with no arguments"
-}
-
-# istarget tests
-if [istarget $target_triplet] {
-    puts "PASSED: istarget, native"
-} else {
-    puts "FAILED: istarget, native"
-}
-
-if [istarget $target_cpu-*-$target_os] {
-    puts "PASSED: istarget, native regexp"
-} else {
-    puts "FAILED: istarget, native regexp"
-}
-
-if [istarget hppa-ibm-macos] {
-    puts "FAILED: istarget, native bogus config string"
-} else {
-    puts "PASSED: istarget, native bogus config string"
-}
-
-# test default argument for istarget
-if {[istarget] ne $target_triplet} {
-   puts "FAILED: istarget with no arguments"
-} else {
-   puts "PASSED: istarget with no arguments"
-}
-
-# native tests
-if [isnative] {
-    puts "PASSED: isnative, native"
-} else {
-    puts "FAILED: isnative, native"
-}
-
-if [is3way] {
-     puts "FAILED: is3way, native"
-} else {
-    puts "PASSED: is3way, native"
+run_tests [subst {
+    { lib_bool_test isbuild {$build_triplet} true
+       "isbuild, native" }
+    { lib_bool_test isbuild {$target_cpu-*-$target_os} true
+       "isbuild, native regexp" }
+    { lib_bool_test isbuild {hppa-ibm-macos} false
+       "isbuild, native bogus config string" }
+
+    { "#" "test default argument for isbuild" }
+    { lib_ret_test isbuild {} $build_triplet
+       "isbuild with no arguments" }
+
+    { "#" "ishost tests" }
+    { lib_bool_test ishost {$host_triplet} true
+       "ishost, native" }
+    { lib_bool_test ishost {$target_cpu-*-$target_os} true
+       "ishost, native regexp" }
+    { lib_bool_test ishost {hppa-ibm-macos} false
+       "ishost, native bogus config string" }
+
+    { "#" "test default argument for ishost" }
+    { lib_ret_test ishost {} $host_triplet
+       "ishost with no arguments" }
+
+    { "#" "istarget tests" }
+    { lib_bool_test istarget {$target_triplet} true
+       "istarget, native" }
+    { lib_bool_test istarget {$target_cpu-*-$target_os} true
+       "istarget, native regexp" }
+    { lib_bool_test istarget {hppa-ibm-macos} false
+       "istarget, native bogus config string" }
+
+    { "#" "test default argument for istarget" }
+    { lib_ret_test istarget {} $target_triplet
+       "istarget with no arguments" }
+}]
+
+run_tests {
+    { lib_bool_test isnative {} true   "isnative, native" }
+    { lib_bool_test is3way {} false    "is3way, native" }
}

#
# Tests for a normal cross configuration
#
set target_triplet m68k-unknown-elf
-if [isnative] {
-    puts "FAILED: isnative, cross"
-} else {
-    puts "PASSED: isnative, cross"
-}
-
-if [is3way] {
-     puts "FAILED: is3way, cross"
-} else {
-    puts "PASSED: is3way, cross"
+run_tests {
+    { lib_bool_test isnative {} false  "isnative, cross" }
+    { lib_bool_test is3way {} false    "is3way, cross" }
}

#
# Tests for a canadian cross configuration
#
set host_triplet  i386-unknown-winnt
-if [isnative] {
-    puts "FAILED: isnative, canadian cross"
-} else {
-    puts "PASSED: isnative, canadian cross"
-}
-
-if [is3way] {
-     puts "PASSED: is3way, canadian cross"
-} else {
-    puts "FAILED: is3way, canadian cross"
+run_tests {
+    { lib_bool_test isnative {} false  "isnative, canadian cross" }
+    { lib_bool_test is3way {} true     "is3way, canadian cross" }
}
-
-
diff --git a/testsuite/runtest.all/default_procs.tcl 
b/testsuite/runtest.all/default_procs.tcl
index c5e4099..ebb0daf 100644
--- a/testsuite/runtest.all/default_procs.tcl
+++ b/testsuite/runtest.all/default_procs.tcl
@@ -5,12 +5,29 @@ 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 "CMD(lib_pat_test) was: $cmd $arglist"
    puts "RESULT(lib_pat_test) was: \"${result}\" for pattern \"$pattern\"."
-    if [ regexp -- "with too many" $result ] {
+
+    if { [regexp -- "with too many" $result] } {
+       return -1
+    }
+    if { [string match "$pattern" $result] } {
+       return 1
+    } else {
+       return 0
+    }
+}
+
+# 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\"."
+
+    if { [regexp -- "with too many" $result] } {
        return -1
    }
-    if [ string match "$pattern" $result ] {
+    if { [regexp -- "$pattern" $result] } {
        return 1
    } else {
        return 0
@@ -30,6 +47,19 @@ proc lib_ret_test { cmd arglist val } {
    }
}

+# 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 }
+    } else {
+       if { $result } { return 0 } else { return 1 }
+    }
+}
+
#
# This runs a standard test for a proc. The list is set up as:
# |test proc|proc being tested|args|pattern|message|
@@ -37,6 +67,8 @@ proc lib_ret_test { cmd arglist val } {
#
proc run_tests { tests } {
    foreach test $tests {
+       # skip comments in test lists
+       if { [lindex $test 0] eq "#" } { continue }
        set result [eval [lrange $test 0 3]]
        switch -- $result {
            "-1" {
diff --git a/testsuite/runtest.all/utils.test b/testsuite/runtest.all/utils.test
index 22356b4..878e601 100644
--- a/testsuite/runtest.all/utils.test
+++ b/testsuite/runtest.all/utils.test
@@ -24,60 +24,46 @@ if [ file exists $file] {

# Test getdirs:
#
-if [lib_pat_test "getdirs" {"${srcdir}/runtest.all"} "runtest.all/topdir" ] {
-    puts "FAILED: getdirs toplevel, no arguments"
-} else {
-    puts "PASSED: getdirs toplevel, no arguments"
-}
-
-if [lib_pat_test "getdirs" {"${srcdir}/runtest.all top*"} "runtest.all/topdir" 
] {
-    puts "FAILED: getdirs toplevel, one subdir"
-} else {
-    puts "PASSED: getdirs toplevel, one subdir"
-}
-
-if [lib_pat_test "getdirs" {"${srcdir}/runtest.all/topdir"} "subdir1*subdir2" 
] {
-    puts "FAILED: getdirs toplevel, two subdirs"
-} else {
-    puts "PASSED: getdirs toplevel, two subdirs"
-}
+run_tests [subst {
+    { lib_pat_test getdirs
+       {[file join ${srcdir} runtest.all]}
+       [file join ${srcdir} runtest.all topdir]
+       "getdirs toplevel, no arguments" }
+    { lib_pat_test getdirs
+       {[file join ${srcdir} runtest.all] "top*"}
+       [file join ${srcdir} runtest.all topdir]
+       "getdirs toplevel, one subdir" }
+    { lib_pat_test getdirs
+       {[file join ${srcdir} runtest.all topdir]}
+       "*topdir*subdir1*topdir*subdir2"
+       "getdirs toplevel, two subdirs" }
+}]

# Test relative_filename:
#
-if { [relative_filename "/foo/test" "/foo/test/bar/baz" ] == "bar/baz" } {
-    puts "PASSED: relative_filename, simple prefix"
-} else {
-    puts "FAILED: relative_filename, simple prefix"
-}
-if { [relative_filename "/foo/test" "/bar/test" ] == "../../bar/test" } {
-    puts "PASSED: relative_filename, up to top"
-} else {
-    puts "FAILED: relative_filename, up to top"
-}
-if { [relative_filename "/tmp/foo-test" "/tmp/bar/test" ] == "../bar/test" } {
-    puts "PASSED: relative_filename, up one level"
-} else {
-    puts "FAILED: relative_filename, up one level"
-}
-if { [relative_filename "/tmp/foo-test" "/tmp/foo-test" ] == "" } {
-    puts "PASSED: relative_filename, same name"
-} else {
-    puts "FAILED: relative_filename, same name"
+run_tests {
+    { lib_ret_test relative_filename {"/foo/test" "/foo/test/bar/baz"} 
"bar/baz"
+       "relative_filename, simple prefix" }
+    { lib_ret_test relative_filename {"/foo/test" "/bar/test"} "../../bar/test"
+       "relative_filename, up to top" }
+    { lib_ret_test relative_filename {"/tmp/foo-test" "/tmp/bar/test"} 
"../bar/test"
+       "relative_filename, up one level" }
+    { lib_ret_test relative_filename {"/tmp/foo-test" "/tmp/foo-test"} ""
+       "relative_filename, same name" }
}

# Test find:
#
-if [string match "*/subdir2/subfile2" "[find ${srcdir}/runtest.all/topdir/subdir2 
sub*]"] {
-    puts "PASSED: find, only one level deep"
-} else {
-    puts "FAILED: find, only one level deep"
-}
-
-if [regexp ".*/subdir1/subsubdir1/subsubfile1( |$)" "[find 
${srcdir}/runtest.all/topdir/subdir1 sub*]"] {
-    puts "PASSED: find, two levels deep"
-} else {
-    puts "FAILED: find, two  levels deep"
-}
+run_tests [subst {
+    { lib_pat_test find
+       {[file join ${srcdir} runtest.all topdir subdir2] "sub*"}
+       "*/subdir2/subfile2"
+       "find, only one level deep" }
+    { lib_regexp_test find
+       {[file join ${srcdir} runtest.all topdir subdir1] "sub*"}
+       ".*/subdir1/subsubdir1/subsubfile1( |$)"
+       "find, two levels deep" }
+}]

# Environment varible utility tests.
#
@@ -215,26 +201,13 @@ file delete -force diff1.txt diff2.txt

# Test runtest_file_p.

-if {[runtest_file_p {foo.exp} foo.c]} {
-  pass "runtest_file_p, bare foo.exp matches foo.c"
-} else {
-  fail "runtest_file_p, bare foo.exp matches foo.c"
-}
-
-if {[runtest_file_p {foo.exp foo.c} foo.c]} {
-  pass "runtest_file_p, foo.exp=foo.c matches foo.c"
-} else {
-  fail "runtest_file_p, foo.exp=foo.c matches foo.c"
-}
-
-if {[runtest_file_p {foo.exp foo.*} foo.c]} {
-  pass "runtest_file_p, foo.exp=foo.* matches foo.c"
-} else {
-  fail "runtest_file_p, foo.exp=foo.* matches foo.c"
-}
-
-if {![runtest_file_p {foo.exp bar.*} foo.c]} {
-  pass "runtest_file_p, foo.exp=bar.* excludes foo.c"
-} else {
-  fail "runtest_file_p, foo.exp=bar.* excludes foo.c"
+run_tests {
+    { lib_bool_test runtest_file_p {{foo.exp} foo.c} true
+       "runtest_file_p, bare foo.exp matches foo.c" }
+    { lib_bool_test runtest_file_p {{foo.exp foo.c} foo.c} true
+       "runtest_file_p, foo.exp=foo.c matches foo.c" }
+    { lib_bool_test runtest_file_p {{foo.exp foo.*} foo.c} true
+       "runtest_file_p, foo.exp=foo.* matches foo.c" }
+    { lib_bool_test runtest_file_p {{foo.exp bar.*} foo.c} false
+       "runtest_file_p, foo.exp=bar.* excludes foo.c" }
}
----


-- Jacob