Add "testcase group" API

5 files changed, 249 insertions, 11 deletions

diff --git a/ChangeLog b/ChangeLog
index a6aedc6..15db9b2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,21 @@
+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.
diff --git a/NEWS b/NEWS
index 6111903..8e8968a 100644
--- a/NEWS
+++ b/NEWS
@@ -17,14 +17,19 @@ Changes since 1.6.2:
    "*dir" variables in test scripts.
 7. A command "testsuite can call api" is added to report the availability
    of multiplexed API calls.
-8. 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.
-9. 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.
-10. A Tcl namespace is now used for some internal procedures and variables.
+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.
diff --git a/doc/dejagnu.texi b/doc/dejagnu.texi
index cafb531..47a3ed7 100644
--- a/doc/dejagnu.texi
+++ b/doc/dejagnu.texi
@@ -3181,7 +3181,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
 
@@ -3249,6 +3249,52 @@ 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
 
@@ -5855,4 +5901,4 @@ 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 api
-@c  LocalWords:  boolean subcommand
+@c  LocalWords:  boolean subcommand testcase eval
diff --git a/lib/framework.exp b/lib/framework.exp
index e0f2ee6..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.
@@ -1096,3 +1149,58 @@ proc testsuite_file { argv } {
     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"