mirror of
https://sourceware.org/git/binutils-gdb.git
synced 2024-12-03 04:12:10 +08:00
* 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.
This commit is contained in:
Daniel Jacobowitz
parent
509ec96a3e
commit
2307bd6a50
@ -1,3 +1,10 @@
|
||||
2003-01-22 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.
|
||||
|
||||
2003-01-20 Elena Zannoni <ezannoni@redhat.com>
|
||||
|
||||
* gdb.arch/altivec-abi.exp: Set variable 'srcfile' differently, to
|
||||
|
||||
@ -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;
|
||||
}
|
||||
}]
|
||||
}
|
||||
|
||||
# Test that a command gives an error. For pass or fail, return
|
||||
# a 1 to indicate that more tests can proceed. However a timeout
|
||||
|
||||
Loading…
Reference in New Issue
Block a user