generic_command_line_processing.adb


------------------------------------------------------------------------------
--
--  package Generic_Command_Line_Processing (body)
--
--  This package is used to process command line arguments.
--
------------------------------------------------------------------------------
--  Update information:
--
--  1997.03.18 (Jacob Sparre Andersen)
--    Written.
--
--  1997.03.19 (Jacob Sparre Andersen)
--    Improved help and error processing.
--
--  1997.04.10 (Jacob Sparre Andersen)
--    Implemented function All_Arguments_Valid.
--    Recoded the package body to use function All_Arguments_Valid.
--
--  (Insert additional update information above this line.)
------------------------------------------------------------------------------

with Ada.Characters.Handling;
with Ada.Command_Line;
with Ada.Integer_Text_IO;
with Ada.Strings.Unbounded;

package body Generic_Command_Line_Processing is

   ---------------------------------------------------------------------------
   --  function To_String (private):
   --
   --  Returns Argument as a string.
   --
   --  Exceptions:
   --    None

   function To_String (Argument : in     Argument_Names) return String is

      use Ada.Characters.Handling;

   begin --  To_String
      return Argument_Marker & To_Lower (Argument_Names'Image (Argument));
   end To_String;

   ---------------------------------------------------------------------------
   --  function To_Argument (private):
   --
   --  Returns Item as a command line argument.
   --
   --  Exceptions:
   --    Constraint_Error - if Item isn't a valid command line argument.

   function To_Argument (Item : in     String) return Argument_Names is

      Trimmed_Name : constant String := Item (Item'First + 1 .. Item'Last);

   begin --  To_Argument
      return Argument_Names'Value (Trimmed_Name);
   end To_Argument;

   ---------------------------------------------------------------------------
   --  function Is_An_Argument (private):
   --
   --  Checks if Item is a valid command line argument.
   --
   --  Exceptions:
   --    None

   function Is_An_Argument (Item : in     String) return Boolean is

      Trimmed_Name : constant String := Item (Item'First + 1 .. Item'Last);

      Argument : Argument_Names;

   begin --  Is_An_Argument
      Argument := Argument_Names'Value (Trimmed_Name);

      return True;
   exception
      when Constraint_Error =>
         return False;
      when others =>
         Ada.Text_IO.Put_Line
           (File => Ada.Text_IO.Current_Error,
            Item => "Generic_Command_Line_Processing.Is_An_Argument: An " &
                    "undocumented exception occured. Aborting ...");
         raise;
   end Is_An_Argument;

   ---------------------------------------------------------------------------
   --  Argument information:

   ---------------------------------------------------------------------
   --  Argument_Index:
   --
   --  0 means that the argument hasn't been found (yet).

   Argument_Index : Command_Line_Types.Natural_Array := (others => 0);

   ---------------------------------------------------------------------
   --  Argument_Field_Count:
   --
   --  A field count of zero is equivalent to a flag.

   Argument_Field_Count : Command_Line_Types.Natural_Array := (others => 0);

   ---------------------------------------------------------------------
   --  procedure Process_Arguments (private):

   procedure Process_Arguments is

      use Ada.Command_Line;

      Current_Argument : Argument_Names;

   begin --  Process_Arguments
      for Index in 1 .. Argument_Count loop
         if Is_An_Argument (Argument (Index)) then
            Current_Argument := To_Argument (Argument (Index));

            Argument_Index (Current_Argument) := Index;
            Argument_Field_Count (Current_Argument) := 0;
         elsif Index = 1 then
            Ada.Text_IO.Put_Line
              (File => Ada.Text_IO.Current_Error,
               Item => "The first command line argument is not one of the " &
                       "valid arguments.");
            Ada.Text_IO.New_Line (File => Ada.Text_IO.Current_Error);
            Put_Help (File => Ada.Text_IO.Current_Error);

            raise Argument_Error;
         else
            Argument_Field_Count (Current_Argument) :=
              Argument_Field_Count (Current_Argument) + 1;
         end if;
      end loop;
   end Process_Arguments;

   ---------------------------------------------------------------------------
   --  procedure Put_Help:
   --
   --  Writes a help message to the file.
   --
   --  Exceptions:
   --    Same as for Ada.Text_IO.Put_Line.

   procedure Put_Help (File : in     Ada.Text_IO.File_Type) is

      use Ada.Command_Line;
      use Ada.Integer_Text_IO;
      use Ada.Strings.Unbounded;
      use Ada.Text_IO;

   begin --  Put_Help
      Put_Line (File => File,
                Item => "Command line arguments for '" & Command_Name & "':");
      New_Line (File => File);

      for Argument in Argument_Names loop
         Put (File => File,
              Item => "   ");
         Put (File => File,
              Item => To_String (Argument));
         Put (File => File,
              Item => " " & To_String (Help (Argument)) & " [");

         if Obligatory (Argument) then
            Put (File => File,
                 Item => "obligatory");
         else
            Put (File => File,
                 Item => "optional");
         end if;

         if Maximum_Field_Count (Argument) = 0 then
            Put (File => File,
                 Item => " flag");
         elsif Minimum_Field_Count (Argument) =
               Maximum_Field_Count (Argument) then
            Put (File => File,
                 Item => ", exactly ");
            Put (File  => File,
                 Item  => Minimum_Field_Count (Argument),
                 Width => 0);

            if Minimum_Field_Count (Argument) = 1 then
               Put (File => File,
                    Item => " field");
            else
               Put (File => File,
                    Item => " fields");
            end if;
         else
            Put (File => File,
                 Item => ", ");
            Put (File  => File,
                 Item  => Minimum_Field_Count (Argument),
                 Width => 0);
            Put (File => File,
                 Item => " to ");
            Put (File  => File,
                 Item  => Maximum_Field_Count (Argument),
                 Width => 0);
            Put (File => File,
                 Item => " fields");
         end if;

         Put_Line (File => File,
                   Item => "]");
      end loop;

      New_Line (File => File);
   end Put_Help;

   ---------------------------------------------------------------------------
   --  function All_Arguments_Valid:
   --
   --  Checks if all the command line arguments are valid (according to
   --  Valid).
   --
   --  Exceptions:
   --    None

   function All_Arguments_Valid return Boolean is

      use Ada.Text_IO;

      OK : Boolean := True;

   begin --  All_Arguments_Valid
      for Argument in Argument_Names loop
         if Valid (Argument) then
            null; --  OK!
         else
            if OK then
               Put (File => Current_Error,
                    Item => "Error. Problems with the command line " &
                            "arguments: " & To_String (Argument));
            else
               Put (File => Current_Error,
                    Item => ", " & To_String (Argument));
            end if;

            OK := False;
         end if;
      end loop;

      if OK then
         null; --  OK!
      else
         Put_Line (File => Current_Error,
                   Item => ".");
      end if;

      return OK;
   end All_Arguments_Valid;

   ---------------------------------------------------------------------------
   --  function Valid:
   --
   --  Checks if Argument is valid (according to Obligatory,
   --  Minimum_Field_Count, and Maximum_Field_Count).
   --
   --  Exceptions:
   --    None

   function Valid (Argument : Argument_Names) return Boolean is

      subtype Valid_Field_Count_Range is Natural range
        Minimum_Field_Count (Argument) .. Maximum_Field_Count (Argument);

   begin --  Valid
      if Set (Argument) then
         return
           Field_Count (Argument) in
           Minimum_Field_Count (Argument) .. Maximum_Field_Count (Argument);
      else
         return not Obligatory (Argument);
      end if;
   end Valid;

   ---------------------------------------------------------------------------
   --  function Set:
   --
   --  Checks if Argument has been passed to the program.
   --
   --  Exceptions:
   --    None

   function Set (Argument : Argument_Names) return Boolean is

   begin --  Set
      return Argument_Index (Argument) > 0;
   end Set;

   pragma Inline (Set);

   ---------------------------------------------------------------------------
   --  function Field_Count:
   --
   --  Returns the number of fields passed along with Argument.
   --
   --  Exceptions:
   --    None

   function Field_Count (Argument : Argument_Names) return Natural is

   begin --  Field_Count
      return Argument_Field_Count (Argument);
   end Field_Count;

   pragma Inline (Field_Count);

   ---------------------------------------------------------------------------
   --  function Value:
   --
   --  Returns the Index field for Argument.
   --
   --  Exceptions:
   --    Argument_Error - if there isn't an Index field for Argument.

   function Value (Argument : Argument_Names;
                   Index    : Positive) return String is

   begin --  Value
      if Index <= Field_Count (Argument) then
         return Ada.Command_Line.Argument (Argument_Index (Argument) + Index);
      else
         Ada.Text_IO.Put_Line
           (File => Ada.Text_IO.Current_Error,
            Item => "Error: Asked for field number " &
                    Positive'Image (Index) & " for the argument '" &
                    To_String (Argument) & "'. Only " &
                    Positive'Image (Field_Count (Argument)) & " were " &
                    "passed to the program.");
         Ada.Text_IO.New_Line (File => Ada.Text_IO.Current_Error);
         Put_Help (File => Ada.Text_IO.Current_Error);

         raise Argument_Error;
      end if;
   end Value;

   ---------------------------------------------------------------------------
   --  function Value:
   --
   --  Returns the Index field for Argument (or Default).
   --
   --  Exceptions:
   --    None

   function Value (Argument : Argument_Names;
                   Default  : String;
                   Index    : Positive) return String is

   begin --  Value
      if Index <= Field_Count (Argument) then
         return Ada.Command_Line.Argument (Argument_Index (Argument) + Index);
      else
         return Default;
      end if;
   end Value;

   ---------------------------------------------------------------------------
   --  function Value:
   --
   --  Returns the Index field for Argument.
   --
   --  Exceptions:
   --    Argument_Error - if there isn't an Index field for Argument or
   --                     if the field isn't an Integer.

   function Value (Argument : Argument_Names;
                   Index    : Positive) return Integer is

   begin --  Value
      return Integer'Value (Value (Argument, Index));
   exception
      when Argument_Error =>
         raise; --  Propagate the exception from the String version of Value.
      when Constraint_Error =>
         Ada.Text_IO.Put_Line
           (File => Ada.Text_IO.Current_Error,
            Item => "Error: Field number " & Positive'Image (Index) & " for" &
                    " the argument '" & To_String (Argument) & "' should be" &
                    " an integer.");
         Ada.Text_IO.New_Line (File => Ada.Text_IO.Current_Error);
         Put_Help (File => Ada.Text_IO.Current_Error);

         raise Argument_Error;
      when others =>
         Ada.Text_IO.Put_Line
           (File => Ada.Text_IO.Current_Error,
            Item => "Error: An undocumented exception occured. Aborting ...");
         raise;
   end Value;

   ---------------------------------------------------------------------------
   --  function Value:
   --
   --  Returns the Index field for Argument (or Default).
   --
   --  Exceptions:
   --    Argument_Error - if the field isn't an Integer.

   function Value (Argument : Argument_Names;
                   Default  : Integer;
                   Index    : Positive) return Integer is

   begin --  Value
      return Integer'Value (Value (Argument, Integer'Image (Default), Index));
   exception
      when Constraint_Error =>
         Ada.Text_IO.Put_Line
           (File => Ada.Text_IO.Current_Error,
            Item => "Error: Field number " & Positive'Image (Index) & " for" &
                    " the argument '" & To_String (Argument) & "' should be" &
                    " an integer.");
         Ada.Text_IO.New_Line (File => Ada.Text_IO.Current_Error);
         Put_Help (File => Ada.Text_IO.Current_Error);

         raise Argument_Error;
      when others =>
         Ada.Text_IO.Put_Line
           (File => Ada.Text_IO.Current_Error,
            Item => "Error: An undocumented exception occured. Aborting ...");
         raise;
   end Value;

   ---------------------------------------------------------------------------
   --  function Value:
   --
   --  Returns the Index field for Argument.
   --
   --  Exceptions:
   --    Argument_Error - if there isn't an Index field for Argument or
   --                     if the field isn't an Float.

   function Value (Argument : Argument_Names;
                   Index    : Positive) return Float is

   begin --  Value
      return Float'Value (Value (Argument, Index));
   exception
      when Argument_Error =>
         raise; --  Propagate the exception from the String version of Value.
      when Constraint_Error =>
         Ada.Text_IO.Put_Line
           (File => Ada.Text_IO.Current_Error,
            Item => "Error: Field number " & Positive'Image (Index) & " for" &
                    " the argument '" & To_String (Argument) & "' should be" &
                    " an integer.");
         Ada.Text_IO.New_Line (File => Ada.Text_IO.Current_Error);
         Put_Help (File => Ada.Text_IO.Current_Error);

         raise Argument_Error;
      when others =>
         Ada.Text_IO.Put_Line
           (File => Ada.Text_IO.Current_Error,
            Item => "Error: An undocumented exception occured. Aborting ...");
         raise;
   end Value;

   ---------------------------------------------------------------------------
   --  function Value:
   --
   --  Returns the Index field for Argument (or Default).
   --
   --  Exceptions:
   --    Argument_Error - if the field isn't an Float.

   function Value (Argument : Argument_Names;
                   Default  : Float;
                   Index    : Positive) return Float is

   begin --  Value
      return Float'Value (Value (Argument, Float'Image (Default), Index));
   exception
      when Constraint_Error =>
         Ada.Text_IO.Put_Line
           (File => Ada.Text_IO.Current_Error,
            Item => "Error: Field number " & Positive'Image (Index) & " for" &
                    " the argument '" & To_String (Argument) & "' should be" &
                    " an integer.");
         Ada.Text_IO.New_Line (File => Ada.Text_IO.Current_Error);
         Put_Help (File => Ada.Text_IO.Current_Error);

         raise Argument_Error;
      when others =>
         Ada.Text_IO.Put_Line
           (File => Ada.Text_IO.Current_Error,
            Item => "Error: An undocumented exception occured. Aborting ...");
         raise;
   end Value;

   ---------------------------------------------------------------------------

begin --  Generic_Command_Line_Processing
   Process_Arguments;

   if Check_Arguments then
      if All_Arguments_Valid then
         null; --  OK!
      else
         Ada.Text_IO.New_Line (File => Ada.Text_IO.Current_Error);
         Put_Help (File => Ada.Text_IO.Current_Error);

         raise Argument_Error;
      end if;
   end if;
end Generic_Command_Line_Processing;

Typeset with Ada_To_HTML (Jacob and Jesper)