[RFA/testsuite] Re: RFC: gdb_test_multiple

[Daniel Jacobowitz <drow at mvista dot com>]

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;
+	}
+     }]
+}
 
 # Test that a command gives an error.  For pass or fail, return
 # a 1 to indicate that more tests can proceed.  However a timeout