This is the mail archive of the gdb-patches@sources.redhat.com mailing list for the GDB project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

RFC: gdb_test_multiple


After a duel with TCL, I return triumphant (but seriously injured; I took a
blow to the head that may never heal...).  This patch adds a new function
gdb_test_multiple, which works like this:

gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" {
  -re "Breakpoint at .*\[\r\n\]$gdb_prompt $" {
    pass "$_gdb_message"
  }
  -re "Explode!" {
    fail "$_gdb_message (gdb/90210)"
  }
  -re "Bang." {
    kfail "gdb/90211" "$_gdb_message"
  }
}

That represents a problem, for which two PRs were filed, one of which is
currently KFAIL'd and the other of which we believe is fixed.  How's it look
to everyone?

It does one truly gross thing, by the way.  See the _gdb_message bit?  That,
_gdb_command, and _gdb_result are set in the caller's scope.  This is
because of certain quoting limitations in TCL which prevented me from doing
it any better way.  It's ironic; the language has no form of lindex which
does not perform backslash escaping, and no way to get items out of a list
without stripping their outer "" or {}.  A friend of mine got so fed up with
TCL that he rewrote DejaGNU in Perl, which he's planning to publish in the
next couple of weeks.  I can see why.

The grossness doesn't affect gdb_test since gdb_test doesn't uplevel the
call to gdb_standard_expect; it's only something to be aware of for new uses
of gdb_test_multiple.

I'm going to sit on this patch until Tuesday, for comments about both the
interface and the implementation; ideas welcome.  After that I plan to
commit it so that Michael C can go wild using it.  The committed version
will include a comment update that I forgot in the below, clarifying that
you do need the "-re" bit just like gdb_expect.

-- 
Daniel Jacobowitz
MontaVista Software                         Debian GNU/Linux Developer

2003-01-04  Daniel Jacobowitz  <drow@mvista.com>

	* lib/gdb.exp (gdb_standard_expect, gdb_standard_send): New
	functions, broken out from gdb_test.  Display the TCL errorInfo
	in the expect error/eof block if set.
	(gdb_test): Use them.
	(gdb_test_multiple): New function.

Index: lib/gdb.exp
===================================================================
RCS file: /cvs/src/src/gdb/testsuite/lib/gdb.exp,v
retrieving revision 1.30
diff -u -p -r1.30 gdb.exp
--- lib/gdb.exp	16 Dec 2002 19:33:54 -0000	1.30
+++ lib/gdb.exp	4 Jan 2003 20:03:06 -0000
@@ -1,4 +1,5 @@
-# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000
+# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+# 2002, 2003
 # Free Software Foundation, Inc.
 
 # This program is free software; you can redistribute it and/or modify
@@ -358,56 +359,12 @@ proc gdb_continue_to_breakpoint {name} {
     }
 }
 
-
-
-# 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$"
-    }
-
-    if $verbose>2 then {
-	send_user "Sending \"$command\" to gdb\n"
-	send_user "Looking to match \"$pattern\"\n"
-	send_user "Message is \"$message\"\n"
-    }
-
-    set result -1
+### gdb_standard_send COMMAND MESSAGE
+###
+### Send a (possibly multiline) COMMAND to GDB.  If an error is
+### encountered, fail with MESSAGE.  This is an internal helper
+### for gdb_test and should not be used from testcases.
+proc gdb_standard_send { command message } {
     set string "${command}\n";
     if { $command != "" } {
 	while { "$string" != "" } {
@@ -422,7 +379,7 @@ proc gdb_test { args } {
 			perror "Couldn't send $command to GDB.";
 		    }
 		    fail "$message";
-		    return $result;
+		    return -1;
 		}
 		# since we're checking if each line of the multi-line
 		# command are 'accepted' by GDB here,
@@ -446,11 +403,28 @@ proc gdb_test { args } {
 		    perror "Couldn't send $command to GDB.";
 		}
 		fail "$message";
-		return $result;
+		return -1;
 	    }
 	}
     }
