diff options
author | Jacob Bachmeyer <jcb62281+dev@gmail.com> | 2020-07-06 21:04:07 -0500 |
---|---|---|
committer | Jacob Bachmeyer <jcb62281+dev@gmail.com> | 2020-07-06 21:04:07 -0500 |
commit | 376dacc26259cbd61860d58a3ec16099d5b7581f (patch) | |
tree | 7a39a88df6cae6513a3592b55b164422c5aa6b00 /lib | |
parent | e572af7e43e26162a717408c2464cad24c936d07 (diff) | |
parent | 8c750f7449bd33cb8952e8ddbb3cc5cecaa05bb3 (diff) | |
download | dejagnu-376dacc26259cbd61860d58a3ec16099d5b7581f.zip dejagnu-376dacc26259cbd61860d58a3ec16099d5b7581f.tar.gz dejagnu-376dacc26259cbd61860d58a3ec16099d5b7581f.tar.bz2 |
Merge branch 'new-api-for-1.6.3'
Conflicts:
ChangeLog
NEWS
doc/dejagnu.texi
Diffstat (limited to 'lib')
-rw-r--r-- | lib/framework.exp | 131 |
1 files changed, 130 insertions, 1 deletions
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 +} |