libgpr2_24.0.0_eda3c693/src/lib/gpr2-path_name.adb

--
--  Copyright (C) 2019-2023, AdaCore
--
--  SPDX-License-Identifier: Apache-2.0 WITH LLVM-Exception
--

with Ada.Characters.Handling;
with Ada.Directories.Hierarchical_File_Names;
with Ada.Environment_Variables;
with Ada.IO_Exceptions;
with Ada.Streams.Stream_IO;

with Ada.Strings.Fixed;
with Ada.Strings.Maps;

with GNAT.OS_Lib;
with GNAT.Regexp;

with System;

package body GPR2.Path_Name is

   use GNAT;
   use GNAT.Regexp;

   function "+"
     (Str : String) return Unbounded_String renames To_Unbounded_String;

   function To_OS_Case (Name : String) return String is
     (if File_Names_Case_Sensitive
      then Name
      else Characters.Handling.To_Lower (Name));

   function To_OS_Case (Name : Unbounded_String) return Unbounded_String is
     (if File_Names_Case_Sensitive
      then Name
      else +Characters.Handling.To_Lower (To_String (Name)));
   --  If filenames is case insensitive converts path name to lowercase,
   --  returns the same value otherwise.

   function To_OS_Case (C : Character) return Character is
     (if File_Names_Case_Sensitive
      then C
      else Characters.Handling.To_Lower (C));
   --  If filenames is case insensitive converts char to lowercase,
   --  returns the same value otherwise.

   Root_Path : constant GNAT.Regexp.Regexp :=
                 Compile ("/+|[A-Z]:\\+", Case_Sensitive => False);

   Temp_Directory : Object;
   --  The name of the temporary directory, computed once at elaboration time

   Dir_Seps : constant Ada.Strings.Maps.Character_Set :=
                Strings.Maps.To_Set ("/\");
   --  UNIX and DOS style directory separators

   --  From old GPR

   procedure Determine_Temporary_Directory;
   --  Determine temporary directory

   function Base_Name (Path : String) return String;
   --  Return Path basename (so simple name without extension).
   --  Assumes Path is a file.

   function Ensure_Directory (Path : String) return String is
     (if Path (Path'Last) in OS_Lib.Directory_Separator | '/'
      then Path
      else Path & OS_Lib.Directory_Separator);

   function Remove_Last_DS (Path : String) return String is
     (if Path'Length > 0
        and then Path (Path'Last) in OS_Lib.Directory_Separator | '/' | '\'
      then Path (Path'First .. Path'Last - 1)
      else Path);

   function Containing_Directory (Path : String) return String;
   --  Containing directory for / is '/'
   --  This is Ada.Directories.Containing_Directory implementation with
   --  valid path name check removed to allow '*' chars.

   function Unchecked_Value (Self : Object) return String;
   --  Value function allowing call returning a value with no path separator
   --  For path objects created using a Path_Name with no path separator.

   -------------------
   -- Make_Absolute --
   -------------------

   function Make_Absolute
     (Name          : Filename_Type;
      Directory     : Filename_Optional := "";
      Resolve_Links : Boolean := False) return String
   is
     (OS_Lib.Normalize_Pathname
        ((if OS_Lib.Is_Absolute_Path (String (Name)) or else Directory = ""
          then ""
          else Ensure_Directory (String (Directory)))
         & String (Name),
         Resolve_Links => Resolve_Links));

   ---------------
   -- Base_Name --
   ---------------

   function Base_Name (Path : String) return String is
      Simple : constant String := Simple_Name (Path);
      --  Simple'First is guaranteed to be 1
   begin
      --  Ada.Directories.Base_Name cannot be used here as
      --  Path can contain '*' character that will be rejected on windows
      --  by Ada.Directories.Validity.Is_Valid_Path_Name check.
      --  The following code is Ada.Directories.Base_Name implementation
      --  calling a Simple_Name version allowing '*' chars in Path.

      --  Look for the last dot in the file name and
      --  return the part of the file name preceding this last dot.
      --  If the first dot is the first character of the file name,
      --  the base name is the empty string.
      --  ".filename" case is treated as a base name without extension.

      for Pos in reverse Simple'Range loop
         if Simple (Pos) = '.' and then Pos /= Simple'First then
            return Simple (Simple'First .. Pos - 1);
         end if;
      end loop;

      --  If there is no dot, return the complete file name

      return Simple;
   end Base_Name;

   ----------------------
   -- Change_Extension --
   ----------------------

   function Change_Extension
     (Self : Object; Extension : Value_Type) return Object
   is
      Result  : Object;
      Old_Ext : constant Value_Type :=
                  Directories.Extension (To_String (Self.Value));
      New_Ext : constant Value_Type :=
                  (if Extension /= ""
                     and then Extension (Extension'First) = '.'
                   then Extension (Extension'First + 1 .. Extension'Last)
                   else Extension);

      procedure Replace_Extension
        (Path : in out Unbounded_String; New_Ext : Value_Type);
      --  Replaces the file extension in Path to the New_Ext

      -----------------------
      -- Replace_Extension --
      -----------------------

      procedure Replace_Extension
        (Path : in out Unbounded_String; New_Ext : Value_Type)
      is
         Low  :  constant Positive := Length (Path) - Old_Ext'Length +
                   (if Old_Ext = "" then 1 else 0);
         Suff : constant Value_Type :=
                   (if New_Ext = "" then "" else '.' & New_Ext);
      begin
         Replace_Slice (Path, Low, Length (Path), Suff);
      end Replace_Extension;

   begin
      if New_Ext = Old_Ext then
         return Self;
      end if;

      Result := Self;

      pragma Assert (Directories.Extension (To_String (Self.As_Is)) = Old_Ext);
      pragma Assert
        (Directories.Extension (To_String (Self.Comparing))
         = To_OS_Case (Old_Ext));

      Replace_Extension (Result.Value,     New_Ext);
      Replace_Extension (Result.As_Is,     New_Ext);
      Replace_Extension (Result.Comparing, To_OS_Case (New_Ext));

      pragma Assert
        (Directories.Extension (To_String (Result.As_Is)) = New_Ext);
      pragma Assert
        (Directories.Extension (To_String (Result.Value)) = New_Ext);
      pragma Assert
        (Directories.Extension (To_String (Result.Comparing))
         = To_OS_Case (New_Ext));

      return Result;
   end Change_Extension;

   -------------------
   -- Common_Prefix --
   -------------------

   function Common_Prefix (Self, Path : Object) return Object is

      use Ada.Directories.Hierarchical_File_Names;

      P1 : constant Filename_Type := Filename_Type (To_String (Self.Dir_Name));
      P2 : constant Filename_Type := Filename_Type (To_String (Path.Dir_Name));
      I1 : Positive := P1'First;
      I2 : Positive := P2'First;
      N1, N2 : Natural;

   begin
      loop
         --  Object.Dir_Name always end with a dir separator, so no need to
         --  check for the case where P1 or P2 end with a subdir name.
         N1 := Ada.Strings.Fixed.Index (String (P1), Dir_Seps, I1);
         N2 := Ada.Strings.Fixed.Index (String (P2), Dir_Seps, I2);

         declare
            Sub1 : constant Filename_Optional := P1 (I1 .. N1 - 1);
            Sub2 : constant Filename_Optional := P2 (I2 .. N2 - 1);
         begin
            exit when Sub1 /= Sub2;

            I1 := N1 + 1;
            I2 := N2 + 1;
         end;

         exit when I1 not in P1'Range or else I2 not in P2'Range;
      end loop;

      if I1 = P1'First then
         --  No common directory at all: happens on windows when the
         --  paths are on two different drives
         return Undefined;
      elsif Is_Root_Directory_Name (String (P1 (P1'First .. I1 - 1))) then
         --  root dir is the only thing remaining: keep the final /
         return Create_Directory (P1 (P1'First .. I1 - 1));
      else
         --  remove last dir separator
         return Create_Directory (P1 (P1'First .. I1 - 2));
      end if;
   end Common_Prefix;

   -------------
   -- Compose --
   -------------

   function Compose
     (Self      : Object;
      Name      : Filename_Type;
      Directory : Boolean := False) return Object
   is
      Filename : constant Filename_Type :=
                   Filename_Type (Dir_Name (Self)) & Name;
   begin
      if Directory then
         return Create_Directory (Filename);
      else
         return Create_File (Filename, No_Resolution);
      end if;
   end Compose;

   --------------------------
   -- Containing_Directory --
   --------------------------

   function Containing_Directory (Path : String) return String is

      --  Ada.Directories.Containing_Directory cannot be used here as
      --  Path can contain '*' character that will be rejected on windows
      --  by Ada.Directories.Validity.Is_Valid_Path_Name check.
      use Ada.Directories.Hierarchical_File_Names;

      Last_DS : constant Natural :=
                  Strings.Fixed.Index
                    (Path, Dir_Seps, Going => Strings.Backward);

   begin
      if Last_DS = 0 then
         --  There is no directory separator, so return ".", representing
         --  the current working directory.

         return ".";

      else
         declare
            Result : constant String := Path (Path'First .. Last_DS);

         begin
            --  Remove any trailing directory separator, except as the
            --  first character or the first character following a drive
            --  number on Windows.

            if Is_Root_Directory_Name (Result) then
               return Result;
            else
               return Result (Result'First .. Result'Last - 1);
            end if;
         end;
      end if;
   end Containing_Directory;

   function Containing_Directory (Self : Object) return Object is
   begin
      if Self.Is_Directory then
         return Create_Directory
           (Filename_Type
              (Containing_Directory (Remove_Last_DS (Dir_Name (Self)))));
      elsif Self.Has_Dir_Name then
         return Create_Directory (Filename_Type (Dir_Name (Self)));
      else
         return Create_Directory
           (Filename_Type
              (Containing_Directory (String (Name (Self)))));
      end if;
   end Containing_Directory;

   -----------------
   -- Content_MD5 --
   -----------------

   function Content_MD5 (Self : Object) return GNAT.MD5.Message_Digest is
      use Ada.Streams;
      use GNAT.MD5;

      C : Context;
      S : Stream_IO.File_Type;
      B : Stream_Element_Array (1 .. 100 * 1024);
      --  Buffer to read chunk of data
      L : Stream_Element_Offset;
   begin
      Stream_IO.Open (S, Stream_IO.In_File, To_String (Self.Value));

      while not Stream_IO.End_Of_File (S) loop
         Stream_IO.Read (S, B, L);
         Update (C, B (1 .. L));
      end loop;

      Stream_IO.Close (S);

      return Digest (C);
   end Content_MD5;

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

   function Create (Name, Path_Name : Filename_Type) return Object is
      Value : constant Unbounded_String := +String (Path_Name);
   begin
      return Object'
        (Is_Dir    => False,
         As_Is     => +String (Name),
         Value     => Value,
         Comparing => To_OS_Case (Value),
         Base_Name => +Base_Name (String (Path_Name)),
         Dir_Name  =>
           +Ensure_Directory (Containing_Directory (String (Path_Name))));
   end Create;

   ----------------------
   -- Create_Directory --
   ----------------------

   function Create_Directory
     (Name          : Filename_Type;
      Directory     : Filename_Optional := "";
      Resolve_Links : Boolean := False) return Object
   is
      NN : constant String :=
             Ensure_Directory (Make_Absolute (Name, Directory, Resolve_Links));
      VN : constant Unbounded_String := +NN;

   begin
      return Object'
        (Is_Dir    => True,
         As_Is     => +String (Name),
         Value     => VN,
         Comparing => To_OS_Case (VN),
         Base_Name => Null_Unbounded_String,
         Dir_Name  => VN);
   end Create_Directory;

   -----------------
   -- Create_File --
   -----------------

   function Create_File
     (Name      : Filename_Type;
      Directory : Filename_Optional := Resolve_On_Current) return Object
   is
   begin
      if Directory = No_Resolution
        and then not OS_Lib.Is_Absolute_Path (String (Name))
      then
         return Object'
           (As_Is     => +String (Name),
            Comparing => +To_OS_Case (String (Name)),
            Base_Name => +Base_Name (String (Name)),
            others    => <>);
      else
         declare
            NN : constant String := Make_Absolute (Name, Directory);
            VN : constant Unbounded_String := +NN;
         begin
            return Object'
              (Is_Dir    => False,
               As_Is     => +String (Name),
               Value     => VN,
               Comparing => To_OS_Case (VN),
               Base_Name => +Base_Name (NN),
               Dir_Name  => +Ensure_Directory (Containing_Directory (NN)));
         end;
      end if;
   end Create_File;

   ---------------------
   -- Create_Sym_Link --
   ---------------------

   procedure Create_Sym_Link (Self, To : Object) is

      function Symlink
        (Oldpath : System.Address;
         Newpath : System.Address) return Integer;
      pragma Import (C, Symlink, "__gnat_symlink");

      C_From  : constant String := To_String (Self.Value) & ASCII.NUL;
      pragma Warnings (Off, "*actuals for this call may be in wrong order*");
      C_To    : constant String :=
                  String (Relative_Path (To, Self).Name) & ASCII.NUL;
      Result  : Integer;
      Success : Boolean;
      pragma Unreferenced (Result);

   begin
      OS_Lib.Delete_File (To_String (Self.Value), Success);
      Result := Symlink (C_To'Address, C_From'Address);
   end Create_Sym_Link;

   -----------------------------------
   -- Determine_Temporary_Directory --
   -----------------------------------

   procedure Determine_Temporary_Directory is

      function Check_Directory (Name : String) return Boolean;
      --  Returns True if directory exists

      function Check_Environment (Name : String) return Boolean;
      --  Returns True if directory from environment variable exists

      ---------------------
      -- Check_Directory --
      ---------------------

      function Check_Directory (Name : String) return Boolean is
      begin
         if OS_Lib.Is_Directory (Name) then
            Temp_Directory :=
              Create_Directory
                (Filename_Type (OS_Lib.Normalize_Pathname (Name)));
            return True;
         end if;

         return False;
      end Check_Directory;

      -----------------------
      -- Check_Environment --
      -----------------------

      function Check_Environment (Name : String) return Boolean is
         use Ada.Environment_Variables;
      begin
         if Exists (Name) then
            return Check_Directory (Value (Name));
         end if;

         return False;
      end Check_Environment;

   begin
      if Check_Environment ("TMPDIR")
        or else Check_Environment ("TEMP")
        or else Check_Environment ("TMP")
      then
         return;
      end if;

      case OS_Lib.Directory_Separator is
         when '\' =>
            if Check_Directory ("C:\TEMP")
              or else Check_Directory ("C:\TMP")
              or else Check_Directory ("\TEMP")
              or else Check_Directory ("\TMP")
            then
               return;
            end if;

         when '/' =>
            if Check_Directory ("/tmp")
              or else Check_Directory ("/var/tmp")
              or else Check_Directory ("/usr/tmp")
            then
               return;
            end if;

         when others =>
            raise Program_Error with
              "Unsupported directory separator " & OS_Lib.Directory_Separator;
      end case;
   end Determine_Temporary_Directory;

   ------------
   -- Exists --
   ------------

   function Exists (Self : Object) return Boolean is
   begin
      return Length (Self.Value) > 0
        and then Directories.Exists (To_String (Self.Value));
   exception
      when Ada.IO_Exceptions.Name_Error =>
         return False;
   end Exists;

   ---------------
   -- Extension --
   ---------------

   function Extension (Self : Object) return Filename_Optional is
      SN : constant GPR2.Simple_Name := Self.Simple_Name;
   begin
      return SN (SN'First + Length (Self.Base_Name) .. SN'Last);
   end Extension;

   -----------------------
   -- Filesystem_String --
   -----------------------

   function Filesystem_String (Self : Object) return VFS.Filesystem_String is
   begin
      if Self.Is_Defined then
         if Self.Has_Dir_Name then
            return VFS.Filesystem_String (To_String (Self.Value));
         else
            return VFS.Filesystem_String (Simple_Name (Self));
         end if;
      else
         return "";
      end if;
   end Filesystem_String;

   -----------------
   -- Is_Root_Dir --
   -----------------

   function Is_Root_Dir (Self : Object) return Boolean is
   begin
      return Self.Is_Directory and then
        Match (To_String (Self.Value), Root_Path);
   end Is_Root_Dir;

   ----------
   -- Name --
   ----------

   function Name
     (Self      : Object;
      Extension : Boolean := True) return Filename_Type
   is
      Name : constant String := To_String (Self.As_Is);
      Ext : Natural;
      Sep : Natural;
   begin
      if Extension or else Self.Is_Dir then
         return Filename_Type (Name);
      else
         Sep := Strings.Fixed.Index (Name, Dir_Seps,
                                     Going => Strings.Backward);

         --  Handle trailing directory separators

         if Sep = Name'Last then
            Sep := Strings.Fixed.Index
              (Name (Name'First .. Name'Last - 1),
               Dir_Seps, Going => Strings.Backward);
         end if;

         Ext := Strings.Fixed.Index (Name, ".", Going => Strings.Backward);

         if Ext = 0 or else Ext < Sep + 2 then
            --  .filename is treated as a whole file name without extension
            Ext := Name'Last;
         else
            Ext := Ext - 1;
         end if;

         return Filename_Type (Name (Name'First .. Ext));
      end if;
   end Name;

   -------------------
   -- Relative_Path --
   -------------------

   function Relative_Path (Self, From : Object) return Object is
      use Ada.Strings.Fixed;
      use GNATCOLL.Utils;

      P       : constant String := To_String (Self.Dir_Name);
      T       : constant String := To_String (From.Dir_Name);
      Rel_Dir : Object;

      Pi : Positive := P'First; -- common prefix ending
      Ti : Positive := P'First;
      N  : Natural;

   begin
      --  First check for common prefix

      loop
         if Is_Directory_Separator (P (Ti))
           and then Is_Directory_Separator (T (Ti))
         then
            Pi := Ti;

         elsif To_OS_Case (P (Ti)) /= To_OS_Case (T (Ti)) then
            if Ti = P'First then
               --  First character differ, it can be only on Windows because
               --  UNIX path starts with a directory separator.
               --  "From" path is on another drive, returns original path.

               return Self;
            end if;

            exit;
         end if;

         exit when Ti in P'Last | T'Last;

         Ti := Ti + 1;
      end loop;

      --  Count directory under prefix in P, these will be replaced by the
      --  corresponding number of "..".

      N := Strings.Fixed.Count (T (Pi + 1 .. T'Last), Dir_Seps);

      Rel_Dir := Create_Directory
        (Filename_Type (String'(N * "../")
         & (if Pi = P'Last and then N = 0
            then "./"
            else P (Pi + 1 .. P'Last))),
         Filename_Optional (T));

      if Self.Is_Dir then
         return Rel_Dir;
      else
         return Create_File
           (Filename_Type (Ensure_Directory (String (Rel_Dir.Name))) &
              Self.Simple_Name,
            Filename_Optional (T));
      end if;
   end Relative_Path;

   -----------------
   -- Simple_Name --
   -----------------

   function Simple_Name (Self : Object) return GPR2.Simple_Name is
   begin
      --  Ada.Directories.Simple_Name cannot be used here as
      --  Path can contain '*' character that will be rejected on windows
      --  by Ada.Directories.Validity.Is_Valid_Path_Name check.
      return GPR2.Simple_Name
        (Simple_Name (To_String (Self.As_Is)));
   end Simple_Name;

   function Simple_Name (Path : String) return String is

      Cut_Start : Natural :=
                    Strings.Fixed.Index
                      (Path, Dir_Seps, Going => Strings.Backward);

      --  Cut_End points to the last simple name character

      Cut_End   : Natural := Path'Last;

   begin
      --  Handle trailing directory separators

      if Cut_Start = Path'Last then
         Cut_End   := Path'Last - 1;
         Cut_Start := Strings.Fixed.Index
           (Path (Path'First .. Path'Last - 1),
            Dir_Seps, Going => Strings.Backward);
      end if;

      --  Cut_Start points to the first simple name character

      Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);

      Check_For_Standard_Dirs : declare
         BN : constant String := Path (Cut_Start .. Cut_End);

         Has_Drive_Letter : constant Boolean :=
                              OS_Lib.Path_Separator /= ':';
         --  If Path separator is not ':' then we are on a DOS based OS
         --  where this character is used as a drive letter separator.

      begin
         if BN = "." or else BN = ".." then
            return BN;

         elsif Has_Drive_Letter
           and then BN'Length > 2
           and then Characters.Handling.Is_Letter (BN (BN'First))
           and then BN (BN'First + 1) = ':'
         then
            --  We have a DOS drive letter prefix, remove it

            return BN (BN'First + 2 .. BN'Last);

         else
            return BN;
         end if;
      end Check_For_Standard_Dirs;
   end Simple_Name;

   -------------------------
   -- Temporary_Directory --
   -------------------------

   function Temporary_Directory return Object is
   begin
      return Temp_Directory;
   end Temporary_Directory;

   ---------------------
   -- Unchecked_Value --
   ---------------------

   function Unchecked_Value (Self : Object) return String is
   begin
      if Self.Is_Dir and then not Self.Is_Root_Dir then
         return Remove_Last_DS (To_String (Self.Value));
      else
         return To_String (Self.Value);
      end if;
   end Unchecked_Value;

   -----------
   -- Value --
   -----------

   function Value (Self : Object) return Full_Name is
   begin
      return Unchecked_Value (Self);
   end Value;

begin
   Determine_Temporary_Directory;
end GPR2.Path_Name;