asis_2019.0.0_3ca32fa2/tools/tool_utils/asis_ul-projects-aggregate.adb

------------------------------------------------------------------------------
--                                                                          --
--                     ASIS UTILITY LIBRARY COMPONENTS                      --
--                                                                          --
--            A S I S _ U L . P R O J E C T S . A G G R E G A T E           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                      Copyright (C) 2018-2019, AdaCore                    --
--                                                                          --
-- Asis Utility Library (ASIS UL) 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.  ASIS UL  is distributed in the hope that it --
-- will  be  useful,  but  WITHOUT  ANY  WARRANTY; without even the implied --
-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --
-- GNU  General Public License for more details. You should have received a --
-- copy of the  GNU General Public License  distributed with GNAT; see file --
-- COPYING3. If not,  go to http://www.gnu.org/licenses for a complete copy --
-- of the license.                                                          --
--                                                                          --
-- ASIS UL is maintained by AdaCore (http://www.adacore.com).               --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2012;

with Ada.Command_Line;  use Ada.Command_Line;
with Ada.Containers.Ordered_Sets;
with Ada.Strings;       use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO;

with GNAT.OS_Lib;       use GNAT.OS_Lib;

with GNATCOLL.VFS;      use GNATCOLL.VFS;

with ASIS_UL.Common;    use ASIS_UL.Common;
with ASIS_UL.Misc;
with ASIS_UL.Options;   use ASIS_UL.Options;
with ASIS_UL.Output;    use ASIS_UL.Output;

package body ASIS_UL.Projects.Aggregate is

   --------------------------------------------
   --  Storage for projects being aggregated --
   --------------------------------------------

   type Project_Record is record
      Project_Path : Virtual_File := No_File;
      --  Full path to a project file

      --  What else may we need?..
   end record;

   function "=" (L, R : Project_Record) return Boolean;
   function "<" (L, R : Project_Record) return Boolean;
   --  These two functions compare project paths

   package Aggregated_Projects_Sets is new Ada.Containers.Ordered_Sets
     (Element_Type => Project_Record);
   use Aggregated_Projects_Sets;

   Aggregated_Projects : Set;

   --  Project iterator - old-fasion manual iteration through the ordered set
   --  is used.
   Iterator_Done   : Boolean := True;
   Iterator_C      : Cursor  := No_Element;
   Iterator_El     : Project_Record;

   Aggregated_Prj_Name : String_Access;
   --  The name of a project file passed as a parameter of '-A' option

   ------------------------
   --  Local subprograms --
   ------------------------

   ------------
   --  Debug --
   ------------

   procedure Stored_Aggregated_Project_Debug_Info (C : Cursor);
   --  Prints out the debig info about a stored aggregated project.

   -------------
   -- "=" "<" --
   -------------

   function "=" (L, R : Project_Record) return Boolean is
   begin
      if R.Project_Path = No_File and then R.Project_Path = No_File then
         return True;
      elsif R.Project_Path = No_File or else R.Project_Path = No_File then
         return False;
      else
         return Filesystem_String'(Full_Name (L.Project_Path, True)) =
                  Full_Name (R.Project_Path, True);
      end if;
   end "=";

   function "<" (L, R : Project_Record) return Boolean is
   begin
      if L = R then
         return False;
      elsif L.Project_Path = No_File then
         return True;
      elsif R.Project_Path = No_File then
         return False;
      else
         return Filesystem_String'(Full_Name (L.Project_Path, True)) <
                  Full_Name (R.Project_Path, True);
      end if;
   end "<";

   -------------------------------------
   -- Aggregated_Projects_Debug_Image --
   -------------------------------------

   procedure Aggregated_Projects_Debug_Image is
   begin
      if Aggregated_Projects.Is_Empty then
         Info ("No aggregated projects stored");
      else
         Info ("***Stored aggregated projects debug info***");
         Aggregated_Projects.Iterate
           (Process => Stored_Aggregated_Project_Debug_Info'Access);
      end if;
   end Aggregated_Projects_Debug_Image;

   ---------------------------------
   -- Collect_Aggregated_Projects --
   ---------------------------------

   procedure Collect_Aggregated_Projects (P : Project_Type) is
      Iter : Project_Iterator := Start (Root_Project     => P,
                                        Recursive        => True,
                                        Direct_Only      => True);

      Arg_Prj_Name : constant Filesystem_String :=
        Full_Name (P.Project_Path, Normalize => True);

      New_Prj_Rec : Project_Record;

      Inserted : Boolean;
      C        : Cursor;
   begin
      if Debug_Flag_A then
         Ada.Text_IO.Put_Line (String (Arg_Prj_Name));
      end if;

      while Current (Iter) /= No_Project loop

         if Is_Aggregate_Project (Current (Iter)) then
            if Arg_Prj_Name /= Full_Name (Current (Iter).Project_Path,
                                          Normalize => True)
            then
               --  Iterator also returns the top project the iteration starts
               --  from, we should not process it again to awoid cycling
               Collect_Aggregated_Projects (Current (Iter));
            end if;
         else
            New_Prj_Rec.Project_Path :=  Current (Iter).Project_Path;

            Insert (Aggregated_Projects,
                    New_Prj_Rec,
                    C,
                    Inserted);
         end if;

         Next (Iter);
      end loop;

   end Collect_Aggregated_Projects;

   ----------------------------
   -- Get_Aggregated_Prj_Src --
   ----------------------------

   function Get_Aggregated_Prj_Src return Virtual_File is
     (Aggregated_Projects.First_Element.Project_Path);

   ----------------------------
   -- Get_Aggregated_Project --
   ----------------------------

   function Get_Aggregated_Project return String is (Aggregated_Prj_Name.all);

   -------------------
   -- Next_Prj_Name --
   -------------------

   function Next_Prj_Name return Filesystem_String_Access is
   begin
      if not Iterator_Done then
         return new Filesystem_String'(Full_Name (Iterator_El.Project_Path));
      else
         Error ("attempt to get project name for non-active iterator");
         raise Fatal_Error;
      end if;
   end Next_Prj_Name;

   --------------------------------
   -- Num_Of_Aggregated_Projects --
   --------------------------------

   function Num_Of_Aggregated_Projects return Natural is
     (Natural (Aggregated_Projects.Length));

   -----------------------
   -- Prj_Iterator_Done --
   -----------------------

   function Prj_Iterator_Done return Boolean is (Iterator_Done);

   -----------------------
   -- Prj_Iterator_Next --
   -----------------------

   procedure Prj_Iterator_Next is
   begin
      Iterator_C := Next (Iterator_C);

      if not Has_Element (Iterator_C) then
         Iterator_Done := True;
      else
         Iterator_El := Element (Iterator_C);
      end if;

   end Prj_Iterator_Next;

   ---------------------------------
   -- Process_Aggregated_Projects --
   ---------------------------------

   procedure Process_Aggregated_Projects
     (My_Project : Arg_Project_Type'Class)
   is
      Report_File_Name     : constant String := (if Text_Report_ON then
                                                     Get_Report_File_Name
                                                 else
                                                     "");
      XML_Report_File_Name : constant String := (if XML_Report_ON then
                                                    Get_XML_Report_File_Name
                                                 else
                                                    "");

      Count : Natural := 1;
      --  Counts iterations on aggregated projects, this number is used to
      --  create a uniqie name of the report files for each iteration

      Prj_Out_File_Start     : String_Access;
      Prj_XML_Out_File_Start : String_Access;
      --  Start of the name of the tool out file for each iteration. To make
      --  a unique name, we add the text image of Count after it.

      Idx : Natural;

      Prj_Args       : Argument_List (1 .. 2);
      Out_Args       : Argument_List (1 .. 4);
      Out_Args_Count : constant Integer :=
        (if Text_Report_ON and then XML_Report_ON then 4 else 2);

      Args      : Argument_List (1 .. Argument_Count);
      Arg_Count : Natural := 0;
      Skip_Next : Boolean := False;

      Exit_Code : Integer;

      Full_Tool_Name : constant String_Access :=
        Locate_Exec_On_Path (Tool_Name.all);
   begin
      if Full_Tool_Name = null then
         Error ("Cannot locate Tool_Name.all on path, possible installation " &
                "problem");
         raise Fatal_Error;
      end if;

      if Text_Report_ON then
         Idx := Index (Report_File_Name,
                       (1 => Directory_Separator),
                       Backward);

         Prj_Out_File_Start := new String'(
            (if Idx = 0 then
                ""
             else
                Report_File_Name (Report_File_Name'First .. Idx)) &
                Tool_Name.all & "_");
      end if;

      if XML_Report_ON then
         Idx := Index (XML_Report_File_Name,
                       (1 => Directory_Separator),
                       Backward);

         Prj_XML_Out_File_Start := new String'(
            (if Idx = 0 then
                ""
             else
                XML_Report_File_Name (XML_Report_File_Name'First .. Idx)) &
                Tool_Name.all & "_");
      end if;

      Prj_Args (1) := new String'("-A");
      Out_Args (1) := new String'(if Text_Report_ON then "-o" else "-ox");

      if Out_Args_Count = 4 then
         Out_Args (3) := new String'("-ox");
      end if;

      for J in 1 .. Argument_Count loop
         declare
            Arg : constant String := Argument (J);
         begin
            if Skip_Next then
               Skip_Next := False;
            else
               if Arg = "-o" or else Arg = "-ox" then
                  Skip_Next := True;
               else
                  Idx := Index (Arg, "-o=", Forward);

                  if Idx = 0 then
                     Idx := Index (Arg, "-ox=", Forward);
                  end if;

                  if Idx = 0 then
                     Arg_Count := Arg_Count + 1;

                     Args (Arg_Count) := new String'(Arg);
                  end if;
               end if;
            end if;
         end;

      end loop;

      Aggregate_Project_Report_Header (My_Project);

      Start_Prj_Iterator;

      while not Prj_Iterator_Done loop

         if Verbose_Mode then
            Info ("Processing aggregated project " &
                  String (Next_Prj_Name.all));
         end if;

         Free (Prj_Args (2));
         Prj_Args (2) := new String'(String (Next_Prj_Name.all));

         Free (Out_Args (2));

         Out_Args (2) := new String'
                           ((if Text_Report_ON then
                                Prj_Out_File_Start.all &
                                ASIS_UL.Misc.Image (Count) & ".out"
                             else
                                Prj_XML_Out_File_Start.all &
                                ASIS_UL.Misc.Image (Count) & ".xml"));

         if Out_Args_Count = 4 then
            Out_Args (4) :=
              new String'(Prj_XML_Out_File_Start.all &
                          ASIS_UL.Misc.Image (Count) & ".xml");
         end if;

         if Debug_Flag_C then
            Info ("Processing aggregated project " &
                   String (Next_Prj_Name.all));
            Info_No_EOL (Tool_Name.all);

            for J in Prj_Args'Range loop
               Info_No_EOL (" " & Prj_Args (J).all);
            end loop;

            for J in 1 .. Out_Args_Count loop
               Info_No_EOL (" " & Out_Args (J).all);
            end loop;

            for J in 1 .. Arg_Count loop
               Info_No_EOL (" " & Args (J).all);
            end loop;

            Info ("");

         end if;

         Report_Aggregated_Project
           (Aggregate_Prj          => My_Project,
            Arrgegated_Prj_Name    => Prj_Args (2).all,
            Expected_Text_Out_File => (if Text_Report_ON then
                                          Out_Args (2).all
                                       else
                                          ""),
            Expected_XML_Out_File  => (if XML_Report_ON then
                                          (if Out_Args_Count = 2 then
                                              Out_Args (2).all
                                          else
                                              Out_Args (4).all)
                                       else
                                          ""));

         Exit_Code := Spawn (Program_Name => Full_Tool_Name.all,
                             Args         => Prj_Args                       &
                                             Out_Args (1 .. Out_Args_Count) &
                                             Args (1 .. Arg_Count));

         Report_Aggregated_Project_Exit_Code
           (Aggregate_Prj       => My_Project,
            Exit_Code           => Exit_Code);

         Prj_Iterator_Next;
         Count := Count + 1;
      end loop;

      Close_Aggregate_Project_Report (My_Project);

   end Process_Aggregated_Projects;

   ------------------------
   -- Start_Prj_Iterator --
   ------------------------

   procedure Start_Prj_Iterator is
   begin
      Iterator_Done   := False;
      Iterator_C      := First (Aggregated_Projects);
      Iterator_El     := Element (Iterator_C);
   exception
      when others =>
         Error ("Cannot start iterator on aggregated projects");
         raise Fatal_Error;
   end Start_Prj_Iterator;

   ------------------------------
   -- Store_Aggregated_Project --
   ------------------------------

   procedure Store_Aggregated_Project (S : String) is
   begin
      Free (Aggregated_Prj_Name);
      Aggregated_Prj_Name := new String'(S);
   end Store_Aggregated_Project;

   ------------------------------------------
   -- Stored_Aggregated_Project_Debug_Info --
   ------------------------------------------

   procedure Stored_Aggregated_Project_Debug_Info (C : Cursor) is
      PR  : Project_Record;
      Pad : constant String := "   ";
   begin
      if not Has_Element (C) then
         Info (Pad & "No project stored!!!");
      end if;

      PR := Element (C);

      Info (Pad & "project name: " &
            String (Filesystem_String'(Full_Name (PR.Project_Path, True))));
      Info ("");

   end Stored_Aggregated_Project_Debug_Info;

end ASIS_UL.Projects.Aggregate;