Re: [PATCH 5/5] Make gdb_test's question non-optional if specified

[Pedro Alves <pedro@palves.net>]

On 2022-05-16 17:01, Tom Tromey wrote:
>>>>>> "Pedro" == Pedro Alves <pedro@palves.net> writes:
> 
> Pedro> gdb_test supports handling scenarios where GDB asks a question before
> Pedro> finishing handling some command.  The full prototype of gdb_test is:
> 
> Pedro>   # gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
> 
> I wonder if, after this patch, we can rewrite gdb_test to use ordinary
> arguments and not parse 'args' by itself:
> 
> Like instead of:
> 
>     set command [lindex $args 0]
>     set pattern [lindex $args 1]
> 
> Just write
> 
>     proc gdb_test {command pattern {message ""} {question ""} {response ""}}
> 
> ... and then default 'message' when appropriate.

(Note pattern is optional too.)

Maybe, but OTOH, we could instead switch to using parse_args, which would
let us support other options to gdb_test, like gdb_test_multiple's 
  [ -prompt PROMPT_REGEXP] [ -lbl ],
and whatever other options we come up in future.

We could even support

  gdb_test "command" "pattern" \
     -question "you sure\?" -response "y"

  gdb_test "command" "pattern" \
     -question "you sure\?" -response "y"

which has the advantage of not requiring you to specify $message whenever you need to supply
a question/response.  We could do both, actually, support parse_args, and keep supporting
the positional arguments.

lindex returns an empty string if the index is >= than number of elements, so we can simplify
things by checking if the positional argument is "" instead of looking at whether it was actually
passed down.  I think this removes most of the ugliness.

In the patch below I've added support for -prompt and -lbl, and one example using gdb_test -prompt,
to show better what I mean.


From 2ef20ed4a12a94a8352d16051b8d1920497348f4 Mon Sep 17 00:00:00 2001
From: Pedro Alves <pedro@palves.net>
Date: Tue, 17 May 2022 11:16:01 +0100
Subject: [PATCH] Support -prompt and -lbl in gdb_test

Change-Id: I243e1296d32c05a421ccef30b63d43a89eaeb4a0
---
 gdb/testsuite/gdb.base/ui-redirect.exp | 10 ++---
 gdb/testsuite/lib/gdb.exp              | 56 +++++++++++++++-----------
 2 files changed, 37 insertions(+), 29 deletions(-)

diff --git a/gdb/testsuite/gdb.base/ui-redirect.exp b/gdb/testsuite/gdb.base/ui-redirect.exp
index 13bc964f46c..4ed82ae63bf 100644
--- a/gdb/testsuite/gdb.base/ui-redirect.exp
+++ b/gdb/testsuite/gdb.base/ui-redirect.exp
@@ -117,12 +117,10 @@ with_test_prefix "debugging" {
     gdb_test "set logging enabled on" \
     "Copying output to /dev/null.*Copying debug output to /dev/null\\."
 
-    set prompt "$gdb_prompt \\\[infrun\\\] fetch_inferior_event: exit\r\n$"
-    gdb_test_multiple "continue" "continue" -prompt $prompt {
-	-re "Continuing.*\\\[infrun\\\] .*\\\[infrun\\\] .*Breakpoint \[0-9\]+, foo.*$prompt$" {
-	    pass $gdb_test_name
-	}
-    }
+    gdb_test \
+	-prompt "$gdb_prompt \\\[infrun\\\] fetch_inferior_event: exit\r\n$" \
+	"continue" \
+	"Continuing.*\\\[infrun\\\] .*\\\[infrun\\\] .*Breakpoint \[0-9\]+, foo.*"
 
     gdb_test "set debug infrun 0"
     gdb_test "set logging enabled off" "Done logging to /dev/null\\."
diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp
index 0b1104bd299..071f4994a76 100644
--- a/gdb/testsuite/lib/gdb.exp
+++ b/gdb/testsuite/lib/gdb.exp
@@ -1313,7 +1313,7 @@ proc gdb_test_multiline { name args } {
 }
 
 
-# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
+# gdb_test COMMAND [PATTERN] [MESSAGE] [QUESTION RESPONSE] [-prompt PROMPT] [-lbl]
 # Send a command to gdb; test the result.
 #
 # COMMAND is the command to execute, send to GDB with send_gdb.  If
@@ -1335,57 +1335,67 @@ proc gdb_test_multiline { name args } {
 #    1 if the test failed,
 #    0 if the test passes,
 #   -1 if there was an internal error.
-#  
+#
 proc gdb_test { args } {
     global gdb_prompt
     upvar timeout timeout
 
+    parse_args {
+	{prompt ""}
+	{lbl}
+    }
+
+    set command [lindex $args 0]
+    set pattern [lindex $args 1]
+    set message [lindex $args 2]
+    set question [lindex $args 3]
+    set response [lindex $args 4]
+
     # Can't have a question without a response.
-    if { [llength $args] == 4 || [llength $args] > 5 } {
+    if { $question != "" && $response == "" } {
 	error "Unexpected arguments: $args"
     }
 
-    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]
 
-    set must_see_question 0
-    if { [llength $args] == 5 } {
-	set must_see_question 1
-	set saw_question 0
+    if { $prompt == "" } {
+	set prompt "$gdb_prompt $"
     }
 
+    set saw_question 0
+
     set user_code {}
     lappend user_code {
-	-re "\[\r\n\]*(?:$pattern)\[\r\n\]+$gdb_prompt $" {
+	-re "\[\r\n\]*(?:$pattern)\[\r\n\]+$prompt" {
 	    if ![string match "" $message] then {
-		if {$must_see_question} {
+		if { $question != "" } {
 		    gdb_assert $saw_question "$message"
 		} else {
 		    pass "$message"
 		}
-            }
-        }
+	    }
+	}
     }
 
-    if { [llength $args] == 5 } {
-	set question_string [lindex $args 3]
-	set response_string [lindex $args 4]
+    if { $question != "" } {
 	lappend user_code {
-	    -re "(${question_string})$" {
+	    -re "($question)$" {
 		set saw_question 1
-		send_gdb "$response_string\n"
+		send_gdb "$response\n"
 		exp_continue
 	    }
 	}
      }
 
+    set opts {}
+    lappend "-prompt $prompt"
+    if {$lbl} {
+	lappend opts "-lbl"
+    }
     set user_code [join $user_code]
-    return [gdb_test_multiple $command $message $user_code]
+    return [gdb_test_multiple $command $message {*}$opts $user_code]
 }
 
 # Return 1 if version MAJOR.MINOR is at least AT_LEAST_MAJOR.AT_LEAST_MINOR.

base-commit: ed01945057cfdf048bc025f15b410492e12283f6
-- 
2.36.0