diff options
| -rw-r--r-- | ChangeLog | 35 | ||||
| -rw-r--r-- | NEWS | 29 | ||||
| -rw-r--r-- | doc/dejagnu.texi | 68 | ||||
| -rw-r--r-- | lib/framework.exp | 131 | ||||
| -rw-r--r-- | testsuite/runtest.libs/testcase_group.test | 61 | ||||
| -rw-r--r-- | testsuite/runtest.libs/testsuite_can.test | 29 |
6 files changed, 338 insertions, 15 deletions
@@ -70,6 +70,41 @@ * config/unix.exp (unix_load): Prepend the value of an "exec_shell" board_info key to the command if it is defined. +2020-06-06 Jacob Bachmeyer <jcb62281+dev@gmail.com> + + * NEWS: Document "testcase" command. + + * doc/dejagnu.texi (testcase procedure): Document multiplex entry + point and "testcase group" command. + + * lib/framework.exp: Add internal namespace ::dejagnu::group. + (::dejagnu::group::check_name): New procedure. + (::dejagnu::group::current): New procedure. + (::dejagnu::group::push): New procedure. + (::dejagnu::group::pop): New procedure. + (::dejagnu::group::pop_to_file): New procedure. + (testcase): New procedure for multiplex commands. + (testcase_group): New procedure implementing "testcase group". + + * testsuite/runtest.libs/testcase_group.test: New file. + +2020-06-05 Jacob Bachmeyer <jcb62281+dev@gmail.com> + + * NEWS: Document new "testsuite can call api" command. + + * doc/dejagnu.texi (testsuite procedure): Document new subcommand + "testsuite can call api". + + * lib/framework.exp (testsuite): Add branch for "testsuite can". + (testsuite_can): New procedure implementing "testsuite can". + + Add internal array ::dejagnu::apilist to store information for + "testsuite can call api" for querying the availability of an API + call. This will allow test scripts to adapt and use new features + while still being able to run under older versions of DejaGnu. + + * testsuite/runtest.libs/testsuite_can.test: New file. + 2020-06-02 Jacob Bachmeyer <jcb62281+dev@gmail.com> PR 41647 @@ -19,17 +19,24 @@ X. The target_compile procedure now accepts a "linker=" option that overrides the compiler selection when producing an executable. X. The internal default_target_compile procedure now supports compiling sources in Go (using GCC Go) and Rust. -7. A shell command "dejagnu" is added as a place to hang various - auxiliary commands not directly involved with running tests. The - "runtest" command will remain for that purpose for the foreseeable - future. -8. The first auxiliary command is added: "report card". The "dejagnu - report card" command reads DejaGnu summary files and produces a - compact tabular summary across multiple tools. -9. A Tcl namespace is now used for some internal procedures and variables. - The Tcl namespace ::dejagnu and all child namespaces are entirely - internal and should not be mentioned in testsuite code. Its contents - are subject to change without notice, even on point releases. +7. A command "testsuite can call api" is added to report the availability + of multiplexed API calls. +8. A new multiplex procedure "testcase" is added for commands + examining or manipulating the dynamic state of ongoing testing. +9. A command "testcase group" is provided for reporting test groups to the + DejaGnu core. Currently, the usage of this command is validated, but it + will affect at least XML output in a future release of DejaGnu. +10. A shell command "dejagnu" is added as a place to hang various + auxiliary commands not directly involved with running tests. The + "runtest" command will remain for that purpose for the foreseeable + future. +11. The first auxiliary command is added: "report card". The "dejagnu + report card" command reads DejaGnu summary files and produces a + compact tabular summary across multiple tools. +12. A Tcl namespace is now used for some internal procedures and variables. + The Tcl namespace ::dejagnu and all child namespaces are entirely + internal and should not be mentioned in testsuite code. Its contents + are subject to change without notice, even on point releases. Changes since 1.6.1: diff --git a/doc/dejagnu.texi b/doc/dejagnu.texi index fa03a07..85b2f58 100644 --- a/doc/dejagnu.texi +++ b/doc/dejagnu.texi @@ -2600,6 +2600,7 @@ DejaGnu provides these Tcl procedures. * verbose Procedure: verbose procedure * load_lib Procedure: load_lib procedure * testsuite Procedure: testsuite procedure +* testcase procedure: testcase procedure @end menu @node open_logs procedure, close_logs procedure, , Core Internal Procedures @@ -3181,7 +3182,7 @@ lappend libdirs $srcdir/../../gcc/testsuite/lib load_lib foo.exp @end example -@node testsuite procedure, , load_lib procedure, Core Internal Procedures +@node testsuite procedure, testcase procedure, load_lib procedure, Core Internal Procedures @subsubheading testsuite Procedure @findex testsuite @@ -3234,6 +3235,67 @@ implied by the returned value will exist upon return. Implied directories are created in the object tree if needed. An error is raised if an implied directory does not exist in the source tree. +@subsubheading testsuite can call api + +The @code{testsuite can call api} command is a feature test and +returns a boolean value indicating if a subcommand under a multiplex +point is available. This API call is needed because only the +multiplex points themselves are visible to the Tcl info command. + +@quotation +@t{ @b{testsuite can call api} @i{feature}... } +@end quotation + +Any number of words are joined together into a single name, beginning +with a multiplex entry point and forming the full name of an API call +as documented in this manual. + +@node testcase procedure, , testsuite procedure, Core Internal Procedures +@subsubheading testcase Procedure + +The @code{testcase} procedure is a multiplex call for retrieving or +providing information about the state of the testing process. + +@subsubheading testcase group + +The @code{testcase group} command provides support for grouping tests +into hierarchical groups within a test script. + +Group names are internally tracked as Tcl lists, but are reported as +strings delimited using forward slash (@samp{/}) characters. +Individual name elements may not contain whitespace, but may contain +forward slash. A group entered by traversing intermediate levels must +be left by traversing those same levels. Groups must properly nest. + +There are three uses: + +@quotation +@t{ @b{testcase group}} +@end quotation + +Return the current group as a string delimited with forward slash +(@samp{/}) characters. + +@quotation +@t{ @b{testcase group begin} @i{name}} +@end quotation +@quotation +@t{ @b{testcase group end} @i{name}} +@end quotation + +These forms allow a group to be explicitly entered and left. The +@i{name} parameter must be identical across a pair of these calls, and +both the @code{begin} and @code{end} calls must be in the same file. + +@quotation +@t{ @b{testcase group eval} @i{name} @{@i{code}@}} +@end quotation + +This form is available to wrap the @code{begin} and @code{end} calls +around the execution of the provided @i{code}. This form is preferred +for convenience in top-level scripts, but the @code{begin} and +@code{end} calls are preferred in helper procedures for performance. + @node Procedures For Remote Communication, connprocs, Core Internal Procedures, Built-in Procedures @section Procedures For Remote Communication @@ -5900,5 +5962,5 @@ This makes @code{runtest} exit. Abbreviation: @kbd{q}. @c LocalWords: subdirectory prepend prepended testsuite filename Expect's svn @c LocalWords: DejaGnu CVS RCS SCCS prepending subcommands Tcl Awk Readline -@c LocalWords: POSIX KFAIL KPASS XFAIL XPASS hostname multitable gfortran -@c LocalWords: rustc executables +@c LocalWords: POSIX KFAIL KPASS XFAIL XPASS hostname multitable gfortran api +@c LocalWords: boolean subcommand testcase eval rustc executables diff --git a/lib/framework.exp b/lib/framework.exp index e6ce197..6d7cf4d 100644 --- a/lib/framework.exp +++ b/lib/framework.exp @@ -16,7 +16,60 @@ # along with DejaGnu; if not, write to the Free Software Foundation, # Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA. -# This file was written by Rob Savoye <rob@welcomehome.org>. +# This file was originally written by Rob Savoye <rob@welcomehome.org>. + +## Internal infrastructure + +namespace eval ::dejagnu::group { + variable names [list] + variable files [list] +} + +proc ::dejagnu::group::check_name { name } { + return [string is graph -strict $name] +} + +proc ::dejagnu::group::current {} { + variable names + return [join $names "/"] +} + +proc ::dejagnu::group::push { name file } { + variable names + variable files + lappend names $name + lappend files $file +} +proc ::dejagnu::group::pop { name file } { + variable names + variable files + + if { $file ne [lindex $files end] + || $name ne [lindex $names end] } { + error "expected to close group {$name} from {$file}\n\ + actually found group {[lindex $names end]}\ + from {[lindex $files end]}" + } else { + set names [lreplace $names end end] + set files [lreplace $files end end] + } +} +proc ::dejagnu::group::pop_to_file { file } { + variable names + variable files + + while { $file ne [lindex $files end] } { + perror "closing forgotten group {[::dejagnu::group::current]}\ + from {[lindex $files end]}" 0 + set names [lreplace $names end end] + set files [lreplace $files end end] + if { [llength $names] < 1 } { + error "no more groups while unwinding to file $file" + } + } +} + +## General code; not yet sorted under headings # These variables are local to this file. # This or more warnings and a test fails. @@ -1019,10 +1072,30 @@ proc incr_count { name args } { proc testsuite { subcommand args } { if { $subcommand eq "file" } { testsuite_file $args + } elseif { $subcommand eq "can" } { + testsuite_can $args } else { error "unknown \"testsuite\" command: testsuite $subcommand $args" } } +namespace eval ::dejagnu {} + +# Feature test +# +proc testsuite_can { argv } { + verbose "entering testsuite can $argv" 3 + + if { [lrange $argv 0 1] eq "call api" } { + set call [lrange $argv 2 end] + set result [info exists ::dejagnu::apilist($call)] + } else { + error "unknown feature test: testsuite can $argv" + } + + verbose "leaving testsuite can: $result" 3 + return $result +} +array set ::dejagnu::apilist { {testsuite can call api} 1 } # Return a full file name in or near the testsuite # @@ -1075,3 +1148,59 @@ proc testsuite_file { argv } { verbose "leaving testsuite file: $result" 3 return $result } +array set ::dejagnu::apilist { {testsuite file} 1 } + +# Return or provide information about the current dynamic state. (multiplex) +# +proc testcase { subcommand args } { + if { $subcommand eq "group" } { + testcase_group $args + } else { + error "unknown \"testcase\" command: testcase $subcommand $args" + } +} + +# Indicate group boundaries or return current group +# +proc testcase_group { argv } { + verbose "entering testcase group $argv" 3 + set argc [llength $argv] + + if { $argc == 0 } { + set result [::dejagnu::group::current] + } else { + set what [lindex $argv 0] + set name [lindex $argv 1] + + if { $what eq "begin" } { + if { ![::dejagnu::group::check_name $name] } { + error "group name '$name' is not valid" + } + ::dejagnu::group::push $name [uplevel 2 info script] + set result $name + } elseif { $what eq "end" } { + if { ![::dejagnu::group::check_name $name] } { + error "group name '$name' is not valid" + } + ::dejagnu::group::pop $name [uplevel 2 info script] + set result $name + } elseif { $what eq "eval" } { + if { ![::dejagnu::group::check_name $name] } { + error "group name '$name' is not valid" + } + ::dejagnu::group::push $name [uplevel 2 info script] + set result [uplevel 2 [lindex $argv 2]] + ::dejagnu::group::pop $name [uplevel 2 info script] + } else { + error "unknown group operation: testcase group $argv" + } + } + + verbose "leaving testcase group: $result" 3 + return $result +} +array set ::dejagnu::apilist { + {testcase group} 1 + {testcase group begin} 1 {testcase group end} 1 + {testcase group eval} 1 +} diff --git a/testsuite/runtest.libs/testcase_group.test b/testsuite/runtest.libs/testcase_group.test new file mode 100644 index 0000000..e524744 --- /dev/null +++ b/testsuite/runtest.libs/testcase_group.test @@ -0,0 +1,61 @@ +# test "testcase group" API call -*- Tcl -*- + +if [ file exists $srcdir/$subdir/default_procs.tcl ] { + source "$srcdir/$subdir/default_procs.tcl" +} else { + puts "ERROR: $srcdir/$subdir/default_procs.tcl doesn't exist" +} +if [ file exists $srcdir/../lib/framework.exp] { + source $srcdir/../lib/framework.exp +} else { + puts "ERROR: $srcdir/../lib/framework.exp doesn't exist" +} + +# test group handling + +run_tests { + { lib_errpat_test testcase { group bogus-command } + "*unknown*bogus-command*" + "reject bogus group operation" } + { lib_errpat_test testcase { group begin "no spaces in group names" } + "*spaces in group names*is not valid*" + "reject entering group with spaces in name" } + + { lib_ret_test testcase { group } "" + "initially in no group" } + { lib_ret_test testcase { group begin foo } "foo" + "enter group 'foo'" } + { lib_ret_test testcase { group } "foo" + "now in group 'foo'" } + { lib_ret_test testcase { group begin bar } "bar" + "enter group 'bar' (foo/bar)" } + { lib_ret_test testcase { group } "foo/bar" + "now in group 'foo/bar'" } + { lib_errpat_test testcase { group end foo } + "*expected to close group*foo*found group*bar*" + "error on mismatch leaving 'foo' in 'foo/bar'" } + { lib_errpat_test testcase { group end "foo/bar" } + "*expected to close group*foo/bar*found group*bar*" + "error on mismatch leaving 'foo/bar'" } + { lib_ret_test testcase { group end bar } "bar" + "leave group 'bar' (foo)" } + { lib_ret_test testcase { group } "foo" + "back in group 'foo'" } + { lib_ret_test testcase { group begin "baz/bar" } "baz/bar" + "enter group 'baz/bar' (foo/baz/bar)" } + { lib_ret_test testcase { group } "foo/baz/bar" + "now in group 'foo/baz/bar'" } + { lib_ret_test testcase { group eval "quux" {testcase group} } + "foo/baz/bar/quux" + "group 'foo/baz/bar/quux' entered for eval" } + { lib_ret_test testcase { group } "foo/baz/bar" + "still in group 'foo/baz/bar' after eval" } + { lib_ret_test testcase { group end "baz/bar" } "baz/bar" + "leave group 'baz/bar' (foo)" } + { lib_ret_test testcase { group end foo } "foo" + "leave group 'foo'" } + { lib_ret_test testcase { group } "" + "finally in no group" } +} + +puts "END testcase_group.test" diff --git a/testsuite/runtest.libs/testsuite_can.test b/testsuite/runtest.libs/testsuite_can.test new file mode 100644 index 0000000..98d4e38 --- /dev/null +++ b/testsuite/runtest.libs/testsuite_can.test @@ -0,0 +1,29 @@ +# test "testsuite can" API call -*- Tcl -*- + +if [ file exists $srcdir/$subdir/default_procs.tcl ] { + source "$srcdir/$subdir/default_procs.tcl" +} else { + puts "ERROR: $srcdir/$subdir/default_procs.tcl doesn't exist" +} +if [ file exists $srcdir/../lib/framework.exp] { + source $srcdir/../lib/framework.exp +} else { + puts "ERROR: $srcdir/../lib/framework.exp doesn't exist" +} + +# API availability check tests + +run_tests { + { lib_errpat_test testsuite { can } + "*unknown feature test*" + "testsuite can without arguments" } + { lib_errpat_test testsuite { can call } + "*unknown feature test*" + "testsuite can call without 'api'" } + { lib_bool_test testsuite { can call api } false + "testsuite can call api returns false for null API call name" } + { lib_bool_test testsuite { can call api testsuite can call api } true + "testsuite can call api reports its own existence" } +} + +puts "END testsuite_can.test" |