Natools

   ----------------------------
   -- Option list management --
   ----------------------------

   procedure Add_Option
     (Options    : in out Option_Definitions;
      Long_Name  : String;
      Short_Name : Character;
      Has_Arg    : Argument_Requirement;
      Id         : Option_Id)
   is
      New_Option : constant Option
        := (Long_Name_Length => Long_Name'Length,
            Id               => Id,
            Has_Arg          => Has_Arg,
            Long_Name        => Long_Name,
            Short_Name       => Short_Name);
   begin
      if Long_Name = Null_Long_Name or Short_Name = Null_Short_Name then
         raise Constraint_Error;
      end if;
      Options.By_Long_Name.Insert (Long_Name, New_Option);
      Options.By_Short_Name.Insert (Short_Name, New_Option);
   end Add_Option;


   procedure Add_Option
     (Options    : in out Option_Definitions;
      Long_Name  : String;
      Has_Arg    : Argument_Requirement;
      Id         : Option_Id)
   is
      New_Option : constant Option
        := (Long_Name_Length => Long_Name'Length,
            Id               => Id,
            Has_Arg          => Has_Arg,
            Long_Name        => Long_Name,
            Short_Name       => Null_Short_Name);
   begin
      if Long_Name = Null_Long_Name then
         raise Constraint_Error;
      end if;
      Options.By_Long_Name.Insert (Long_Name, New_Option);
   end Add_Option;


   procedure Add_Option
     (Options    : in out Option_Definitions;
      Short_Name : Character;
      Has_Arg    : Argument_Requirement;
      Id         : Option_Id)
   is
      New_Option : constant Option
        := (Long_Name_Length => 0,
            Id               => Id,
            Has_Arg          => Has_Arg,
            Long_Name        => Null_Long_Name,
            Short_Name       => Short_Name);
   begin
      if Short_Name = Null_Short_Name then
         raise Constraint_Error;
      end if;
      Options.By_Short_Name.Insert (Short_Name, New_Option);
   end Add_Option;


   procedure Del_Option
     (Options    : in out Option_Definitions;
      Id         : Option_Id)
   is
      Short_Name_Cursor : Short_Option_Maps.Cursor
        := Options.By_Short_Name.First;
      Long_Name_Cursor : Long_Option_Maps.Cursor
        := Options.By_Long_Name.First;
   begin
      while Short_Option_Maps.Has_Element (Short_Name_Cursor) loop
         declare
            Next : constant Short_Option_Maps.Cursor
              := Short_Option_Maps.Next (Short_Name_Cursor);
         begin
            if Short_Option_Maps.Element (Short_Name_Cursor).Id = Id then
               Options.By_Short_Name.Delete (Short_Name_Cursor);
            end if;
            Short_Name_Cursor := Next;
         end;
      end loop;
      while Long_Option_Maps.Has_Element (Long_Name_Cursor) loop
         declare
            Next : constant Long_Option_Maps.Cursor
              := Long_Option_Maps.Next (Long_Name_Cursor);
         begin
            if Long_Option_Maps.Element (Long_Name_Cursor).Id = Id then
               Options.By_Long_Name.Delete (Long_Name_Cursor);
            end if;
            Long_Name_Cursor := Next;
         end;
      end loop;
   end Del_Option;


   procedure Del_Option
     (Options    : in out Option_Definitions;
      Long_Name  : String) is
   begin
      Options.By_Long_Name.Delete (Long_Name);
   end Del_Option;


   procedure Del_Option
     (Options    : in out Option_Definitions;
      Short_Name : Character) is
   begin
      Options.By_Short_Name.Delete (Short_Name);
   end Del_Option;



   ----------------------------
   -- Formatting subprograms --
   ----------------------------

   function Format_Long_Names
     (Options     : Option_Definitions;
      Id          : Option_Id;
      Separator   : String := ", ";
      Name_Prefix : String := "--")
      return String
   is
      Long_Name_Count : constant Natural := Get_Long_Name_Count (Options, Id);
      Space_Per_Name : constant Positive
        := Name_Prefix'Length + 1 + Separator'Length;
      Result : String (1 .. Long_Name_Count * Space_Per_Name);
   begin
      if Long_Name_Count = 0 then
         return "";
      end if;
      for J in 1 .. Long_Name_Count loop
         declare
            First : constant Positive
              := Result'First + (J - 1) * Space_Per_Name;
            Name : constant String := Get_Long_Name (Options, Id, J);
         begin
            Result (First .. First + Name_Prefix'Length - 1) := Name_Prefix;
            Result (First + Name_Prefix'Length ..
                    First + Name_Prefix'Length + Name'Length - 1)
              := Name;
            Result (First + Name_Prefix'Length + Name'Length ..
                    First + Space_Per_Name - 1)
              := Separator;
         end;
      end loop;
      return Result (1 .. Long_Name_Count * Space_Per_Name - Separator'Length);
   end Format_Long_Names;


   function Format_Names
     (Options           : Option_Definitions;
      Id                : Option_Id;
      Separator         : String := ", ";
      Long_Name_Prefix  : String := "--";
      Short_Name_Prefix : String := "-";
      Short_First       : Boolean := True)
      return String
   is
      Long_Names : constant String
        := Format_Long_Names (Options, Id, Separator, Long_Name_Prefix);
      Short_Names : constant String
        := Format_Short_Names (Options, Id, Separator, Short_Name_Prefix);
   begin
      if Long_Names = "" then
         return Short_Names;
      elsif Short_Names = "" then
         return Long_Names;
      elsif Short_First then
         return Short_Names & Separator & Long_Names;
      else
         return Long_Names & Separator & Short_Names;
      end if;
   end Format_Names;


   function Format_Short_Names
     (Options     : Option_Definitions;
      Id          : Option_Id;
      Separator   : String := ", ";
      Name_Prefix : String := "-")
      return String
   is
      Short_Names : constant String := Get_Short_Names (Options, Id);
      Space_Per_Name : constant Positive
        := Name_Prefix'Length + 1 + Separator'Length;
      Result : String (1 .. Short_Names'Length * Space_Per_Name);
   begin
      if Short_Names = "" then
         return "";
      end if;

      end loop;
      return Result (Result'First .. Result'Last - Separator'Length);
   end Format_Short_Names;



   function Get_Long_Name
     (Options    : Option_Definitions;
      Id         : Option_Id;
      Index      : Positive := 1)
      return String
   is
      Seen : Natural := 0;
      Cursor : Long_Option_Maps.Cursor := Options.By_Long_Name.First;
   begin
      while Long_Option_Maps.Has_Element (Cursor) loop
         declare
            Opt : constant Option := Long_Option_Maps.Element (Cursor);
         begin
            if Opt.Id = Id then
               Seen := Seen + 1;
               if Seen = Index then
                  return Opt.Long_Name;
               end if;
            end if;
         end;
         Long_Option_Maps.Next (Cursor);
      end loop;
      raise Constraint_Error;
   end Get_Long_Name;


   function Get_Long_Name_Count
     (Options    : Option_Definitions;
      Id         : Option_Id)
      return Natural
   is
      procedure Process (Key : String; Element : Option);
      procedure Process (Cursor : Long_Option_Maps.Cursor);

      Result : Natural := 0;

      end Process;

      procedure Process (Cursor : Long_Option_Maps.Cursor) is
      begin
         Long_Option_Maps.Query_Element (Cursor, Process'Access);
      end Process;
   begin
      Options.By_Long_Name.Iterate (Process'Access);
      return Result;
   end Get_Long_Name_Count;


   function Get_Short_Name_Count
     (Options    : Option_Definitions;
      Id         : Option_Id)
      return Natural
   is
      procedure Process (Key : Character; Element : Option);
      procedure Process (Cursor : Short_Option_Maps.Cursor);

      Result : Natural := 0;

      end Process;

      procedure Process (Cursor : Short_Option_Maps.Cursor) is
      begin
         Short_Option_Maps.Query_Element (Cursor, Process'Access);
      end Process;
   begin
      Options.By_Short_Name.Iterate (Process'Access);
      return Result;
   end Get_Short_Name_Count;


   function Get_Short_Names
     (Options    : Option_Definitions;
      Id         : Option_Id)
      return String
   is
      procedure Process (Key : Character; Element : Option);
      procedure Process (Cursor : Short_Option_Maps.Cursor);

      Result : String (1 .. Options.Get_Short_Name_Count (Id));
      J : Positive := Result'First;

      procedure Process (Key : Character; Element : Option) is
      begin
         if Element.Id = Id then
            Result (J) := Key;
            J := J + 1;
         end if;
      end Process;

      procedure Process (Cursor : Short_Option_Maps.Cursor) is
      begin
         Short_Option_Maps.Query_Element (Cursor, Process'Access);
      end Process;
   begin
      Options.By_Short_Name.Iterate (Process'Access);
      return Result;
   end Get_Short_Names;


   procedure Iterate
     (Options : Option_Definitions;
      Process : not null access procedure (Id : Option_Id;
                                           Long_Name : String;
                                           Short_Name : Character;
                                           Has_Arg : Argument_Requirement))
   is
      procedure Long_Process (Key : String; Opt : Option);
      procedure Long_Query (C : Long_Option_Maps.Cursor);

      end Short_Process;

      procedure Short_Query (C : Short_Option_Maps.Cursor) is
      begin
         Short_Option_Maps.Query_Element (C, Short_Process'Access);
      end Short_Query;
   begin
      Options.By_Short_Name.Iterate (Short_Query'Access);
      Options.By_Long_Name.Iterate (Long_Query'Access);
   end Iterate;



   -----------------------------
   -- Command-line processing --
   -----------------------------

   procedure Process
     (Options : Option_Definitions;
      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)

         if Equal /= 0 then
            Arg_Name_Last := Equal - 1;
         end if;
         declare
            Arg_Name : String renames Arg (Arg'First .. Arg_Name_Last);
         begin
            --  Looking for an exact match
            Cursor := Options.By_Long_Name.Find (Arg_Name);
            if not Long_Option_Maps.Has_Element (Cursor) then
               --  Looking for a unique partial match
               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
                  Handler.Unknown_Option (To_Name (Arg_Name));
                  return;
               end if;

               Arg_N := Arg_N + 1;
            else
               --  Process a list of short options, until one with required
               --    argument is encountered (and the rest is its argument).
               for Arg_I in Arg'First + 1 .. Arg'Last loop
                  declare
                     Cursor : constant Short_Option_Maps.Cursor
                       := Options.By_Short_Name.Find (Arg (Arg_I));
                  begin
                     if Short_Option_Maps.Has_Element (Cursor) then
                        declare
                           Opt : constant Option
                             := Short_Option_Maps.Element (Cursor);
                        begin
                           if Opt.Has_Arg = Required_Argument then

------------------------------------------------------------------------------
-- 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 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,       --
-- using the handler callbacks from a Handlers.Callback'Class object.       --
--                                                                          --
-- 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         --

         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;

   procedure Add_Option
     (Options    : in out Option_Definitions;
      Long_Name  : String;
      Short_Name : Character;
      Has_Arg    : Argument_Requirement;
      Id         : Option_Id);
      --  Add an option with both a short and a long name to the database.

   procedure Add_Option
     (Options    : in out Option_Definitions;
      Long_Name  : String;
      Has_Arg    : Argument_Requirement;
      Id         : Option_Id);
      --  Add an option with only a long name to the database.

   procedure Add_Option
     (Options    : in out Option_Definitions;
      Short_Name : Character;
      Has_Arg    : Argument_Requirement;
      Id         : Option_Id);
      --  Add an option with only a short name to the database.

   procedure Del_Option
     (Options    : in out Option_Definitions;
      Id         : Option_Id);
      --  Remove from the database an option identified by its id.

   procedure Del_Option
     (Options    : in out Option_Definitions;
      Long_Name  : String);
      --  Remove from the database an option identified by its long name.

   procedure Del_Option
     (Options    : in out Option_Definitions;
      Short_Name : Character);
      --  Remove from the database an option identified by its short name.

   function Format_Long_Names
     (Options     : Option_Definitions;
      Id          : Option_Id;
      Separator   : String := ", ";
      Name_Prefix : String := "--")
      return String;
      --  Return a human-readable list of long names for the given option.

   function Format_Names
     (Options           : Option_Definitions;
      Id                : Option_Id;
      Separator         : String := ", ";
      Long_Name_Prefix  : String := "--";
      Short_Name_Prefix : String := "-";
      Short_First       : Boolean := True)
      return String;
      --  Return a human-readable list of all names for the given option.

   function Format_Short_Names
     (Options     : Option_Definitions;
      Id          : Option_Id;
      Separator   : String := ", ";
      Name_Prefix : String := "-")
      return String;
      --  Return a human-readable list of short names for the given option.

   function Get_Long_Name
     (Options    : Option_Definitions;
      Id         : Option_Id;
      Index      : Positive := 1)
      return String;
      --  Return the "Index"th long name for the given option id.
      --  Raise Constraint_Error when Index is not
      --     in range 1 .. Get_Long_Name_Count (Options, Id)

   function Get_Long_Name_Count
     (Options    : Option_Definitions;
      Id         : Option_Id)
      return Natural;
      --  Return the number of long names for the given option id.

   function Get_Short_Name_Count
     (Options    : Option_Definitions;
      Id         : Option_Id)
      return Natural;
      --  Return the number of short names for the given option id.

   function Get_Short_Names
     (Options    : Option_Definitions;
      Id         : Option_Id)
      return String;
      --  Return a string containing the characters for short names for
      --    the given option id.

   procedure Iterate
     (Options : Option_Definitions;
      Process : not null access procedure (Id : Option_Id;
                                           Long_Name : String;
                                           Short_Name : Character;
                                           Has_Arg : Argument_Requirement));
      --  Iterate over all options, starting with options having a short name,
      --    followed by options having only a long name, sorted respectively by
      --    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;
      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);

   package Long_Option_Maps is
      new Ada.Containers.Indefinite_Ordered_Maps (String, Option);

   package Short_Option_Maps is
      new Ada.Containers.Indefinite_Ordered_Maps (Character, Option);

   type Option_Definitions is tagged record
      By_Long_Name : Long_Option_Maps.Map;
      By_Short_Name : Short_Option_Maps.Map;
   end record;

end Natools.Getopt_Long;

   type Flag_Argument_Array is array (Option_Id) of US.Unbounded_String;

   Separator : constant Character := ';';

   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.


   function Option_Definitions return Getopt.Option_Definitions is
   begin
      return OD : Getopt.Option_Definitions do
         OD.Add_Option ('a', Getopt.No_Argument, Short_No_Arg);
         OD.Add_Option ('q', Getopt.No_Argument, Short_No_Arg_2);
         OD.Add_Option ('f', Getopt.Required_Argument, Short_Arg);
         OD.Add_Option ('v', Getopt.Optional_Argument, Short_Opt_Arg);
         OD.Add_Option ("aq", Getopt.No_Argument, Long_Ambiguous);
         OD.Add_Option ("aquatic", Getopt.No_Argument, Long_No_Arg);
         OD.Add_Option ("color", Getopt.Optional_Argument, Long_Opt_Arg);
         OD.Add_Option ("input", Getopt.Required_Argument, Long_Arg);
         OD.Add_Option ("execute", 'e', Getopt.Required_Argument, Mixed_Arg);
         OD.Add_Option ("ignore-case", 'i', Getopt.No_Argument, Mixed_No_Arg);
         OD.Add_Option ("write", 'w', Getopt.Optional_Argument, Mixed_Opt_Arg);
      end return;
   end Option_Definitions;



   -------------------
   -- Test Handlers --
   -------------------

      Expected_Seen : Flag_Seen_Array;
      Expected_Argument : Flag_Argument_Array;
      Expected_Error : String_Vectors.Vector := String_Vectors.Empty_Vector;
      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
      begin
         Options.Process

           (Handler            => Handler,
            Posixly_Correct    => Posixly_Correct,
            Long_Only          => Long_Only,
            Argument_Count     => Argument_Count'Access,
            Argument           => Argument'Access);
      exception
         when Error : Getopt.Option_Error =>
            Handler.Flag_Error.Append

      procedure Local_Test
        (Name : String;
         Expected_Seen : Flag_Seen_Array;
         Expected_Argument : Flag_Argument_Array;
         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