gnatcoll_24.0.0_11c512d1/src/gnatcoll-arg_lists.adb

------------------------------------------------------------------------------
--                             G N A T C O L L                              --
--                                                                          --
--                     Copyright (C) 2009-2021, 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    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

with GNAT.OS_Lib; use GNAT.OS_Lib;

with Ada.Unchecked_Deallocation;
with Ada.Containers; use Ada.Containers;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Strings.Fixed;       use Ada.Strings.Fixed;
with Ada.Strings.Maps;        use Ada.Strings.Maps;

with GNATCOLL.Scripts.Utils; use GNATCOLL.Scripts.Utils;

package body GNATCOLL.Arg_Lists is

   procedure Parse_Command_Line_String
     (CL   : in out Arg_List;
      Text : String)
      with Pre => CL.Mode = Separate_Args;
   --  Factor code between variants of Parse_String.
   --  This processes Text as if it were passed on a command line (for instance
   --  the bash command line) and adds the arguments to CL.

   function Escape_Backslashes (A : Unbounded_String) return Unbounded_String;
   --  Escape backslashes in A

   ------------------------
   -- Escape_Backslashes --
   ------------------------

   function Escape_Backslashes
     (A : Unbounded_String) return Unbounded_String is
      S : constant String := To_String (A);
      R : Unbounded_String;
   begin
      for J in S'Range loop
         case S (J) is
            when '\' =>
               Append (R, "\\");
            when others =>
               Append (R, S (J));
         end case;
      end loop;
      return R;
   end Escape_Backslashes;

   -------------------------------
   -- Parse_Command_Line_String --
   -------------------------------

   procedure Parse_Command_Line_String
     (CL   : in out Arg_List;
      Text : String)
   is
      function Process (A : String) return Argument_Type
         with Pre => A'Length > 0;
      --  Post-process on each argument returned by Argument_String_To_List.
      --  Note that Argument_String_To_List_With_Triple_Quotes never returns
      --  empty arguments.

      -------------
      -- Process --
      -------------

      function Process (A : String) return Argument_Type is
      begin
         --  Argument_String_To_List does not remove single quotes around an
         --  argument: do this now.
         if A (A'First) = '"' and then A (A'Last) = '"' then
            return (One_Arg,
                    To_Unbounded_String (A (A'First + 1 .. A'Last - 1)));
         end if;

         return (Expandable, To_Unbounded_String (A));
      end Process;

      Local_Args : Argument_List_Access;
      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
        (Argument_List, Argument_List_Access);
   begin

      --  Get rid of the leading spaces, as this would result in multiple
      --  arguments in the call to Argument_String_To_List_With_Triple_Quotes
      --  Also remove trailing spaces, since otherwise the last argument on the
      --  command line, when surrounded with quotes, will be seen by Process as
      --  ending with ASCII.LF, and therefore the quotes will not be removed.

      Local_Args := Argument_String_To_List_With_Triple_Quotes
        (Trim
           (Text,
            Left  => To_Set (' ' & ASCII.LF & ASCII.HT),
            Right => To_Set (' ' & ASCII.LF & ASCII.HT)));

      for J in Local_Args'Range loop
         CL.V.Append (Process (Local_Args (J).all));
         Free (Local_Args (J));
      end loop;

      Unchecked_Free (Local_Args);
   end Parse_Command_Line_String;

   ------------------
   -- Parse_String --
   ------------------

   function Parse_String
     (Text : String;
      Mode : Command_Line_Mode) return Arg_List
   is
      CL : Arg_List;

   begin
      CL.Mode := Mode;

      if Mode = Separate_Args then
         Parse_Command_Line_String (CL, Text);
      else
         CL.V.Append ((One_Arg, To_Unbounded_String (Text)));
      end if;

      return CL;
   end Parse_String;

   ------------------
   -- Parse_String --
   ------------------

   function Parse_String
     (Command : String; Text : String) return Arg_List
   is
      CL : Arg_List := Create (Command);
   begin
      Parse_Command_Line_String (CL, Text);
      return CL;
   end Parse_String;

   -----------------
   -- Get_Command --
   -----------------

   function Get_Command (C : Arg_List) return String is
   begin
      if C.V.Is_Empty then
         return "";
      else
         return To_String (C.V.Element (0).Text);
      end if;
   end Get_Command;

   ------------
   -- Create --
   ------------

   function Create (Command : String) return Arg_List is
      C : Arg_List;
   begin
      C.V.Append ((One_Arg, To_Unbounded_String (Command)));
      return C;
   end Create;

   ---------------------
   -- Append_Argument --
   ---------------------

   procedure Append_Argument
     (C        : in out Arg_List;
      Argument : String;
      Mode     : Argument_Mode) is
   begin
      C.V.Append ((Mode, To_Unbounded_String (Argument)));
   end Append_Argument;

   -------------
   -- To_List --
   -------------

   function To_List
     (C               : Arg_List;
      Include_Command : Boolean) return GNAT.OS_Lib.Argument_List
   is
      First : Natural;
   begin
      if Include_Command then
         First := 0;
      else
         First := 1;
      end if;

      declare
         L : GNAT.OS_Lib.Argument_List (1 .. Natural (C.V.Length) - First);
      begin
         for J in First .. Natural (C.V.Length) - 1 loop
            L (J + 1 - First) := new String'
              (To_String (C.V.Element (J).Text));
         end loop;
         return L;
      end;
   end To_List;

   -----------------------
   -- To_Display_String --
   -----------------------

   function To_Display_String
     (C               : Arg_List;
      Include_Command : Boolean := True;
      Max_Arg_Length  : Positive := Positive'Last) return String
   is
      Result : Unbounded_String := To_Unbounded_String ("");
      Start  : Natural := 1;
   begin
      if not Include_Command then
         Start := 2;
      end if;

      for Index in Start .. Natural (C.V.Length) loop
         declare
            Arg_Len : constant Natural :=
                        Length (C.V.Element (Index - 1).Text);
         begin
            if Arg_Len > Max_Arg_Length then
               Append
                 (Result,
                  Unbounded_Slice (C.V.Element (Index - 1).Text,
                    1, Max_Arg_Length - 1));
               Append (Result, "...");
            else
               Append (Result, C.V.Element (Index - 1).Text);
            end if;
         end;

         if Index < Natural (C.V.Length) then
            Append (Result, " ");
         end if;
      end loop;
      return To_String (Result);
   end To_Display_String;

   ---------------------
   -- To_Debug_String --
   ---------------------

   function To_Debug_String (C : Arg_List) return String is
      Result : Unbounded_String := To_Unbounded_String ("Command: ");
   begin
      Append (Result, C.V.Element (0).Text);

      for J in 1 .. Natural (C.V.Length) - 1 loop
         Append (Result, ASCII.LF & "Arg: " & C.V.Element (J).Text);
      end loop;
      return To_String (Result);
   end To_Debug_String;

   ----------------------
   -- To_Script_String --
   ----------------------

   function To_Script_String (C : Arg_List) return String is

      function Arg (A : Unbounded_String) return Unbounded_String;
      --  Auxiliary function to process one arg

      ---------
      -- Arg --
      ---------

      function Arg (A : Unbounded_String) return Unbounded_String is
         S : constant String := To_String (A);
         R : Unbounded_String;
      begin
         for J in S'Range loop
            case S (J) is
            when '\' =>
               Append (R, "\\");
            when ' ' =>
               Append (R, "\ ");
            when '"' =>
               Append (R, "\""");
            when others =>
               Append (R, S (J));
            end case;
         end loop;
         return R;
      end Arg;

      Result : Unbounded_String;
   begin
      if C = Empty_Command_Line then
         return "";
      end if;

      if C.Mode = Raw_String then
         return To_String (C.V.Element (0).Text);
      end if;

      --  Convert all arguments
      for J in 1 .. Natural (C.V.Length) loop
         Append (Result, Arg (C.V.Element (J - 1).Text));
         Append (Result, ' ');
      end loop;

      --  Return result without the trailing space
      declare
         R : constant String := To_String (Result);
      begin
         return R (R'First .. R'Last - 1);
      end;
   end To_Script_String;

   ----------------
   -- Substitute --
   ----------------

   procedure Substitute
     (CL       : in out Arg_List;
      Char     : Character;
      Callback : access function
                   (Param : String; Mode : Command_Line_Mode) return Arg_List)
   is
      New_CL  : Arg_List;

      function Expand_In_String (A : Unbounded_String) return Unbounded_String;
      --  Expand the argument in place in S and return the result

      ----------------------
      -- Expand_In_String --
      ----------------------

      function Expand_In_String
        (A : Unbounded_String) return Unbounded_String
      is
         S   : constant String := To_String (A);
         U   : Unbounded_String;
         J   : Natural;
         Beg : Natural;
         New_CL  : Arg_List;
         Skip_Ending_Bracket : Boolean := False;
      begin
         if S = "" then
            return Null_Unbounded_String;
         end if;

         J := S'First;
         while J <= S'Last loop
            if S (J) = Char and then J < S'Last then
               --  Skip to the next separator
               J := J + 1;
               Beg := J;

               if S (J) = '{' then
                  --  An '{' immediately follows the special character:
                  --  the parameter should be the whole string contained
                  --  between this and the ending '}'.
                  Skip_Ending_Bracket := True;
                  J := J + 1;
                  Beg := J;
                  while J <= S'Last
                    and then S (J) /= '}'
                  loop
                     J := J + 1;
                  end loop;
               else
                  Skip_Ending_Bracket := False;
                  while J <= S'Last
                    and then (Is_Alphanumeric (S (J))
                              or else S (J) = '*'
                              or else S (J) = '-'
                              or else S (J) = '@')

                  loop
                     J := J + 1;
                  end loop;
               end if;

               --  A doubling of the special character indicates that we
               --  are inserting it.
               if S (J - 1) = Char then
                  Append (U, Char);
                  J := J + 1;
               else
                  New_CL := Callback (S (Beg .. J - 1), Raw_String);

                  for K in 0 .. Natural (New_CL.V.Length) - 1 loop

                     if CL.Mode = Raw_String then
                        Append
                          (U,
                           Escape_Backslashes (New_CL.V.Element (K).Text));
                     else
                        Append (U, New_CL.V.Element (K).Text);
                     end if;

                     if K < Natural (New_CL.V.Length) - 1 then
                        Append (U, ' ');
                     end if;
                  end loop;
               end if;

               if Skip_Ending_Bracket then
                  J := J + 1;
               end if;
            else
               Append (U, S (J));
               J := J + 1;
            end if;
         end loop;

         return U;
      end Expand_In_String;

   begin
      New_CL.Mode := CL.Mode;

      if CL = Empty_Command_Line then
         return;
      end if;

      if Callback = null then
         return;
      end if;

      case CL.Mode is
         when Raw_String =>
            declare
               U : constant Unbounded_String := Expand_In_String
                 (CL.V.Element (0).Text);
            begin
               CL.V.Replace_Element (0, (One_Arg, U));
            end;

         when Separate_Args =>
            for J in 0 .. Natural (CL.V.Length) - 1 loop
               case CL.V.Element (J).Mode is
                  when One_Arg =>
                     declare
                        U : constant Unbounded_String := Expand_In_String
                          (CL.V.Element (J).Text);
                     begin
                        New_CL.V.Append ((One_Arg, U));
                     end;

                  when Expandable =>
                     declare
                        P : constant Unbounded_String := CL.V.Element (J).Text;
                     begin
                        if Element (P, 1) = Char then
                           declare
                              List : constant Arg_List := Callback
                                (Slice (P, 2, Length (P)), Separate_Args);
                           begin
                              for Item of List.V loop
                                 New_CL.V.Append (Item);
                              end loop;
                           end;
                        else
                           New_CL.V.Append
                             ((Expandable, Expand_In_String (P)));
                        end if;
                     end;
               end case;
            end loop;

            CL := New_CL;
      end case;
   end Substitute;

   -----------------
   -- Args_Length --
   -----------------

   function Args_Length (C : Arg_List) return Integer is
   begin
      return Natural (C.V.Length) - 1;
   end Args_Length;

   -------------
   -- Nth_Arg --
   -------------

   function Nth_Arg (C : Arg_List; N : Natural) return String is
   begin
      return To_String (C.V.Element (N).Text);
   end Nth_Arg;

   function Nth_Arg (C : Arg_List; N : Natural) return Unbounded_String is
   begin
      return C.V.Element (N).Text;
   end Nth_Arg;

   -----------------
   -- Set_Nth_Arg --
   -----------------

   procedure Set_Nth_Arg (C : in out Arg_List; N : Natural; Arg : String) is
   begin
      --  If there are not enough arguments, create them
      while N > Args_Length (C) loop
         C.V.Append ((One_Arg, Null_Unbounded_String));
      end loop;

      C.V.Replace_Element
        (N, (C.V.Element (N).Mode, To_Unbounded_String (Arg)));
   end Set_Nth_Arg;

   -----------------------------
   -- Argument_List_To_String --
   -----------------------------

   function Argument_List_To_String
     (List           : GNAT.Strings.String_List;
      Protect_Quotes : Boolean := True) return String
   is
      Length : Natural := 0;
   begin
      for L in List'Range loop
         Length := Length + List (L)'Length + 1;

         if Protect_Quotes then
            for S in List (L)'Range loop
               if List (L)(S) = '"'
                 or else List (L)(S) = ' '
                 or else List (L) (S) = '\'
                 or else List (L) (S) = '''
               then
                  Length := Length + 1;
               end if;
            end loop;
         end if;
      end loop;

      declare
         S     : String (1 .. Length);
         Index : Positive := S'First;
      begin
         for L in List'Range loop
            for J in List (L)'Range loop
               if Protect_Quotes then
                  if List (L) (J) = '"'
                    or else List (L) (J) = ' '
                    or else List (L) (J) = '\'
                    or else List (L) (J) = '''
                  then
                     S (Index) := '\';
                     Index := Index + 1;
                  end if;
               end if;
               S (Index) := List (L)(J);
               Index := Index + 1;
            end loop;
            S (Index) := ' ';
            Index := Index + 1;
         end loop;
         return S (1 .. S'Last - 1);  -- Ignore last space
      end;
   end Argument_List_To_String;

end GNATCOLL.Arg_Lists;