Index: natools-getopt_long.adb ================================================================== --- natools-getopt_long.adb +++ natools-getopt_long.adb @@ -19,10 +19,91 @@ package body Natools.Getopt_Long is package Fixed renames Ada.Strings.Fixed; package Maps renames Ada.Strings.Maps; + + + --------------------------- + -- Any_Name constructors -- + --------------------------- + + function To_Name (Long_Name : String) return Any_Name is + begin + return Any_Name'(Style => Long, + Size => Long_Name'Length, + Long => Long_Name); + end To_Name; + + + function To_Name (Short_Name : Character) return Any_Name is + begin + return Any_Name'(Style => Short, Size => 1, Short => Short_Name); + end To_Name; + + + function Image (Name : Any_Name) return String is + begin + case Name.Style is + when Short => return '-' & Name.Short; + when Long => return "--" & Name.Long; + end case; +-- Alternate implementation: +-- case Name.Style is +-- when Short => return String'(1 => Name.Short); +-- when Long => return '"' & Name.Long & '"'; +-- end case; + end Image; + + + + ---------------------- + -- Default handlers -- + ---------------------- + + package body Handlers is + + procedure Missing_Argument + (Handler : in out Callback; + Id : Option_Id; + Name : Any_Name) + is + pragma Unreferenced (Handler); + pragma Unreferenced (Id); + begin + raise Option_Error with + "Missing argument to option " & Image (Name); + end Missing_Argument; + + + procedure Unexpected_Argument + (Handler : in out Callback; + Id : Option_Id; + Name : Any_Name; + Argument : String) + is + pragma Unreferenced (Handler); + pragma Unreferenced (Id); + begin + raise Option_Error with + "Unexpected argument """ & Argument + & """ to option " & Image (Name); + end Unexpected_Argument; + + + procedure Unknown_Option + (Handler : in out Callback; + Name : Any_Name) + is + pragma Unreferenced (Handler); + begin + raise Option_Error with "Unknown option " & Image (Name); + end Unknown_Option; + + end Handlers; + + ---------------------------- -- Option list management -- ---------------------------- @@ -391,18 +472,11 @@ -- Command-line processing -- ----------------------------- procedure Process (Options : Option_Definitions; - Top_Level_Argument : Option_Id; - Callback : not null access procedure (Id : Option_Id; - Argument : String); - Missing_Argument : access procedure (Id : Option_Id) := null; - Unexpected_Argument : access procedure (Id : Option_Id; - Arg : String) := null; - Unknown_Long_Option : access procedure (Name : String) := null; - Unknown_Short_Option : access procedure (Name : Character) := null; + Handler : in out Handlers.Callback'Class; Posixly_Correct : Boolean := True; Long_Only : Boolean := False; Argument_Count : not null access function return Natural := Ada.Command_Line.Argument_Count'Access; Argument : not null access function (Number : Positive) return String @@ -443,57 +517,45 @@ Cursor := Options.By_Long_Name.Ceiling (Arg_Name); if not Long_Option_Maps.Has_Element (Cursor) or else not Has_Prefix (Cursor, Arg_Name) or else Has_Prefix (Long_Option_Maps.Next (Cursor), Arg_Name) then - if Unknown_Long_Option = null then - raise Option_Error with "Unknown long option " & Arg_Name; - else - Unknown_Long_Option (Arg_Name); - return; - end if; + Handler.Unknown_Option (To_Name (Arg_Name)); + return; end if; end if; -- At this point, Cursor points to the selected argument declare Opt : constant Option := Long_Option_Maps.Element (Cursor); begin case Opt.Has_Arg is when No_Argument => if Equal = 0 then - Callback (Opt.Id, ""); - else - if Unexpected_Argument = null then - raise Option_Error with "Unexpected argument """ - & Arg (Equal + 1 .. Arg'Last) & """ to " - & Opt.Long_Name; - else - Unexpected_Argument (Opt.Id, - Arg (Equal + 1 .. Arg'Last)); - end if; + Handler.Option (Opt.Id, ""); + else + Handler.Unexpected_Argument + (Opt.Id, + To_Name (Opt.Long_Name), + Arg (Equal + 1 .. Arg'Last)); end if; when Optional_Argument => if Equal = 0 then - Callback (Opt.Id, ""); + Handler.Option (Opt.Id, ""); else - Callback (Opt.Id, Arg (Equal + 1 .. Arg'Last)); + Handler.Option (Opt.Id, Arg (Equal + 1 .. Arg'Last)); end if; when Required_Argument => if Equal = 0 then if Arg_N = Arg_Count then - if Missing_Argument = null then - raise Option_Error with "Missing argument to " - & "option " & Opt.Long_Name; - else - Missing_Argument (Opt.Id); - end if; - else - Callback (Opt.Id, Argument (Arg_N + 1)); + Handler.Missing_Argument + (Opt.Id, To_Name (Opt.Long_Name)); + else + Handler.Option (Opt.Id, Argument (Arg_N + 1)); Arg_N := Arg_N + 1; end if; else - Callback (Opt.Id, Arg (Equal + 1 .. Arg'Last)); + Handler.Option (Opt.Id, Arg (Equal + 1 .. Arg'Last)); end if; end case; end; end; end Process_Long_Option; @@ -506,19 +568,20 @@ -- This is a non-flag argument, abort option processing if -- posixly correct. if Posixly_Correct then exit; else - Callback (Top_Level_Argument, Arg); + Handler.Argument (Arg); Arg_N := Arg_N + 1; end if; elsif Arg (Arg'First + 1) = '-' then - -- Argument starting with "--": long option. + -- "--" stops option processing. if Arg'Length = 2 then Arg_N := Arg_N + 1; exit; end if; + -- Argument starting with "--": long option. Process_Long_Option (Arg (Arg'First + 2 .. Arg'Last)); Arg_N := Arg_N + 1; elsif Long_Only then -- Force long option on a single dash prefix. Process_Long_Option (Arg (Arg'First + 1 .. Arg'Last)); @@ -537,38 +600,29 @@ := Short_Option_Maps.Element (Cursor); begin if Opt.Has_Arg = Required_Argument then if Arg_I = Arg'Last then if Arg_N = Arg_Count then - if Missing_Argument = null then - raise Option_Error with "Missing " - & "argument to option " - & Opt.Short_Name; - else - Missing_Argument (Opt.Id); - end if; - else - Callback (Opt.Id, Argument (Arg_N + 1)); + Handler.Missing_Argument + (Opt.Id, To_Name (Opt.Short_Name)); + else + Handler.Option + (Opt.Id, Argument (Arg_N + 1)); Arg_N := Arg_N + 1; exit; end if; else - Callback (Opt.Id, - Arg (Arg_I + 1 .. Arg'Last)); + Handler.Option + (Opt.Id, Arg (Arg_I + 1 .. Arg'Last)); exit; end if; else - Callback (Opt.Id, ""); + Handler.Option (Opt.Id, ""); end if; end; else - if Unknown_Short_Option = null then - raise Option_Error with "Unknown short option " - & Arg (Arg_I); - else - Unknown_Short_Option (Arg (Arg_I)); - end if; + Handler.Unknown_Option (To_Name (Arg (Arg_I))); end if; end; end loop; Arg_N := Arg_N + 1; end if; @@ -575,11 +629,11 @@ end; end loop; -- Only non-flag arguments remain while Arg_N <= Arg_Count loop - Callback (Top_Level_Argument, Argument (Arg_N)); + Handler.Argument (Argument (Arg_N)); Arg_N := Arg_N + 1; end loop; end Process; end Natools.Getopt_Long; Index: natools-getopt_long.ads ================================================================== --- natools-getopt_long.ads +++ natools-getopt_long.ads @@ -17,28 +17,27 @@ ------------------------------------------------------------------------------ -- Natools.Getopt_Long is a native Ada implementation of getopt_long() -- -- processor for command line arguments. -- -- -- -- This package is generic, and its only formal parameter is a descrete -- --- type supposed to cover all command-line flags, including a special value -- --- for non-flag command-line arguments. -- +-- type supposed to cover all command-line options. -- -- -- -- Option_Definitions objects hold the list of recognized flags. Flags can -- -- have a single-character short name or a multiple-character long name. -- -- Moreover, there is no limit to the number of flag names referring to the -- -- same Option_Id value. -- -- -- -- Once the Option_Definitions object has been filled with flags recognized -- --- by the client, the actual command-line arguments can be processed. -- --- Process subprogram uses an Option_Definitions objects and a callback -- --- procedure that is repeatedly called for each command-line flag and -- --- argument found in the command line. -- +-- by the client, the actual command-line arguments can be processed, -- +-- using the handler callbacks from a Handlers.Callback'Class object. -- -- -- --- Process also optionally uses callbacks for error conditions, which -- --- allows the client application to recover from it and allow command-line -- --- processing to continue. If there is no error callback (null access), -- --- an Option_Error exception is raised. -- +-- Callback subprograms for normal operation are Option, for command-line -- +-- flags identified by their Option_Id, and Argument, for top-level command -- +-- line arguments. There are also callbacks for error conditions (missing -- +-- or unexpected argument, unknown option), whose implementation in -- +-- Handlers.Callback are simply to raise Option_Error with an appropriate -- +-- message. -- ------------------------------------------------------------------------------ with Ada.Command_Line; private with Ada.Containers.Indefinite_Ordered_Maps; @@ -47,15 +46,85 @@ type Option_Id is (<>); package Natools.Getopt_Long is pragma Preelaborate (Getopt_Long); - Option_Error : exception; - Null_Long_Name : constant String := ""; Null_Short_Name : constant Character := Character'Val (0); + + + ------------------------------------------ + -- Holder for both short and long names -- + ------------------------------------------ + + type Name_Style is (Long, Short); + + type Any_Name (Style : Name_Style; Size : Positive) is record + case Style is + when Short => + Short : Character; + when Long => + Long : String (1 .. Size); + end case; + end record; + + function To_Name (Long_Name : String) return Any_Name; + function To_Name (Short_Name : Character) return Any_Name; + function Image (Name : Any_Name) return String; + + + + ------------------------ + -- Callback interface -- + ------------------------ + + Option_Error : exception; + + package Handlers is + + type Callback is abstract tagged null record; + + procedure Option + (Handler : in out Callback; + Id : Option_Id; + Argument : String) + is abstract; + -- Callback for successfully-parsed options. + + procedure Argument + (Handler : in out Callback; + Argument : String) + is abstract; + -- Callback for non-flag arguments. + + procedure Missing_Argument + (Handler : in out Callback; + Id : Option_Id; + Name : Any_Name); + -- Raise Option_Error (default error handler). + + procedure Unexpected_Argument + (Handler : in out Callback; + Id : Option_Id; + Name : Any_Name; + Argument : String); + -- Raise Option_Error (default error handler). + + procedure Unknown_Option + (Handler : in out Callback; + Name : Any_Name); + -- Raise Option_Error (default error handler). + + end Handlers; + + + + --------------------- + -- Option database -- + --------------------- + type Argument_Requirement is (No_Argument, Required_Argument, Optional_Argument); type Option_Definitions is tagged private; @@ -161,34 +230,27 @@ -- short and long name. -- Process is called for each option; for options lacking a long name, -- Long_Name is "", and for options lacking a short name, Short_Name -- is Character'Val (0). + + + -------------------------------------- + -- Command line argument processing -- + -------------------------------------- + procedure Process (Options : Option_Definitions; - Top_Level_Argument : Option_Id; - Callback : not null access procedure (Id : Option_Id; - Argument : String); - Missing_Argument : access procedure (Id : Option_Id) := null; - Unexpected_Argument : access procedure (Id : Option_Id; - Arg : String) := null; - Unknown_Long_Option : access procedure (Name : String) := null; - Unknown_Short_Option : access procedure (Name : Character) := null; + Handler : in out Handlers.Callback'Class; Posixly_Correct : Boolean := True; Long_Only : Boolean := False; Argument_Count : not null access function return Natural := Ada.Command_Line.Argument_Count'Access; Argument : not null access function (Number : Positive) return String := Ada.Command_Line.Argument'Access); -- Process system command line argument list, using the provided option - -- definitions. Callback is called for each identified option with its - -- idea and the option argument if any, or the empty string otherwise. - -- When encountering a command-line argument not attached to an option, - -- Callback is called with Top_Level_Argument and the argument string. - -- When encontering an option missing a required argument or an unkonwn - -- option name, the relevant callback is called if not null, otherwise - -- Option_Error is raised. + -- definitions and handler callbacks. private type Option (Long_Name_Length : Natural) is record Id : Option_Id; Index: natools-getopt_long_tests.adb ================================================================== --- natools-getopt_long_tests.adb +++ natools-getopt_long_tests.adb @@ -61,62 +61,16 @@ type Flag_Seen_Array is array (Option_Id) of Boolean; type Flag_Argument_Array is array (Option_Id) of US.Unbounded_String; - package Getopt is new Natools.Getopt_Long (Option_Id); - - Flag_Seen : Flag_Seen_Array; - Flag_Argument : Flag_Argument_Array; - Flag_Error : String_Vectors.Vector; Separator : constant Character := ';'; - procedure Callback (Id : Option_Id; Argument : String); - -- Process the given argument, by recording it as seen in Flag_Seen - -- and appending the argument to Flag_Argument. - procedure Dump (Report : in out NT.Reporter'Class); - -- Dump the current state (Flag_* variables) into the Report. + package Getopt is new Natools.Getopt_Long (Option_Id); + function Option_Definitions return Getopt.Option_Definitions; -- Create the Option_Definitions object used for these tests. - procedure Reset_Flags; - -- Reset Flag_* variables for a new test. - - - - procedure Callback (Id : Option_Id; Argument : String) is - begin - Flag_Seen (Id) := True; - US.Append (Flag_Argument (Id), Argument & Separator); - end Callback; - - - procedure Dump (Report : in out NT.Reporter'Class) is - procedure Process (Position : String_Vectors.Cursor); - function Seen_String (Seen : Boolean) return String; - - procedure Process (Position : String_Vectors.Cursor) is - begin - Report.Info ("Error """ & String_Vectors.Element (Position) & '"'); - end Process; - - function Seen_String (Seen : Boolean) return String is - begin - if Seen then - return "Seen"; - else - return "Not seen"; - end if; - end Seen_String; - begin - Report.Info ("Flags:"); - for Id in Option_Id loop - Report.Info (" " & Option_Id'Image (Id) & ": " - & Seen_String (Flag_Seen (Id)) & ", """ - & US.To_String (Flag_Argument (Id)) & '"'); - end loop; - Flag_Error.Iterate (Process'Access); - end Dump; function Option_Definitions return Getopt.Option_Definitions is begin return OD : Getopt.Option_Definitions do @@ -133,18 +87,182 @@ OD.Add_Option ("write", 'w', Getopt.Optional_Argument, Mixed_Opt_Arg); end return; end Option_Definitions; - procedure Reset_Flags is - begin - for Id in Option_Id loop - Flag_Seen (Id) := False; - Flag_Argument (Id) := US.Null_Unbounded_String; - end loop; - Flag_Error.Clear; - end Reset_Flags; + + ------------------- + -- Test Handlers -- + ------------------- + + package Handlers is + + type Basic is new Getopt.Handlers.Callback with record + Flag_Seen : Flag_Seen_Array := (others => False); + Flag_Argument : Flag_Argument_Array; + Flag_Error : String_Vectors.Vector; + end record; + + overriding + procedure Option (Handler : in out Basic; + Id : Option_Id; + Argument : String); + -- Process the given option, by recording it as seen in Flag_Seen + -- and appending the argument to Flag_Argument. + + overriding + procedure Argument (Handler : in out Basic; + Argument : String); + -- Process the given argument, by recording it + -- in Flag_Seen (Command_Argument) and appending it + -- to Flag_Argument (Command_Argument). + + not overriding + procedure Dump (Handler : Basic; + Report : in out NT.Reporter'Class); + -- Dump the current state (Flag_* variables) into the Report. + + + type Error_Count is record + Missing_Argument_Long : Natural := 0; + Missing_Argument_Short : Natural := 0; + Unexpected_Argument : Natural := 0; + Unknown_Long_Option : Natural := 0; + Unknown_Short_Option : Natural := 0; + end record; + + type Recovering is new Basic with record + Count : Error_Count; + end record; + + procedure Increment (Number : in out Natural); + + overriding + procedure Missing_Argument + (Handler : in out Recovering; + Id : Option_Id; + Name : Getopt.Any_Name); + + overriding + procedure Unexpected_Argument + (Handler : in out Recovering; + Id : Option_Id; + Name : Getopt.Any_Name; + Argument : String); + + overriding + procedure Unknown_Option + (Handler : in out Recovering; + Name : Getopt.Any_Name); + + end Handlers; + + + + package body Handlers is + + overriding + procedure Option (Handler : in out Basic; + Id : Option_Id; + Argument : String) is + begin + Handler.Flag_Seen (Id) := True; + US.Append (Handler.Flag_Argument (Id), Argument & Separator); + end Option; + + + overriding + procedure Argument (Handler : in out Basic; + Argument : String) is + begin + Option (Handler, Command_Argument, Argument); + end Argument; + + + not overriding + procedure Dump (Handler : Basic; + Report : in out NT.Reporter'Class) + is + procedure Process (Position : String_Vectors.Cursor); + function Seen_String (Seen : Boolean) return String; + + procedure Process (Position : String_Vectors.Cursor) is + begin + Report.Info ("Error """ & String_Vectors.Element (Position) & '"'); + end Process; + + function Seen_String (Seen : Boolean) return String is + begin + if Seen then + return "Seen"; + else + return "Not seen"; + end if; + end Seen_String; + begin + Report.Info ("Flags:"); + for Id in Option_Id loop + Report.Info (" " + & Option_Id'Image (Id) & ": " + & Seen_String (Handler.Flag_Seen (Id)) & ", """ + & US.To_String (Handler.Flag_Argument (Id)) & '"'); + end loop; + Handler.Flag_Error.Iterate (Process'Access); + end Dump; + + + procedure Increment (Number : in out Natural) is + begin + Number := Number + 1; + end Increment; + + + overriding + procedure Missing_Argument + (Handler : in out Recovering; + Id : Option_Id; + Name : Getopt.Any_Name) + is + pragma Unreferenced (Id); + begin + case Name.Style is + when Getopt.Short => + Increment (Handler.Count.Missing_Argument_Short); + when Getopt.Long => + Increment (Handler.Count.Missing_Argument_Long); + end case; + end Missing_Argument; + + overriding + procedure Unexpected_Argument + (Handler : in out Recovering; + Id : Option_Id; + Name : Getopt.Any_Name; + Argument : String) + is + pragma Unreferenced (Id); + pragma Unreferenced (Name); + pragma Unreferenced (Argument); + begin + Increment (Handler.Count.Unexpected_Argument); + end Unexpected_Argument; + + + overriding + procedure Unknown_Option + (Handler : in out Recovering; + Name : Getopt.Any_Name) is + begin + case Name.Style is + when Getopt.Short => + Increment (Handler.Count.Unknown_Short_Option); + when Getopt.Long => + Increment (Handler.Count.Unknown_Long_Option); + end case; + end Unknown_Option; + + end Handlers; ---------------------------- -- Generic test procedure -- @@ -169,38 +287,38 @@ Posixly_Correct : Boolean := True; Long_Only : Boolean := False) is use type String_Vectors.Vector; Options : constant Getopt.Option_Definitions := Option_Definitions; + Handler : Handlers.Basic; begin - Reset_Flags; begin Options.Process - (Top_Level_Argument => Command_Argument, - Callback => Callback'Access, + (Handler => Handler, Posixly_Correct => Posixly_Correct, Long_Only => Long_Only, Argument_Count => Argument_Count'Access, Argument => Argument'Access); exception when Error : Getopt.Option_Error => - Flag_Error.Append (Ada.Exceptions.Exception_Message (Error)); + Handler.Flag_Error.Append + (Ada.Exceptions.Exception_Message (Error)); end; - if Flag_Seen = Expected_Seen and - Flag_Argument = Expected_Argument and - Flag_Error = Expected_Error + if Handler.Flag_Seen = Expected_Seen and + Handler.Flag_Argument = Expected_Argument and + Handler.Flag_Error = Expected_Error then Report.Item (Name, NT.Success); else Report.Item (Name, NT.Fail); - Dump (Report); + Handler.Dump (Report); end if; exception when Error : others => Report.Report_Exception (Name, Error); - Dump (Report); + Handler.Dump (Report); end Test; --------------------------- @@ -258,140 +376,108 @@ procedure Test_Error_Callbacks (Report : in out NT.Reporter'Class) is procedure Local_Test (Name : String; Expected_Seen : Flag_Seen_Array; Expected_Argument : Flag_Argument_Array; - Expected_Missing_Argument : Natural := 0; - Expected_Unexpected_Argument : Natural := 0; - Expected_Unknown_Long_Option : Natural := 0; - Expected_Unknown_Short_Option : Natural := 0); - procedure Missing_Argument (Id : Option_Id); - procedure Unexpected_Argument (Id : Option_Id; Arg : String); - procedure Unknown_Long_Option (Name : String); - procedure Unknown_Short_Option (Name : Character); - - Missing_Argument_Nb, Unexpected_Argument_Nb, - Unknown_Long_Option_Nb, Unknown_Short_Option_Nb : Natural; + Expected_Count : Handlers.Error_Count); + procedure Local_Test (Name : String; Expected_Seen : Flag_Seen_Array; Expected_Argument : Flag_Argument_Array; - Expected_Missing_Argument : Natural := 0; - Expected_Unexpected_Argument : Natural := 0; - Expected_Unknown_Long_Option : Natural := 0; - Expected_Unknown_Short_Option : Natural := 0) - is - Options : constant Getopt.Option_Definitions := Option_Definitions; - begin - Reset_Flags; - Missing_Argument_Nb := 0; - Unexpected_Argument_Nb := 0; - Unknown_Long_Option_Nb := 0; - Unknown_Short_Option_Nb := 0; - Options.Process - (Top_Level_Argument => Command_Argument, - Callback => Callback'Access, - Missing_Argument => Missing_Argument'Access, - Unexpected_Argument => Unexpected_Argument'Access, - Unknown_Long_Option => Unknown_Long_Option'Access, - Unknown_Short_Option => Unknown_Short_Option'Access, - Argument_Count => Argument_Count'Access, - Argument => Argument'Access); - if Missing_Argument_Nb /= Expected_Missing_Argument or - Unexpected_Argument_Nb /= Expected_Unexpected_Argument or - Unknown_Long_Option_Nb /= Expected_Unknown_Long_Option or - Unknown_Short_Option_Nb /= Expected_Unknown_Short_Option - then - Report.Item (Name, NT.Fail); - if Missing_Argument_Nb /= Expected_Missing_Argument then - Report.Info ("Missing argument callback called" - & Natural'Image (Missing_Argument_Nb) - & " times, expected" - & Natural'Image (Expected_Missing_Argument)); - end if; - if Unexpected_Argument_Nb /= Expected_Unexpected_Argument then - Report.Info ("Unexpected argument callback called" - & Natural'Image (Unexpected_Argument_Nb) - & " times, expected" - & Natural'Image (Expected_Unexpected_Argument)); - end if; - if Unknown_Long_Option_Nb /= Expected_Unknown_Long_Option then - Report.Info ("Unknown long option callback called" - & Natural'Image (Unknown_Long_Option_Nb) - & " times, expected" - & Natural'Image (Expected_Unknown_Long_Option)); - end if; - if Unknown_Short_Option_Nb /= Expected_Unknown_Short_Option then - Report.Info ("Unknown short option callback called" - & Natural'Image (Unknown_Short_Option_Nb) - & " times, expected" - & Natural'Image (Expected_Unknown_Short_Option)); - end if; - elsif Flag_Seen /= Expected_Seen or - Flag_Argument /= Expected_Argument - then - Report.Item (Name, NT.Fail); - Dump (Report); + Expected_Count : Handlers.Error_Count) + is + use type Handlers.Error_Count; + Options : constant Getopt.Option_Definitions := Option_Definitions; + Handler : Handlers.Recovering; + begin + Options.Process + (Handler => Handler, + Argument_Count => Argument_Count'Access, + Argument => Argument'Access); + if Handler.Count /= Expected_Count then + Report.Item (Name, NT.Fail); + if Handler.Count.Missing_Argument_Long + /= Expected_Count.Missing_Argument_Long + then + Report.Info ("Missing argument to long option callback called" + & Natural'Image (Handler.Count.Missing_Argument_Long) + & " times, expected" + & Natural'Image (Expected_Count.Missing_Argument_Long)); + end if; + if Handler.Count.Missing_Argument_Short + /= Expected_Count.Missing_Argument_Short + then + Report.Info ("Missing argument to short option callback called" + & Natural'Image (Handler.Count.Missing_Argument_Short) + & " times, expected" + & Natural'Image (Expected_Count.Missing_Argument_Short)); + end if; + if Handler.Count.Unexpected_Argument + /= Expected_Count.Unexpected_Argument + then + Report.Info ("Unexpected argument callback called" + & Natural'Image (Handler.Count.Unexpected_Argument) + & " times, expected" + & Natural'Image (Expected_Count.Unexpected_Argument)); + end if; + if Handler.Count.Unknown_Long_Option + /= Expected_Count.Unknown_Long_Option + then + Report.Info ("Unknown long option callback called" + & Natural'Image (Handler.Count.Unknown_Long_Option) + & " times, expected" + & Natural'Image (Expected_Count.Unknown_Long_Option)); + end if; + if Handler.Count.Unknown_Short_Option + /= Expected_Count.Unknown_Short_Option + then + Report.Info ("Unknown short option callback called" + & Natural'Image (Handler.Count.Unknown_Short_Option) + & " times, expected" + & Natural'Image (Expected_Count.Unknown_Short_Option)); + end if; + elsif Handler.Flag_Seen /= Expected_Seen or + Handler.Flag_Argument /= Expected_Argument + then + Report.Item (Name, NT.Fail); + Handler.Dump (Report); else Report.Item (Name, NT.Success); end if; exception when Error : others => Report.Report_Exception (Name, Error); - Dump (Report); + Handler.Dump (Report); end Local_Test; - - procedure Missing_Argument (Id : Option_Id) is - pragma Unreferenced (Id); - begin - Missing_Argument_Nb := Missing_Argument_Nb + 1; - end Missing_Argument; - - procedure Unexpected_Argument (Id : Option_Id; Arg : String) is - pragma Unreferenced (Id, Arg); - begin - Unexpected_Argument_Nb := Unexpected_Argument_Nb + 1; - end Unexpected_Argument; - - procedure Unknown_Long_Option (Name : String) is - pragma Unreferenced (Name); - begin - Unknown_Long_Option_Nb := Unknown_Long_Option_Nb + 1; - end Unknown_Long_Option; - - procedure Unknown_Short_Option (Name : Character) is - pragma Unreferenced (Name); - begin - Unknown_Short_Option_Nb := Unknown_Short_Option_Nb + 1; - end Unknown_Short_Option; begin Report.Section ("Error-handling callbacks"); Command_Line.Clear; Command_Line.Append ("-af"); Local_Test ("Missing argument for short option", (Short_No_Arg => True, others => False), (Short_No_Arg => US.To_Unbounded_String (";"), others => US.Null_Unbounded_String), - Expected_Missing_Argument => 1); + (Missing_Argument_Short => 1, others => 0)); Command_Line.Clear; Command_Line.Append ("--color"); Command_Line.Append ("--input"); Local_Test ("Missing argument for long option", (Long_Opt_Arg => True, others => False), (Long_Opt_Arg => US.To_Unbounded_String (";"), others => US.Null_Unbounded_String), - Expected_Missing_Argument => 1); + (Missing_Argument_Long => 1, others => 0)); Command_Line.Clear; Command_Line.Append ("--aquatic=extra"); Local_Test ("Unexpected argument", (others => False), (others => US.Null_Unbounded_String), - Expected_Unexpected_Argument => 1); + (Unexpected_Argument => 1, others => 0)); Command_Line.Clear; Command_Line.Append ("-a"); Command_Line.Append ("--ignore-case=true"); Command_Line.Append ("--execute"); @@ -402,11 +488,11 @@ others => False), (Short_No_Arg => US.To_Unbounded_String (";"), Mixed_Arg => US.To_Unbounded_String ("command;"), Command_Argument => US.To_Unbounded_String ("file;"), others => US.Null_Unbounded_String), - Expected_Unexpected_Argument => 1); + (Unexpected_Argument => 1, others => 0)); Command_Line.Clear; Command_Line.Append ("-abqffoo"); Local_Test ("Unknown short option", (Short_No_Arg | Short_No_Arg_2 | Short_Arg => True, @@ -413,11 +499,11 @@ others => False), (Short_No_Arg => US.To_Unbounded_String (";"), Short_No_Arg_2 => US.To_Unbounded_String (";"), Short_Arg => US.To_Unbounded_String ("foo;"), others => US.Null_Unbounded_String), - Expected_Unknown_Short_Option => 1); + (Unknown_Short_Option => 1, others => 0)); Command_Line.Clear; Command_Line.Append ("--execute"); Command_Line.Append ("command"); Command_Line.Append ("--unknown=argument"); @@ -425,11 +511,11 @@ Local_Test ("Unknown long option", (Mixed_Arg | Command_Argument => True, others => False), (Mixed_Arg => US.To_Unbounded_String ("command;"), Command_Argument => US.To_Unbounded_String ("file;"), others => US.Null_Unbounded_String), - Expected_Unknown_Long_Option => 1); + (Unknown_Long_Option => 1, others => 0)); Command_Line.Clear; Command_Line.Append ("--ignore-case"); Command_Line.Append ("-bffoo"); Command_Line.Append ("--aq=unexpected"); @@ -441,14 +527,15 @@ others => False), (Short_Arg => US.To_Unbounded_String ("foo;"), Mixed_Arg => US.To_Unbounded_String ("command;"), Mixed_No_Arg => US.To_Unbounded_String (";"), others => US.Null_Unbounded_String), - Expected_Missing_Argument => 1, - Expected_Unexpected_Argument => 1, - Expected_Unknown_Long_Option => 1, - Expected_Unknown_Short_Option => 1); + (Missing_Argument_Long => 1, + Missing_Argument_Short => 0, + Unexpected_Argument => 1, + Unknown_Long_Option => 1, + Unknown_Short_Option => 1)); Report.End_Section; end Test_Error_Callbacks; @@ -553,11 +640,11 @@ Command_Line.Append ("--i"); -- partial match for both "input" and "ignore-case" long flags Test (Report, "Ambiguous partial match for long flags", (others => False), (others => US.Null_Unbounded_String), - String_Vectors.To_Vector ("Unknown long option i", 1)); + String_Vectors.To_Vector ("Unknown option --i", 1)); Command_Line.Clear; Command_Line.Append ("--aq"); -- partial match for both "aq" and "aquatic" long flags -- but exact match is preferred @@ -575,11 +662,12 @@ Command_Line.Append ("--input"); Test (Report, "Missing argument for long option", (Long_Opt_Arg => True, others => False), (Long_Opt_Arg => US.To_Unbounded_String (";"), others => US.Null_Unbounded_String), - String_Vectors.To_Vector ("Missing argument to option input", 1)); + String_Vectors.To_Vector + ("Missing argument to option --input", 1)); end Test_Missing_Argument_Long; procedure Test_Missing_Argument_Short (Report : in out NT.Reporter'Class) is begin @@ -588,11 +676,11 @@ Command_Line.Append ("-f"); Test (Report, "Missing argument for long option", (Short_Opt_Arg => True, others => False), (Short_Opt_Arg => US.To_Unbounded_String (";"), others => US.Null_Unbounded_String), - String_Vectors.To_Vector ("Missing argument to option f", 1)); + String_Vectors.To_Vector ("Missing argument to option -f", 1)); end Test_Missing_Argument_Short; procedure Test_Mixed_Arg (Report : in out NT.Reporter'Class) is begin @@ -711,29 +799,30 @@ Command_Line.Append ("--aq=bar"); Test (Report, "Unexpected argument to long option", (Long_Opt_Arg => True, others => False), (Long_Opt_Arg => US.To_Unbounded_String ("foo;"), others => US.Null_Unbounded_String), - String_Vectors.To_Vector ("Unexpected argument ""bar"" to aq", 1)); + String_Vectors.To_Vector + ("Unexpected argument ""bar"" to option --aq", 1)); end Test_Unexpected_Argument; procedure Test_Unknown_Long (Report : in out NT.Reporter'Class) is begin Command_Line.Clear; Command_Line.Append ("--long-flag"); Test (Report, "Unknown long flag", (others => False), (others => US.Null_Unbounded_String), - String_Vectors.To_Vector ("Unknown long option long-flag", 1)); + String_Vectors.To_Vector ("Unknown option --long-flag", 1)); end Test_Unknown_Long; procedure Test_Unknown_Short (Report : in out NT.Reporter'Class) is begin Command_Line.Clear; Command_Line.Append ("-g"); Test (Report, "Unknown short flag", (others => False), (others => US.Null_Unbounded_String), - String_Vectors.To_Vector ("Unknown short option g", 1)); + String_Vectors.To_Vector ("Unknown option -g", 1)); end Test_Unknown_Short; end Natools.Getopt_Long_Tests;