libgpr2_24.0.0_eda3c693/tools/src/gprtools-util.adb

------------------------------------------------------------------------------
--                                                                          --
--                           GPR2 PROJECT MANAGER                           --
--                                                                          --
--                     Copyright (C) 2019-2023, AdaCore                     --
--                                                                          --
-- This is  free  software;  you can redistribute it and/or modify it under --
-- terms of the  GNU  General Public License as published by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  This software 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. 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  COPYING. If not, --
-- see <http://www.gnu.org/licenses/>.                                      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Directories;
with Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO;

with GNAT.Case_Util;
with GNAT.OS_Lib;
with GNATCOLL.Utils;

package body GPRtools.Util is

   use Ada;
   use Ada.Strings.Unbounded;

   Partial_Prefix : constant Simple_Name := "p__";

   Keep_Program_Name : Unbounded_String;

   -------------------------------
   -- Check_For_Default_Project --
   -------------------------------

   function Check_For_Default_Project return GPR2.Path_Name.Object is
      use Directories;
      Default_Name : constant String := "default.gpr";
      Search       : Search_Type;
      Item         : Directory_Entry_Type;

   begin
      if Exists (Default_Name)
        and then Kind (Default_Name) = Ordinary_File
      then
         return Path_Name.Create_File (Filename_Type (Default_Name));
      end if;

      Start_Search
        (Search, ".", "*.gpr", (Ordinary_File => True, others => False));

      if More_Entries (Search) then
         Get_Next_Entry (Search, Item);

         if not More_Entries (Search) then
            --  Only one project in current directory can be default one

            return Path_Name.Create_File (Filename_Type (Full_Name (Item)));
         end if;
      end if;

      return Path_Name.Undefined;
   end Check_For_Default_Project;

   ----------------------------
   -- Executable_Prefix_Path --
   ----------------------------

   function Executable_Prefix_Path return String is
      use GNAT;
      use GNATCOLL;

      Exec_Name : constant String := Command_Line.Command_Name;

      function Get_Install_Dir (S : String) return String;
      --  S is the executable name preceded by the absolute or relative path,
      --  e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
      --  lies (in the example "C:\usr"). If the executable is not in a "bin"
      --  directory, return "".

      ---------------------
      -- Get_Install_Dir --
      ---------------------

      function Get_Install_Dir (S : String) return String is
         Exec      : String  :=
                       OS_Lib.Normalize_Pathname (S, Resolve_Links => True);
         Path_Last : Integer := 0;

      begin
         for J in reverse Exec'Range loop
            if Utils.Is_Directory_Separator (Exec (J)) then
               Path_Last := J - 1;
               exit;
            end if;
         end loop;

         if Path_Last >= Exec'First + 2 then
            Case_Util.To_Lower (Exec (Path_Last - 2 .. Path_Last));
         end if;

         if Path_Last < Exec'First + 2
           or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
           or else (Path_Last - 3 >= Exec'First
                      and then
                    not Utils.Is_Directory_Separator (Exec (Path_Last - 3)))
         then
            return "";
         end if;

         return (Exec (Exec'First .. Path_Last - 4))
           & OS_Lib.Directory_Separator;
      end Get_Install_Dir;

   --  Beginning of Executable_Prefix_Path

   begin
      --  First determine if a path prefix was placed in front of the
      --  executable name.

      if GPR2.Has_Directory_Separator (Exec_Name) then
         return Get_Install_Dir (Exec_Name);
      end if;

      --  If we get here, the user has typed the executable name with no
      --  directory prefix.

      declare
         Path : constant String := Locate_Exec_On_Path (Exec_Name);
      begin
         return (if Path = "" then "" else Get_Install_Dir (Path));
      end;
   end Executable_Prefix_Path;

   ---------------
   -- Exit_Code --
   ---------------

   function Exit_Code
     (Code : Exit_Code_Type) return Ada.Command_Line.Exit_Status is
   begin
      case Code is
         when E_Success    => return 0;
         when E_Warnings   => return 0;
         when E_No_Compile => return 1;
         when E_Fatal      => return 4;
         when E_Errors     => return 5;
         when E_No_Code    => return 6;
         when E_Abort      => return 16#FF#;
      end case;
   end Exit_Code;

   ------------------
   -- Exit_Program --
   ------------------

   procedure Exit_Program (Exit_Code : Exit_Code_Type) is
      use GNAT.OS_Lib;
   begin
      --  The program will exit with the following status:

      --    0 if the object file has been generated (with or without warnings)
      --    1 if recompilation was not needed (smart recompilation)
      --    4 for a fatal error
      --    5 if there were errors
      --    6 if no code has been generated (spec)

      --  Note that exit code 3 is not used and must not be used as this is
      --  the code returned by a program aborted via C abort() routine on
      --  Windows. GCC checks for that case and thinks that the child process
      --  has been aborted. This code (exit code 3) used to be the code used
      --  for E_No_Code, but E_No_Code was changed to 6 for this reason.

      case Exit_Code is
         when E_Success    => OS_Exit (0);
         when E_Warnings   => OS_Exit (0);
         when E_No_Compile => OS_Exit (1);
         when E_Fatal      => OS_Exit (4);
         when E_Errors     => OS_Exit (5);
         when E_No_Code    => OS_Exit (6);
         when E_Abort      => OS_Abort;
      end case;
   end Exit_Program;

   ------------------
   -- Fail_Program --
   ------------------

   procedure Fail_Program (Message : String) is
   begin
      Finish_Program (E_Fatal, Message);
   end Fail_Program;

   --------------------
   -- Finish_Program --
   --------------------

   procedure Finish_Program
     (Exit_Code : Exit_Code_Type := E_Success;
      Message   : String := "")
   is
      use Ada.Text_IO;
   begin
      if Message'Length > 0 then
         Put_Line
           ((if Exit_Code = E_Success
             then Standard_Output
             else Standard_Error),
            To_String (Keep_Program_Name) & ": " & Message);
      end if;

      Exit_Program (Exit_Code);
   end Finish_Program;

   ----------------------------
   -- Is_Ada_Predefined_Unit --
   ----------------------------

   function Is_Ada_Predefined_Unit (Unit : Name_Type) return Boolean is
      use GNATCOLL.Utils;

      Lower_Unit : constant String := To_Lower (Unit);
   begin
      return Lower_Unit = "ada"
        or else Lower_Unit = "gnat"
        or else Lower_Unit = "interfaces"
        or else Lower_Unit = "system"
        or else Lower_Unit = "calendar"
        or else Lower_Unit = "machine_code"
        or else Lower_Unit = "unchecked_conversion"
        or else Lower_Unit = "unchecked_deallocation"
        or else Lower_Unit = "direct_io"
        or else Lower_Unit = "io_exceptions"
        or else Lower_Unit = "sequential_io"
        or else Lower_Unit = "text_io"
        or else Starts_With (Lower_Unit, "ada.")
        or else Starts_With (Lower_Unit, "gnat.")
        or else Starts_With (Lower_Unit, "system.")
        or else Starts_With (Lower_Unit, "interfaces.");
   end Is_Ada_Predefined_Unit;

   -------------------------
   -- Locate_Exec_On_Path --
   -------------------------

   function Locate_Exec_On_Path (Exec_Name : String) return String is
      use type GNAT.OS_Lib.String_Access;

      Path     : GNAT.OS_Lib.String_Access
        := GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name);
      Path_Str : constant String := (if Path = null then "" else Path.all);
   begin
      GNAT.OS_Lib.Free (Path);
      return Path_Str;
   end Locate_Exec_On_Path;

   ---------------------
   -- Output_Messages --
   ---------------------

   procedure Output_Messages
     (Options : GPRtools.Options.Base_Options'Class)
   is
   begin
      Options.Config_Project_Log.Output_Messages
        (Information    => Options.Verbosity = Very_Verbose,
         Warning        => Options.Warnings,
         Lint           => Options.Verbosity = Very_Verbose,
         Full_Path_Name => Options.Full_Path_Name_For_Brief);
      if Options.Tree /= null and then Options.Tree.Has_Messages then
         Options.Tree.all.Log_Messages.Output_Messages
           (Information    => Options.Verbosity = Very_Verbose,
            Warning        => Options.Warnings,
            Lint           => Options.Verbosity = Very_Verbose,
            Full_Path_Name => Options.Full_Path_Name_For_Brief);
      end if;
   end Output_Messages;

   ------------------
   -- Partial_Name --
   ------------------

   function Partial_Name
     (Lib_Name      : Simple_Name;
      Number        : Natural;
      Object_Suffix : Simple_Name) return Simple_Name is
   begin
      return Partial_Prefix & Lib_Name
             & Simple_Name ('_' & GNATCOLL.Utils.Image (Number, 1))
             & Object_Suffix;
   end Partial_Name;

   -------------------------------
   -- Project_Processing_Failed --
   -------------------------------

   procedure Project_Processing_Failed
     (Options : GPRtools.Options.Base_Options'Class) is
   begin
      Output_Messages (Options);
      Fail_Program
        ('"'
         & (if Options.Config_Project_Has_Error
           then String (Options.Config_Project.Simple_Name)
           else String (Options.Filename.Simple_Name))
          & """ processing failed");
   end Project_Processing_Failed;

   ----------------------
   -- Set_Program_Name --
   ----------------------

   procedure Set_Program_Name (Name : String) is
      use Ada.Environment_Variables;
      GPR_Tool : constant String := "GPR_TOOL";
   begin
      Keep_Program_Name := To_Unbounded_String (Name);

      if Value (GPR_Tool, Default => "") = "" then
         Set
           (GPR_Tool,
            (if Name in "gprclean" | "gprbuild" | "gprls"
                 | "gprinstall" | "gprdump" | "gprdoc"
             then "gprbuild"
             else Name));
      end if;
   end Set_Program_Name;

end GPRtools.Util;