+    return 0
+}
+
+### gdb_standard_expect COMMAND MESSAGE CODE
+###
+### Like gdb_expect, but also matching a set of standard patterns.
+### This plays games with uplevel, so the variables _GDB_COMMAND, _GDB_MESSAGE,
+### and _GDB_RESULT will be set in the calling procedure.  GDB_PROMPT will be
+### globalized in the above procedure, also.
+### The return value is whatever gets assigned to _GDB_RESULT.
+### This is an internal helper for gdb_test and gdb_test_multiple and should not
+### be called directly.
+proc gdb_standard_expect {command message code} {
+    global errorInfo
+    set errorInfo ""
 
+    # Infer a timeout.
+    uplevel {if {[info exists timeout]} { } else { upvar timeout timeout }}
     if [target_info exists gdb,timeout] {
 	set tmt [target_info gdb,timeout];
     } else {
@@ -465,104 +439,234 @@ proc gdb_test { args } {
 	    }
 	}
     }
-    gdb_expect $tmt {
-	 -re "\\*\\*\\* DOSEXIT code.*" {
-	     if { $message != "" } {
-		 fail "$message";
-	     }
-	     gdb_suppress_entire_file "GDB died";
-	     return -1;
-	 }
-	 -re "Ending remote debugging.*$gdb_prompt $" {
+
+    set before {
+	-re "\\*\\*\\* DOSEXIT code.*" {
+	    if { $_gdb_message != "" } {
+		fail "$_gdb_message";
+	    }
+	    gdb_suppress_entire_file "GDB died";
+	    set _gdb_result -1;
+	}
+	-re "Ending remote debugging.*$gdb_prompt $" {
 	    if ![isnative] then {
 		warning "Can`t communicate to remote target."
 	    }
 	    gdb_exit
 	    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;
-	}
-	 -re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
-	    perror "Undefined command \"$command\"."
-            fail "$message"
-	    set result 1
-	}
-	 -re "Ambiguous command.*$gdb_prompt $" {
-	    perror "\"$command\" is not a unique command name."
-            fail "$message"
-	    set result 1
+	    set _gdb_result -1
 	}
-	 -re "Program exited with code \[0-9\]+.*$gdb_prompt $" {
-	    if ![string match "" $message] then {
-		set errmsg "$message: the program exited"
+    }
+    set after {
+	-re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
+	    perror "Undefined command \"$_gdb_command\"."
+	    fail "$_gdb_message"
+	    set _gdb_result 1
+	}
+	-re "Ambiguous command.*$gdb_prompt $" {
+	    perror "\"$_gdb_command\" is not a unique command name."
+	    fail "$_gdb_message"
+	    set _gdb_result 1
+	}
+	-re "Program exited with code \[0-9\]+.*$gdb_prompt $" {
+	    if ![string match "" $_gdb_message] then {
+		set _gdb_errmsg "$_gdb_message: the program exited"
 	    } else {
-		set errmsg "$command: the program exited"
+		set _gdb_errmsg "$_gdb_command: the program exited"
 	    }
-	    fail "$errmsg"
-	    return -1
+	    fail "$_gdb_errmsg"
+	    set _gdb_result -1
 	}
-	 -re "EXIT code \[0-9\r\n\]+Program exited normally.*$gdb_prompt $" {
-	    if ![string match "" $message] then {
-		set errmsg "$message: the program exited"
+	-re "EXIT code \[0-9\r\n\]+Program exited normally.*$gdb_prompt $" {
+	    if ![string match "" $_gdb_message] then {
+		set _gdb_errmsg "$_gdb_message: the program exited"
 	    } else {
-		set errmsg "$command: the program exited"
+		set _gdb_errmsg "$_gdb_command: the program exited"
 	    }
-	    fail "$errmsg"
-	    return -1
+	    fail "$_gdb_errmsg"
+	    set _gdb_result -1
 	}
-	 -re "The program is not being run.*$gdb_prompt $" {
-	    if ![string match "" $message] then {
-		set errmsg "$message: the program is no longer running"
+	-re "The program is not being run.*$gdb_prompt $" {
+	    if ![string match "" $_gdb_message] then {
+		set _gdb_errmsg "$_gdb_message: the program is no longer running"
 	    } else {
-		set errmsg "$command: the program is no longer running"
+		set _gdb_errmsg "$_gdb_command: the program is no longer running"
 	    }
-	    fail "$errmsg"
-	    return -1
+	    fail "$_gdb_errmsg"
+	    set _gdb_result -1
 	}
-	 -re ".*$gdb_prompt $" {
-	    if ![string match "" $message] then {
-		fail "$message"
+	-re ".*$gdb_prompt $" {
+	    if ![string match "" $_gdb_message] then {
+		fail "$_gdb_message"
 	    }
-	    set result 1
+	    set _gdb_result 1
 	}
-	 "<return>" {
+	"<return>" {
 	    send_gdb "\n"
 	    perror "Window too small."
-            fail "$message"
+	    fail "$_gdb_message"
 	}
-	 -re "\\(y or n\\) " {
+	-re "\\(y or n\\) " {
 	    send_gdb "n\n"
 	    perror "Got interactive prompt."
-            fail "$message"
+	    fail "$_gdb_message"
 	}
-	 eof {
-	     perror "Process no longer exists"
-	     if { $message != "" } {
-		 fail "$message"
-	     }
-	     return -1
+	eof {
+	    global errorInfo
+	    if {[info exists errorInfo] && $errorInfo != ""} {
+		perror "TCL error: $errorInfo"
+	    } else {
+		perror "Process no longer exists"
+	    }
+	    if { $_gdb_message != "" } {
+		 fail "$_gdb_message"
+	    }
+	    set _gdb_result -1
 	}
-	 full_buffer {
+	full_buffer {
 	    perror "internal buffer is full."
-            fail "$message"
+	    fail "$_gdb_message"
 	}
 	timeout	{
+	    if ![string match "" $_gdb_message] then {
+		fail "$_gdb_message (timeout)"
+	    }
+	    set _gdb_result 1
+	}
+    }
+
+    upvar _gdb_result _gdb_result
+    set _gdb_result 0
+
+    set body "gdb_expect $tmt {[concat $before $code $after]}"
+
+    # We need to get _gdb_message and _gdb_command into the namespace above
+    # us.  There's no good way to do this in TCL; this will work as long
+    # as they don't have unbalanced braces.
+    uplevel "set _gdb_message {$message}"
+    uplevel "set _gdb_command {$command}"
+
+    uplevel "global gdb_prompt"
+    uplevel $body
+
+    return $_gdb_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$"
+    }
+
+    if $verbose>2 then {
+	send_user "Sending \"$command\" to gdb\n"
+	send_user "Looking to match \"$pattern\"\n"
+	send_user "Message is \"$message\"\n"
+    }
+
+    set result [gdb_standard_send $command $message]
+    if {$result == -1} {
+	return -1
+    }
+
+    gdb_standard_expect $command $message {
+	-re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
 	    if ![string match "" $message] then {
-		fail "$message (timeout)"
+		pass "$message"
 	    }
-	    set result 1
+	    set _gdb_result 0
+	}
+	 -re "(${question_string})$" {
+	    send_gdb "$response_string\n";
+	    exp_continue;
 	}
     }
-    return $result
+
+    return $_gdb_result
+}
+
+# gdb_test_multiple COMMAND MESSAGE {PATTERN RESPONSE [PATTERN 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.
+# MESSAGE is a message to be printed in pass/fail responses.  If this is
+#   the empty string then the pass/fail messages use the command string as the
+#   message.
+# For each following pair in the third list:
+#  PATTERN is the complete pattern to match for a PASS.  Unlike for gdb_test,
+#    this pattern should include the \r\n sequence and final prompt.
+#  RESPONSE is a block of code to be executed for PATTERN.  The code will
+#    be executed in the context of the caller; _GDB_COMMAND and _GDB_MESSAGE
+#    are available in the block, and setting _GDB_RESULT will control the
+#     return value of gdb_test_multiple.
+#
+# Note that _GDB_COMMAND, _GDB_MESSAGE, and _GDB_RESULT are set in the caller's
+# scope; see gdb_standard_expect.
+#
+# Returns:
+#    The value assigned to _GDB_RESULT if by a provided RESPONSE, if any
+#    1 if the test failed,
+#    0 if the test passes, or if a provided RESPONSE matched and did not
+#      set _GDB_RESULT.
+#   -1 if there was an internal error.
+#  
+proc gdb_test_multiple { command message code } {
+    global verbose
+    global gdb_prompt
+    global GDB
+    upvar timeout timeout
+
+    if {$message == ""} {
+	set message $command
+    }
+
+    if $verbose>2 then {
+	send_user "Sending \"$command\" to gdb\n"
+	send_user "Message is \"$message\"\n"
+    }
+
+    set result [gdb_standard_send $command $message]
+    if {$result == -1} {
+	return -1
+    }
+
+    return [uplevel gdb_standard_expect \{$command\} \{$message\} \{$code\}]
 }
 
 # Test that a command gives an error.  For pass or fail, return


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]