-# 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"
}
}
}
}
- 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 {
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"
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 {
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 {
set errmsg "$command: the program is no longer running"
}
fail "$errmsg"
- return -1
+ set result -1
}
-re ".*$gdb_prompt $" {
if ![string match "" $message] then {
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"
full_buffer {
perror "internal buffer is full."
fail "$message"
+ set result -1
}
timeout {
if ![string match "" $message] then {
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
projects / external / binutils.git / commitdiff