* [RFA/testsuite] Re: RFC: gdb_test_multiple
2003-01-07 4:33 RFC: gdb_test_multiple Michael Elizabeth Chastain
@ 2003-01-07 17:10 ` Daniel Jacobowitz
2003-01-14 19:16 ` Fernando Nasser
0 siblings, 1 reply; 5+ messages in thread
From: Daniel Jacobowitz @ 2003-01-07 17:10 UTC (permalink / raw)
To: gdb-patches; +Cc: fnasser, mec
On Mon, Jan 06, 2003 at 10:33:11PM -0600, Michael Elizabeth Chastain wrote:
> > OK. I'll have an even easier version of this done tomorrow; it has one
> > truely gruesome TCL hack in it, but that's it.
>
> I'd like to do another test spin on the new version before you commit
> it if that's all right with you. I can do a cut-down version but I'd
> like to be really sure about sourceware dejagnu because the damn things
> are subtly different, and I normally don't test with it.
Here's the version I'd like to include. I definitely need your
reaction to this patch, and Fernando's. I'd like anyone else's, too.
There's one quoting hack in it, but I don't think it's fragile.
This one is a lot more intuitive. You use it like this:
gdb_test_multiple $command $message {
-re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
if ![string match "" $message] then {
pass "$message"
}
}
-re "(${question_string})$" {
send_gdb "$response_string\n";
exp_continue;
}
}
There's no magic variable names any more. $pattern and $gdb_prompt in
this example get evaluated in the caller's context; the action blocks
get executed in the caller's context; and in general it behaves just
like expect ought to.
[That "\[\r\n\]*" is just there because it was previously in gdb_test.
Bonus points to the astute reader who can figure out why it doesn't
need to be there. Presumably the _intent_ was to use "\[\r\n\]+", so
that $pattern needed to match an entire line, but our testsuite doesn't
honor that intent, so this is a question for another day.]
Fernando, Michael, how does this look? I think it will be useful.
--
Daniel Jacobowitz
MontaVista Software Debian GNU/Linux Developer
2003-01-07 Daniel Jacobowitz <drow@mvista.com>
* gdb.exp (gdb_test_multiple): New function, cloned from
gdb_test. Accept a list of expect arguments as the third
parameter.
(gdb_test): Use it.
--- gdb.exp 2003-01-07 11:48:22.000000000 -0500
+++ gdb.exp-ver2 2003-01-07 11:54:31.000000000 -0500
@@ -364,50 +364,93 @@ proc gdb_continue_to_breakpoint {name} {
-# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
+# gdb_test_multiple COMMAND MESSAGE EXPECT_ARGUMENTS
# Send a command to gdb; test the result.
#
# COMMAND is the command to execute, send to GDB with send_gdb. If
# this is the null string no command is sent.
-# PATTERN is the pattern to match for a PASS, and must NOT include
-# the \r\n sequence immediately before the gdb prompt.
-# MESSAGE is an optional message to be printed. If this is
-# omitted, then the pass/fail messages use the command string as the
-# message. (If this is the empty string, then sometimes we don't
-# call pass or fail at all; I don't understand this at all.)
-# QUESTION is a question GDB may ask in response to COMMAND, like
-# "are you sure?"
-# RESPONSE is the response to send if QUESTION appears.
+# MESSAGE is a message to be printed with the built-in failure patterns
+# if one of them matches. If MESSAGE is empty COMMAND will be used.
+# EXPECT_ARGUMENTS will be fed to expect in addition to the standard
+# patterns. Pattern elements will be evaluated in the caller's
+# context; action elements will be executed in the caller's context.
+# Unlike patterns for gdb_test, these patterns should generally include
+# the final newline and prompt.
#
# Returns:
-# 1 if the test failed,
-# 0 if the test passes,
+# 1 if the test failed, according to a built-in failure pattern
+# 0 if only user-supplied patterns matched
# -1 if there was an internal error.
#
-proc gdb_test { args } {
+proc gdb_test_multiple { command message user_code } {
global verbose
global gdb_prompt
global GDB
upvar timeout timeout
- if [llength $args]>2 then {
- set message [lindex $args 2]
- } else {
- set message [lindex $args 0]
+ if { $message == "" } {
+ set message $command
}
- set command [lindex $args 0]
- set pattern [lindex $args 1]
- if [llength $args]==5 {
- set question_string [lindex $args 3];
- set response_string [lindex $args 4];
- } else {
- set question_string "^FOOBAR$"
- }
+ # TCL/EXPECT WART ALERT
+ # Expect does something very strange when it receives a single braced
+ # argument. It splits it along word separators and performs substitutions.
+ # This means that { "[ab]" } is evaluated as "[ab]", but { "\[ab\]" } is
+ # evaluated as "\[ab\]". But that's not how TCL normally works; inside a
+ # double-quoted list item, "\[ab\]" is just a long way of representing
+ # "[ab]", because the backslashes will be removed by lindex.
+
+ # Unfortunately, there appears to be no easy way to duplicate the splitting
+ # that expect will do from within TCL. And many places make use of the
+ # "\[0-9\]" construct, so we need to support that; and some places make use
+ # of the "[func]" construct, so we need to support that too. In order to
+ # get this right we have to substitute quoted list elements differently
+ # from braced list elements.
+
+ # We do this roughly the same way that Expect does it. We have to use two
+ # lists, because if we leave unquoted newlines in the argument to uplevel
+ # they'll be treated as command separators, and if we escape newlines
+ # we mangle newlines inside of command blocks. This assumes that the
+ # input doesn't contain a pattern which contains actual embedded newlines
+ # at this point!
+
+ regsub -all {\n} ${user_code} { } subst_code
+ set subst_code [uplevel list $subst_code]
+
+ set processed_code ""
+ set patterns ""
+ set expecting_action 0
+ foreach item $user_code subst_item $subst_code {
+ if { $item == "-n" || $item == "-notransfer" || $item == "-nocase" } {
+ lappend processed_code $item
+ continue
+ }
+ if {$item == "-indices" || $item == "-re" || $item == "-ex"} {
+ lappend processed_code $item
+ continue
+ }
+ if { $expecting_action } {
+ lappend processed_code "uplevel [list $item]"
+ set expecting_action 0
+ # Cosmetic, no effect on the list.
+ append processed_code "\n"
+ continue
+ }
+ set expecting_action 1
+ lappend processed_code $subst_item
+ if {$patterns != ""} {
+ append patterns "; "
+ }
+ append patterns "\"$subst_item\""
+ }
+
+ # Also purely cosmetic.
+ regsub -all {\r} $patterns {\\r} patterns
+ regsub -all {\n} $patterns {\\n} patterns
if $verbose>2 then {
send_user "Sending \"$command\" to gdb\n"
- send_user "Looking to match \"$pattern\"\n"
+ send_user "Looking to match \"$patterns\"\n"
send_user "Message is \"$message\"\n"
}
@@ -469,13 +512,14 @@ proc gdb_test { args } {
}
}
}
- gdb_expect $tmt {
+
+ set code {
-re "\\*\\*\\* DOSEXIT code.*" {
if { $message != "" } {
fail "$message";
}
gdb_suppress_entire_file "GDB died";
- return -1;
+ set result -1;
}
-re "Ending remote debugging.*$gdb_prompt $" {
if ![isnative] then {
@@ -485,16 +529,9 @@ proc gdb_test { args } {
gdb_start
set result -1
}
- -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
- if ![string match "" $message] then {
- pass "$message"
- }
- set result 0
- }
- -re "(${question_string})$" {
- send_gdb "$response_string\n";
- exp_continue;
- }
+ }
+ append code $processed_code
+ append code {
-re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
perror "Undefined command \"$command\"."
fail "$message"
@@ -512,7 +549,7 @@ proc gdb_test { args } {
set errmsg "$command: the program exited"
}
fail "$errmsg"
- return -1
+ set result -1
}
-re "EXIT code \[0-9\r\n\]+Program exited normally.*$gdb_prompt $" {
if ![string match "" $message] then {
@@ -521,7 +558,7 @@ proc gdb_test { args } {
set errmsg "$command: the program exited"
}
fail "$errmsg"
- return -1
+ set result -1
}
-re "The program is not being run.*$gdb_prompt $" {
if ![string match "" $message] then {
@@ -530,7 +567,7 @@ proc gdb_test { args } {
set errmsg "$command: the program is no longer running"
}
fail "$errmsg"
- return -1
+ set result -1
}
-re ".*$gdb_prompt $" {
if ![string match "" $message] then {
@@ -542,11 +579,13 @@ proc gdb_test { args } {
send_gdb "\n"
perror "Window too small."
fail "$message"
+ set result -1
}
-re "\\(y or n\\) " {
send_gdb "n\n"
perror "Got interactive prompt."
fail "$message"
+ set result -1
}
eof {
perror "Process no longer exists"
@@ -558,6 +597,7 @@ proc gdb_test { args } {
full_buffer {
perror "internal buffer is full."
fail "$message"
+ set result -1
}
timeout {
if ![string match "" $message] then {
@@ -566,8 +606,65 @@ proc gdb_test { args } {
set result 1
}
}
+
+ set result 0
+ gdb_expect $tmt $code
return $result
}
+
+# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
+# Send a command to gdb; test the result.
+#
+# COMMAND is the command to execute, send to GDB with send_gdb. If
+# this is the null string no command is sent.
+# PATTERN is the pattern to match for a PASS, and must NOT include
+# the \r\n sequence immediately before the gdb prompt.
+# MESSAGE is an optional message to be printed. If this is
+# omitted, then the pass/fail messages use the command string as the
+# message. (If this is the empty string, then sometimes we don't
+# call pass or fail at all; I don't understand this at all.)
+# QUESTION is a question GDB may ask in response to COMMAND, like
+# "are you sure?"
+# RESPONSE is the response to send if QUESTION appears.
+#
+# Returns:
+# 1 if the test failed,
+# 0 if the test passes,
+# -1 if there was an internal error.
+#
+proc gdb_test { args } {
+ global verbose
+ global gdb_prompt
+ global GDB
+ upvar timeout timeout
+
+ if [llength $args]>2 then {
+ set message [lindex $args 2]
+ } else {
+ set message [lindex $args 0]
+ }
+ set command [lindex $args 0]
+ set pattern [lindex $args 1]
+
+ if [llength $args]==5 {
+ set question_string [lindex $args 3];
+ set response_string [lindex $args 4];
+ } else {
+ set question_string "^FOOBAR$"
+ }
+
+ return [gdb_test_multiple $command $message {
+ -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
+ if ![string match "" $message] then {
+ pass "$message"
+ }
+ }
+ -re "(${question_string})$" {
+ send_gdb "$response_string\n";
+ exp_continue;
+ }
+ }]
+}
\f
# Test that a command gives an error. For pass or fail, return
# a 1 to indicate that more tests can proceed. However a timeout
^ permalink raw reply [flat|nested] 5+ messages in thread