From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from barracuda.ebox.ca (barracuda.ebox.ca [96.127.255.19]) by sourceware.org (Postfix) with ESMTPS id 5FCBF3858D34 for ; Tue, 26 May 2020 13:02:26 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 5FCBF3858D34 X-ASG-Debug-ID: 1590498144-0c856e6d3813b1d0001-fS2M51 Received: from smtp.ebox.ca (smtp.ebox.ca [96.127.255.82]) by barracuda.ebox.ca with ESMTP id fDXpsgxej7Jk3sTN (version=TLSv1 cipher=DHE-RSA-AES256-SHA bits=256 verify=NO); Tue, 26 May 2020 09:02:24 -0400 (EDT) X-Barracuda-Envelope-From: simon.marchi@polymtl.ca X-Barracuda-RBL-Trusted-Forwarder: 96.127.255.82 Received: from localhost.localdomain (173-246-6-90.qc.cable.ebox.net [173.246.6.90]) by smtp.ebox.ca (Postfix) with ESMTP id C668B441B21; Tue, 26 May 2020 09:02:24 -0400 (EDT) From: Simon Marchi X-Barracuda-Effective-Source-IP: 173-246-6-90.qc.cable.ebox.net[173.246.6.90] X-Barracuda-Apparent-Source-IP: 173.246.6.90 X-Barracuda-RBL-IP: 173.246.6.90 To: gdb-patches@sourceware.org Subject: [PATCH] gdb/testsuite: introduce parse_options procedure Date: Tue, 26 May 2020 09:02:22 -0400 X-ASG-Orig-Subj: [PATCH] gdb/testsuite: introduce parse_options procedure Message-Id: <20200526130222.1956061-1-simon.marchi@polymtl.ca> X-Mailer: git-send-email 2.26.2 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Barracuda-Connect: smtp.ebox.ca[96.127.255.82] X-Barracuda-Start-Time: 1590498144 X-Barracuda-Encrypted: DHE-RSA-AES256-SHA X-Barracuda-URL: https://96.127.255.19:443/cgi-mod/mark.cgi X-Barracuda-Scan-Msg-Size: 13533 X-Virus-Scanned: by bsmtpd at ebox.ca X-Barracuda-BRTS-Status: 1 X-Barracuda-Spam-Score: 0.00 X-Barracuda-Spam-Status: No, SCORE=0.00 using global scores of TAG_LEVEL=1000.0 QUARANTINE_LEVEL=1000.0 KILL_LEVEL=8.0 tests= X-Barracuda-Spam-Report: Code version 3.2, rules version 3.2.3.82116 Rule breakdown below pts rule name description ---- ---------------------- -------------------------------------------------- X-Spam-Status: No, score=-16.0 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_DMARC_QUARANTINE, KAM_DMARC_STATUS, RCVD_IN_DNSWL_LOW, SPF_HELO_NONE, SPF_SOFTFAIL, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gdb-patches@sourceware.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gdb-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Tue, 26 May 2020 13:02:28 -0000 In the testsuite, I really like when procedures take optional arguments using shell-like options that start with dash (for example, gdb_test_multiple). I think this leads to clearer code than using parameters with defaults value. For example, if one wants to specify arg3 but not arg2 when calling the following proc: proc some_proc { arg1 { arg2 "" } { arg3 "" } } { ... } they would have to do: some_proc value1 "" value3 I find it nicer when it's shell-like: some_proc value1 -arg3 value3 some_proc -arg3 value3 value1 This patch adds a `parse_options` procedure to help doing this without much code. See the documentation above the proc to see how it works. I modified the gdb_test_multiple procedure to use it, and I think the result is quite readable. Note that because arguments to gdb_test_multiple sometimes start with a hyphen (such as MI commands, but not only), I found it necessary to support the typical "--" argument, which stops the processing of options. Otherwise, parse_options would complain about the argument being an unrecognized option of gdb_test_multiple. I added it at a few places where I found it to be necessary. gdb/testsuite/ChangeLog: * lib/gdb.exp (parse_options): New proc. (gdb_test_multiple): Handle args using parse_options. (gdb_test): Add `--` to gdb_test_multiple call. (gdb_test_no_output): Likewise. * gdb.mi/list-thread-groups-available.exp: Likewise. * gdb.mi/list-thread-groups-no-inferior.exp: Likewise. * gdb.mi/mi-fortran-modules.exp: Likewise. Change-Id: I8910bfba360a25ed28e5ed8c0aea165acbca996f --- .../gdb.mi/list-thread-groups-available.exp | 2 +- .../gdb.mi/list-thread-groups-no-inferior.exp | 2 +- gdb/testsuite/gdb.mi/mi-fortran-modules.exp | 4 +- gdb/testsuite/lib/gdb.exp | 198 +++++++++++++++--- 4 files changed, 174 insertions(+), 32 deletions(-) diff --git a/gdb/testsuite/gdb.mi/list-thread-groups-available.exp b/gdb/testsuite/gdb.mi/list-thread-groups-available.exp index 697ee343d8b4..86a455a34cb1 100644 --- a/gdb/testsuite/gdb.mi/list-thread-groups-available.exp +++ b/gdb/testsuite/gdb.mi/list-thread-groups-available.exp @@ -58,7 +58,7 @@ set process_entry_re "{${id_re},${type_re}(,$description_re)?(,$user_re)?(,$core # timeout (especially when running with check-read1). set cmd "-list-thread-groups --available" set test "list available thread groups" -gdb_test_multiple $cmd $test -prompt "$mi_gdb_prompt" { +gdb_test_multiple -prompt "$mi_gdb_prompt" -- $cmd $test { -re "\\^done,groups=\\\[" { # The beginning of the response. exp_continue diff --git a/gdb/testsuite/gdb.mi/list-thread-groups-no-inferior.exp b/gdb/testsuite/gdb.mi/list-thread-groups-no-inferior.exp index beea82443ba3..e50c862ac04e 100644 --- a/gdb/testsuite/gdb.mi/list-thread-groups-no-inferior.exp +++ b/gdb/testsuite/gdb.mi/list-thread-groups-no-inferior.exp @@ -31,7 +31,7 @@ if [mi_gdb_start] { # size. So we consume the output in chunks. set test "-list-thread-groups --available" -gdb_test_multiple $test $test { +gdb_test_multiple -- $test $test { -re "\}" { exp_continue } diff --git a/gdb/testsuite/gdb.mi/mi-fortran-modules.exp b/gdb/testsuite/gdb.mi/mi-fortran-modules.exp index e7ee1b96e461..3e06c058d758 100644 --- a/gdb/testsuite/gdb.mi/mi-fortran-modules.exp +++ b/gdb/testsuite/gdb.mi/mi-fortran-modules.exp @@ -65,7 +65,7 @@ set modmany_re \ set moduse_re \ "\{module=\"moduse\",files=\\\[\{filename=\"\[^\"\]+$srcfile\",fullname=\"\[^\"\]+$srcfile\",symbols=\\\[\{line=\"44\",name=\"moduse::check_all\",type=\"void \\(void\\)\",description=\"void moduse::check_all\\(void\\);\"\},\{line=\"49\",name=\"moduse::check_var_x\",type=\"void \\(void\\)\",description=\"void moduse::check_var_x\\(void\\);\"\}\\\]\}\\\]\}" set state 0 -gdb_test_multiple $cmd $test -prompt $mi_gdb_prompt$ { +gdb_test_multiple -prompt $mi_gdb_prompt$ -- $cmd $test { -re "104\\^done,symbols=\\\[" { if { $state == 0 } { set state 1 } exp_continue @@ -126,7 +126,7 @@ set moduse_re \ set cmd "107-symbol-info-module-variables" set test "-symbol-info-module-variables" set state 0 -gdb_test_multiple $cmd $test -prompt $mi_gdb_prompt$ { +gdb_test_multiple -prompt $mi_gdb_prompt$ -- $cmd $test { -re "107\\^done,symbols=\\\[" { if { $state == 0 } { set state 1 } exp_continue diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp index 444cea01c36a..26b55b09b3e1 100644 --- a/gdb/testsuite/lib/gdb.exp +++ b/gdb/testsuite/lib/gdb.exp @@ -713,23 +713,28 @@ proc gdb_internal_error_resync {} { } -# gdb_test_multiple COMMAND MESSAGE [ -promp PROMPT_REGEXP] [ -lbl ] -# EXPECT_ARGUMENTS +# gdb_test_multiple [ -prompt PROMPT_REGEXP] [ -lbl ] +# COMMAND MESSAGE EXPECT_ARGUMENTS # Send a command to gdb; test the result. # +# The following positional arguments are required: +# # 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 with the built-in failure patterns # if one of them matches. If MESSAGE is empty COMMAND will be used. -# -prompt PROMPT_REGEXP specifies a regexp matching the expected prompt -# after the command output. If empty, defaults to "$gdb_prompt $". -# -lbl specifies that line-by-line matching 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. # +# The following options are supported: +# +# -prompt PROMPT_REGEXP specifies a regexp matching the expected prompt +# after the command output. If empty, defaults to "$gdb_prompt $". +# -lbl specifies that line-by-line matching will be used. +# # Returns: # 1 if the test failed, according to a built-in failure pattern # 0 if only user-supplied patterns matched @@ -808,7 +813,7 @@ proc gdb_internal_error_resync {} { # } # } # -proc gdb_test_multiple { command message args } { +proc gdb_test_multiple { args } { global verbose use_gdb_stub global gdb_prompt pagination_prompt global GDB @@ -818,30 +823,20 @@ proc gdb_test_multiple { command message args } { upvar expect_out expect_out global any_spawn_id - set line_by_line 0 - set prompt_regexp "" - for {set i 0} {$i < [llength $args]} {incr i} { - set arg [lindex $args $i] - if { $arg == "-prompt" } { - incr i - set prompt_regexp [lindex $args $i] - } elseif { $arg == "-lbl" } { - set line_by_line 1 - } else { - set user_code $arg - break - } - } - if { [expr $i + 1] < [llength $args] } { - error "Too many arguments to gdb_test_multiple" - } elseif { ![info exists user_code] } { - error "Too few arguments to gdb_test_multiple" + set prompt_regexp "$gdb_prompt $" + + set opt_desc { + { "prompt" prompt_regexp true } + { "lbl" line_by_line false } } - if { "$prompt_regexp" == "" } { - set prompt_regexp "$gdb_prompt $" + set args [parse_options $args $opt_desc] + if { [llength $args] != 3 } { + error "gdb_test_multiple requires 3 positional argument (command, message and user_code), [llength $args] given)" } + lassign $args command message user_code + if { $message == "" } { set message $command } @@ -1237,7 +1232,7 @@ proc gdb_test { args } { } set user_code [join $user_code] - return [gdb_test_multiple $command $message $user_code] + return [gdb_test_multiple -- $command $message $user_code] } # Return 1 if version MAJOR.MINOR is at least AT_LEAST_MAJOR.AT_LEAST_MINOR. @@ -1296,7 +1291,7 @@ proc gdb_test_no_output { args } { } set command_regex [string_to_regexp $command] - gdb_test_multiple $command $message { + gdb_test_multiple -- $command $message { -re "^$command_regex\r\n$gdb_prompt $" { if ![string match "" $message] then { pass "$message" @@ -7203,5 +7198,152 @@ proc hex_in_list { val hexlist } { return [expr $index != -1] } +# A simple option parser for TCL procedures. +# +# This helps writing procedures that take shell-like options. Options begin +# with a single hyphen and may require a following argument. Arguments which +# are not options nor arguments to options are called positional arguments. +# +# ARGV must be a list of arguments to parse. Typically, a procedure using +# PARSE_OPTIONS will pass in its `args` parameter (the va_list of TCL). +# +# OPT_DESC must be a list of options descriptions. An option description is +# itself a list with the following elements: +# +# 1. Option name, without the leading hyphen +# 2. Variable name +# 3. Whether the option takes an argument +# +# When an option is provided, PARSE_OPTIONS sets the corresponding variable in +# the context of the caller. If the option takes an argument, the following +# element in the argument list is used as the variable value. Otherwise, the +# variable is set to "true". +# +# If an option is not provided: +# +# - if the option does not take an argument: the variable is set to false +# - if the option takes an argument: the variable is not set +# +# The latter allows checking whether an option which requires an argument was +# given or not using `info exists var_name`. Alternatively, the calling +# procedure may provide a default value for an option that requires an argument +# by setting the corresponding variable prior to invoking PARSE_OPTIONS. +# +# Positional arguments are accumulated in a separate list, which is returned by +# PARSE_OPTIONS. +# +# A positional argument "--" causes PARSE_OPTIONS to stop looking for options. All +# arguments following it are appended the returned list. +# +# Here's a somewhat complete example of using PARSE_OPTIONS: +# +# proc some_proc { args } { +# # Default value for -opt-with-arg-1. +# set opt_with_arg_1 123 +# +# set opt_desc { +# { "opt-without-arg-1" opt_without_arg_1 false } +# { "opt-without-arg-2" opt_without_arg_2 false } +# { "opt-with-arg-1" opt_with_arg_1 true } +# { "opt-with-arg-2" opt_with_arg_2 true } +# { "opt-with-arg-3" opt_with_arg_3 true } +# } +# +# set args [parse_options $args $opt_desc] +# +# puts "-opt-without-arg-1: $opt_without_arg_1" +# puts "-opt-without-arg-2: $opt_without_arg_2" +# puts "-opt-with-arg-1: $opt_with_arg_1" +# puts "-opt-with-arg-2: $opt_with_arg_2" +# if { ![info exists opt_with_arg_3] } { +# puts "-opt-with-arg-3 is not specified" +# } +# +# puts "positional arguments: $args" +# } +# +# Calling the proc above with: +# +# some_proc Hello -opt-without-arg-1 World -opt-with-arg-2 arg2 +# +# ... would print: + +# -opt-without-arg-1: true +# -opt-without-arg-2: false +# -opt-with-arg-1: 123 +# -opt-with-arg-2: arg2 +# -opt-with-arg-3 is not specified +# positional arguments: Hello World + +proc parse_options { argv opt_desc } { + set argc [llength $argv] + set optc [llength $opt_desc] + set positional_args {} + + # Initialize variables for options that don't take an argument. + for { set opt_idx 0 } { $opt_idx < $optc } { incr opt_idx } { + lassign [lindex $opt_desc $opt_idx] opt_name opt_var_name \ + opt_requires_arg + + if { !$opt_requires_arg } { + upvar $opt_var_name opt_var + set opt_var false + } + } + + # For each argument... + for { set arg_idx 0 } { $arg_idx < $argc } { incr arg_idx } { + set arg [lindex $argv $arg_idx] + + if { $arg == "--" } { + # End of options, append the remainder of arguments to list + # of positional arguments. + + incr arg_idx + set remainder [lrange $argv $arg_idx end] + set positional_args [concat $positional_args $remainder] + break + } elseif { [string index $arg 0] == "-" } { + # It's an option. + + # Find the option in the option array. + for { set opt_idx 0 } { $opt_idx < $optc } { incr opt_idx } { + lassign [lindex $opt_desc $opt_idx] opt_name opt_var_name \ + opt_requires_arg + + if { $arg == "-${opt_name}" } { + break + } + } + + if { $opt_idx == $optc } { + error "while parsing `$arg`: unrecognized option" + } + + if { $opt_requires_arg } { + # Option requires argument, consume following argument. + incr arg_idx + if { $arg_idx == $argc } { + error "while parsing `$arg`: option requires an argument" + } + + set opt_arg [lindex $argv $arg_idx] + } else { + # Option requires no argument, use value "true". + set opt_arg true + } + + # Set variable in the valler. + upvar $opt_var_name opt_var + set opt_var $opt_arg + } else { + # It's a positional argument, append to positional argument list. + lappend positional_args $arg + } + } + + return $positional_args +} + # Always load compatibility stuff. load_lib future.exp -- 2.26.2