From 15093998aa0890eb57ccb9f996f6b4a7ea696a4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20AMIARD?= Date: Wed, 29 May 2024 10:20:19 +0200 Subject: [PATCH] Add Parse (Unknown_Args => ...) to Opt_Parse Allowing to combine `Opt_Parse` with ad-hoc cmd line parsing/ other cmd line parsing technologies. --- src/gnatcoll-opt_parse.adb | 215 +++++++++++------- src/gnatcoll-opt_parse.ads | 50 +++- .../tests/opt_parse/parse_known_args/test.adb | 70 ++++++ .../opt_parse/parse_known_args/test.yaml | 2 + 4 files changed, 249 insertions(+), 88 deletions(-) create mode 100644 testsuite/tests/opt_parse/parse_known_args/test.adb create mode 100644 testsuite/tests/opt_parse/parse_known_args/test.yaml diff --git a/src/gnatcoll-opt_parse.adb b/src/gnatcoll-opt_parse.adb index d7f3fea7..50797819 100644 --- a/src/gnatcoll-opt_parse.adb +++ b/src/gnatcoll-opt_parse.adb @@ -35,6 +35,8 @@ package body GNATCOLL.Opt_Parse is package Cmd_Line renames Ada.Command_Line; + type XString_Vector_Access is access all XString_Vector; + function "+" (Self : String) return XString renames To_XString; @@ -42,6 +44,8 @@ package body GNATCOLL.Opt_Parse is (Self : XString) return String renames To_String; function Get_Arguments (Arguments : XString_Array) return XString_Array; + -- Return the arguments in ``Arguments``, if it's not an empty array. Else, + -- create an array from the application's command line arguments. function Parse_One_Option (Short, Long : String; @@ -369,26 +373,39 @@ package body GNATCOLL.Opt_Parse is return Self.Get_Result (Args) /= null; end Has_Result; + function Parse_Impl + (Self : in out Argument_Parser; + Arguments : XString_Array := No_Arguments; + Result : out Parsed_Arguments; + Unknown_Args : XString_Vector_Access := null) return Boolean; + -- Shared implementation for all the ``Parse`` public overloads + ----------- -- Parse -- ----------- function Parse - (Self : in out Argument_Parser; - Arguments : XString_Array := No_Arguments) return Boolean + (Self : in out Argument_Parser; + Arguments : XString_Array := No_Arguments) return Boolean is begin - if Self.Data.Default_Result /= No_Parsed_Arguments then - Self.Data.Default_Result := No_Parsed_Arguments; - end if; + return Self.Parse_Impl (Arguments, Self.Data.Default_Result, null); + end Parse; - return Ret : constant Boolean - := Self.Parse (Arguments, Self.Data.Default_Result) - do - if not Ret then - Put_Line (Help (Self)); - end if; - end return; + ----------- + -- Parse -- + ----------- + + function Parse + (Self : in out Argument_Parser; + Arguments : XString_Array := No_Arguments; + Unknown_Arguments : out XString_Vector) return Boolean + is + begin + return Self.Parse_Impl + (Arguments, + Self.Data.Default_Result, + Unknown_Arguments'Unchecked_Access); end Parse; ----------- @@ -396,9 +413,23 @@ package body GNATCOLL.Opt_Parse is ----------- function Parse - (Self : in out Argument_Parser; - Arguments : XString_Array := No_Arguments; - Result : out Parsed_Arguments) return Boolean + (Self : in out Argument_Parser; + Arguments : XString_Array := No_Arguments; + Result : out Parsed_Arguments) return Boolean + is + begin + return Self.Parse_Impl (Arguments, Result, null); + end Parse; + + ---------------- + -- Parse_Impl -- + ---------------- + + function Parse_Impl + (Self : in out Argument_Parser; + Arguments : XString_Array := No_Arguments; + Result : out Parsed_Arguments; + Unknown_Args : XString_Vector_Access := null) return Boolean is Exit_Parsing : exception; -- Raised when aborting arguments parsing for --help. We cannot call @@ -412,6 +443,7 @@ package body GNATCOLL.Opt_Parse is Cmd_Line_Args : constant XString_Array := Get_Arguments (Arguments); procedure Handle_Failure (Error_Msg : String); + function Internal return Boolean; -------------------- -- Handle_Failure -- @@ -423,85 +455,110 @@ package body GNATCOLL.Opt_Parse is ("Argument parsing failed: " & Error_Msg); end Handle_Failure; - begin - Result.Ref.Set - (Parsed_Arguments_Type' - (Raw_Args => new XString_Array'(Cmd_Line_Args), - Results => new Parser_Result_Array - (1 .. Self.Data.All_Parsers.Last_Index))); + function Internal return Boolean is + begin + Result.Ref.Set + (Parsed_Arguments_Type' + (Raw_Args => new XString_Array'(Cmd_Line_Args), + Results => new Parser_Result_Array + (1 .. Self.Data.All_Parsers.Last_Index))); - while Current_Arg <= Cmd_Line_Args'Last loop + while Current_Arg <= Cmd_Line_Args'Last loop - for Opt_Parser of Self.Data.Opts_Parsers loop - begin - declare - P_Return : constant Parser_Return := - Opt_Parser.Parse (Cmd_Line_Args, Current_Arg, Result); + for Opt_Parser of Self.Data.Opts_Parsers loop begin - if P_Return /= Error_Return then - Current_Arg := Positive (P_Return); - - if Opt_Parser.all in Help_Flag_Parser'Class then - Put_Line (Self.Help); - raise Exit_Parsing; + declare + P_Return : constant Parser_Return := + Opt_Parser.Parse (Cmd_Line_Args, Current_Arg, Result); + begin + if P_Return /= Error_Return then + Current_Arg := Positive (P_Return); + + if Opt_Parser.all in Help_Flag_Parser'Class then + Put_Line (Self.Help); + raise Exit_Parsing; + end if; + + goto Next_Iter; end if; - - goto Next_Iter; - end if; + end; + exception + when E : Opt_Parse_Error => + Handle_Failure + ("for option " & (+Opt_Parser.Name) & " - " + & Ada.Exceptions.Exception_Message (E)); + return False; end; - exception - when E : Opt_Parse_Error => - Handle_Failure - ("for option " & (+Opt_Parser.Name) & " - " - & Ada.Exceptions.Exception_Message (E)); - return False; - end; - end loop; + end loop; - for Pos_Parser of Self.Data.Positional_Args_Parsers loop - begin - declare - P_Return : constant Parser_Return := - Pos_Parser.Parse (Cmd_Line_Args, Current_Arg, Result); + for Pos_Parser of Self.Data.Positional_Args_Parsers loop begin - if P_Return /= Error_Return then - Current_Arg := Positive (P_Return); - goto Next_Iter; - end if; + declare + P_Return : constant Parser_Return := + Pos_Parser.Parse (Cmd_Line_Args, Current_Arg, Result); + begin + if P_Return /= Error_Return then + Current_Arg := Positive (P_Return); + goto Next_Iter; + end if; + end; + exception + when E : Opt_Parse_Error => + Handle_Failure + ("for parser " & (+Pos_Parser.Name) & " - " + & Ada.Exceptions.Exception_Message (E)); + return False; end; - exception - when E : Opt_Parse_Error => - Handle_Failure - ("for parser " & (+Pos_Parser.Name) & " - " - & Ada.Exceptions.Exception_Message (E)); - return False; - end; + end loop; + + -- If the user passed an Unknown_Args vector, fill it with + -- arguments that we didn't recognize. Else, raise an error when + -- we encounter an unknown argument. + if Unknown_Args = null then + Handle_Failure + ("Unrecognized argument " & (+Cmd_Line_Args (Current_Arg))); + return False; + else + Unknown_Args.Append (Cmd_Line_Args (Current_Arg)); + Current_Arg := Current_Arg + 1; + end if; + + <> end loop; - Handle_Failure - ("Unrecognized argument " & (+Cmd_Line_Args (Current_Arg))); - return False; + for Parser of Self.Data.All_Parsers loop + if not Parser.Opt and then not Parser.Has_Result (Result) then + Handle_Failure ("Missing value for " & (+Parser.Name)); + return False; + end if; + end loop; - <> - end loop; + return True; + exception + when E : Opt_Parse_Error => + Handle_Failure (Ada.Exceptions.Exception_Message (E)); + return False; - for Parser of Self.Data.All_Parsers loop - if not Parser.Opt and then not Parser.Has_Result (Result) then - Handle_Failure ("Missing value for " & (+Parser.Name)); + when Exit_Parsing => + GNAT.OS_Lib.OS_Exit (0); return False; - end if; - end loop; + end Internal; - return True; - exception - when E : Opt_Parse_Error => - Handle_Failure (Ada.Exceptions.Exception_Message (E)); - return False; + begin + -- Reset the default result if we're using it + if Arguments = No_Arguments + and then Self.Data.Default_Result /= No_Parsed_Arguments + then + Self.Data.Default_Result := No_Parsed_Arguments; + end if; - when Exit_Parsing => - GNAT.OS_Lib.OS_Exit (0); - return False; - end Parse; + return Ret : constant Boolean := Internal do + -- Print help if parsing has failed + if not Ret then + Put_Line (Help (Self)); + end if; + end return; + end Parse_Impl; ----------- -- Parse -- diff --git a/src/gnatcoll-opt_parse.ads b/src/gnatcoll-opt_parse.ads index ea01422a..6ba4836e 100644 --- a/src/gnatcoll-opt_parse.ads +++ b/src/gnatcoll-opt_parse.ads @@ -34,7 +34,7 @@ with System.Aux_DEC; use System.Aux_DEC; with GNATCOLL.Strings; use GNATCOLL.Strings; -private with Ada.Containers.Vectors; +with Ada.Containers.Vectors; private with GNATCOLL.Refcount; private with GNATCOLL.Locks; @@ -131,16 +131,50 @@ package GNATCOLL.Opt_Parse is No_Parsed_Arguments : constant Parsed_Arguments; -- Constant for a null Parsed_Arguments value. + package XString_Vectors is new Ada.Containers.Vectors (Positive, XString); + + subtype XString_Vector is XString_Vectors.Vector; + -- Vector of XStrings. Used to fill unknown args in calls to ``Parse``. + + ------------------------ + -- Parse entry points -- + ------------------------ + + -- Those ``Parse`` functions are the entry points to run the argument parse + -- on a set of command line arguments. + -- + -- In every case, Arguments can be an explicit argument array. If not + -- passed, arguments will be parsed from the application's command line. + -- + -- Those functions will return ``False`` if there is an error during + -- parsing, after printing the error on stdout. + -- + -- .. note:: todo, we probably want to print errors on stderr rt. stdout. + -- + -- In overloads without an explicit ``Result``, Results are stored in the + -- implicit default ``Parsed_Arguments`` instance. This means that you can + -- directly call the corresponding ``Get`` function in parsers to get the + -- parsed result. + + function Parse + (Self : in out Argument_Parser; + Arguments : XString_Array := No_Arguments) return Boolean; + -- Parse the command line arguments for Self. + function Parse - (Self : in out Argument_Parser; - Arguments : XString_Array := No_Arguments) return Boolean; + (Self : in out Argument_Parser; + Arguments : XString_Array := No_Arguments; + Unknown_Arguments : out XString_Vector) return Boolean; -- Parse the command line arguments for Self. + -- Unknown arguments will be put in ``Unknown_Arguments``, and no error + -- will be raised. function Parse - (Self : in out Argument_Parser; - Arguments : XString_Array := No_Arguments; - Result : out Parsed_Arguments) return Boolean; - -- Parse command line arguments for Self. Return arguments explicitly. + (Self : in out Argument_Parser; + Arguments : XString_Array := No_Arguments; + Result : out Parsed_Arguments) return Boolean; + -- Parse command line arguments for Self. Return arguments explicitly in + -- ``Result``. function Create_Argument_Parser (Help : String; @@ -441,8 +475,6 @@ private type Argument_Parser_Data; type Argument_Parser_Data_Access is access all Argument_Parser_Data; - package XString_Vectors is new Ada.Containers.Vectors (Positive, XString); - type Parser_Type is abstract tagged record Name : XString; -- Name of the parser diff --git a/testsuite/tests/opt_parse/parse_known_args/test.adb b/testsuite/tests/opt_parse/parse_known_args/test.adb new file mode 100644 index 00000000..d18bcfb1 --- /dev/null +++ b/testsuite/tests/opt_parse/parse_known_args/test.adb @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- G N A T C O L L -- +-- -- +-- Copyright (C) 2010-2018, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +with GNATCOLL.Opt_Parse; use GNATCOLL.Opt_Parse; +with GNATCOLL.Strings; use GNATCOLL.Strings; +with Ada.Containers; + +with Test_Assert; + +function Test return Integer is + package A renames Test_Assert; + + function "+" + (Self : String) return XString renames To_XString; + + package Arg is + Parser : Argument_Parser := Create_Argument_Parser + (Help => "Empty parser"); + + package Quiet is new Parse_Flag + (Parser => Parser, + Short => "-q", + Long => "--quiet", + Help => "Whether the tool should be quiet or not"); + + pragma Unreferenced (Quiet); + + end Arg; + + Unknown_Args : XString_Vector; + + use type Ada.Containers.Count_Type; +begin + + if Arg.Parser.Parse + ((+"--quiet", +"--test"), Unknown_Arguments => Unknown_Args) + then + + A.Assert + (Unknown_Args.Length = 1, "Unknown_Args should contain 1 element"); + + A.Assert + (Unknown_Args (1).To_String, "--test", + "Unknown_Args (1) = ""--test"""); + else + A.Assert (False, "Arg parsing failed, should have succeeded"); + end if; + + return A.Report; +end Test; diff --git a/testsuite/tests/opt_parse/parse_known_args/test.yaml b/testsuite/tests/opt_parse/parse_known_args/test.yaml new file mode 100644 index 00000000..bcc90697 --- /dev/null +++ b/testsuite/tests/opt_parse/parse_known_args/test.yaml @@ -0,0 +1,2 @@ +description: + Test the preservation of unknown arguments mechanism in Opt_Parse