gnatcoll_24.0.0_11c512d1/src/gnatcoll-io-native.adb

------------------------------------------------------------------------------
--                             G N A T C O L L                              --
--                                                                          --
--                     Copyright (C) 2009-2022, 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 Ada.Directories;
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;
with System;

with Ada.Calendar.Formatting;  use Ada.Calendar;
with Ada.Calendar.Time_Zones;  use Ada.Calendar.Time_Zones;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib;
with GNAT.Strings;              use GNAT.Strings;
with Interfaces.C;              use Interfaces.C;
with Interfaces.C.Strings;      use Interfaces.C.Strings;

with GNATCOLL.Mmap;
with GNATCOLL.Path;             use GNATCOLL.Path;
with GNATCOLL.Utils;            use GNATCOLL.Utils;

package body GNATCOLL.IO.Native is

   package body Codec is separate;
   --  Separate implementation for Windows and Unix

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

   function Create (Path : FS_String) return File_Access is
   begin
      return new Native_File_Record'
        (Ref_Count  => 1,
         Full       => new FS_String'(From_Unix (Local_FS, Path)),
         Normalized => null,
         Normalized_And_Resolved => null,
         Kind       => Unknown);
   end Create;

   ------------------------
   -- Dispatching_Create --
   ------------------------

   overriding function Dispatching_Create
     (Ref       : not null access Native_File_Record;
      Full_Path : FS_String) return File_Access
   is
      pragma Unreferenced (Ref);
   begin
      return Create (Full_Path);
   end Dispatching_Create;

   -------------
   -- To_UTF8 --
   -------------

   overriding function To_UTF8
     (Ref  : not null access Native_File_Record;
      Path : FS_String) return String
   is
      pragma Unreferenced (Ref);
   begin
      return Codec.To_UTF8 (Path);
   end To_UTF8;

   ---------------
   -- From_UTF8 --
   ---------------

   overriding function From_UTF8
     (Ref  : not null access Native_File_Record;
      Path : String) return FS_String
   is
      pragma Unreferenced (Ref);
   begin
      return Codec.From_UTF8 (Path);
   end From_UTF8;

   -----------------
   -- Current_Dir --
   -----------------

   function Current_Dir return File_Access is
      D   : constant GNAT.Directory_Operations.Dir_Name_Str :=
              GNAT.Directory_Operations.Get_Current_Dir;
      Ret : File_Access;
   begin
      Ret := Create (FS_String (D));
      return Ret;
   end Current_Dir;

   --------------
   -- Home_Dir --
   --------------

   function Home_Dir return File_Access is
      HOME : GNAT.Strings.String_Access := GNAT.OS_Lib.Getenv ("HOME");
      Tmp  : GNAT.Strings.String_Access;
   begin
      if HOME.all = "" then
         Free (HOME);
         HOME := GNAT.OS_Lib.Getenv ("USERPROFILE");

         if HOME.all = "" then
            Free (HOME);
            return Create (Get_Root (Local_FS, ""));
         end if;
      end if;

      if HOME'Length > 2
        and then HOME (HOME'First) = '%'
        and then HOME (HOME'Last) = '%'
      then
         --  Some Windows systems set %HOME% to another env variable, e.g.
         --  %USERPROFILE%

         Tmp := HOME;
         HOME := GNAT.OS_Lib.Getenv (Tmp (Tmp'First + 1 .. Tmp'Last - 1));
         Free (Tmp);
      end if;

      declare
         --  ??? Convert from display charset to filesystem charset ?
         Result : constant FS_String :=
                    From_Unix (Local_FS, FS_String (HOME.all));
      begin
         Free (HOME);
         return Create (Result);
      end;
   end Home_Dir;

   -----------------------
   -- Get_Tmp_Directory --
   -----------------------

   function Get_Tmp_Directory return File_Access is

      function Internal return chars_ptr;
      pragma Import (C, Internal, "__gnatcoll_get_tmp_dir");

      procedure c_free (C : chars_ptr);
      pragma Import (C, c_free, "free");

      C_Str : constant chars_ptr := Internal;
      Str   : constant FS_String :=
                FS_String
                  (GNAT.Directory_Operations.Format_Pathname
                     (To_Ada (Value (C_Str))));
   begin
      --  Since the allocation was done in C (strdup), we use directly the
      --  C version of free. This is probably more reliable, and more
      --  importantly, this works correctly with our own version of
      --  s-memory.adb (when GPS_MEMORY_MONITOR=1)
      c_free (C_Str);
      return Create (Ensure_Directory (Local_FS, Str));
   end Get_Tmp_Directory;

   ------------------------
   -- Get_Logical_Drives --
   ------------------------

   function Get_Logical_Drives return File_Array is

      function Internal
        (Buffer : System.Address;
         Length : Integer) return Integer;
      pragma Import (C, Internal, "__gnatcoll_get_logical_drive_strings");
      Len    : Integer;
      Last   : Natural;
      N      : Natural;

   begin
      --  First get the size of the buffer needed to contain the drives
      Len := Internal (System.Null_Address, 0);

      if Len = 0 then
         return (1 .. 0 => <>);
      end if;

      declare
         --  Use the returned length for creating the buffer. Do not forget
         --  to add room for the trailing \n
         Buffer : aliased FS_String (1 .. Len + 1);
      begin
         Len := Internal (Buffer'Address, Len);

         N := 0;
         for J in 1 .. Len loop
            if Buffer (J) = ASCII.NUL then
               N := N + 1;
            end if;
         end loop;

         declare
            Ret : File_Array (1 .. N);
         begin
            N := 1;
            Last := Buffer'First;

            for J in 1 .. Len loop
               if Buffer (J) = ASCII.NUL then
                  Ret (N) := Create
                    (GNATCOLL.Path.Path
                       (Local_FS, Buffer (Last .. Last), "", ""));
                  N := N + 1;
                  Last := J + 1;
               end if;
            end loop;

            return Ret;
         end;
      end;
   end Get_Logical_Drives;

   --------------
   -- Is_Local --
   --------------

   overriding function Is_Local (File : Native_File_Record) return Boolean is
      pragma Unreferenced (File);
   begin
      return True;
   end Is_Local;

   ------------
   -- Get_FS --
   ------------

   overriding function Get_FS
     (File : not null access Native_File_Record) return FS_Type
   is
      pragma Unreferenced (File);
   begin
      return Local_FS;
   end Get_FS;

   ----------------------
   -- Resolve_Symlinks --
   ----------------------

   overriding procedure Resolve_Symlinks
     (File : not null access Native_File_Record)
   is
      Is_Dir_Path : Boolean;
   begin
      if File.Normalized_And_Resolved = null then
         Is_Dir_Path := Path.Is_Dir_Name (File.Get_FS, File.Full.all);

         declare
            --  We have to pass "" for the directory, in case File.Full is a
            --  relative path name. That might be surprising to the application
            --  since the current directory might have changed since File was
            --  created.
            Norm : constant String :=
                     GNAT.OS_Lib.Normalize_Pathname
                       (String (File.Full.all),
                        Directory     => "",
                        Resolve_Links => True);
         begin
            --  Normalize_Pathname sometimes removes the trailing dir separator
            --  We need to take care of it then.
            if not Is_Dir_Path
              or else Norm (Norm'Last) = GNAT.OS_Lib.Directory_Separator
            then
               if File.Normalized /= null
                 and then FS_String (Norm) = File.Normalized.all
               then
                  File.Normalized_And_Resolved := File.Normalized;
               else
                  File.Normalized_And_Resolved :=
                    new FS_String'(FS_String (Norm));
               end if;

            else
               if File.Normalized /= null
                 and then FS_String (Norm) & GNAT.OS_Lib.Directory_Separator =
                    File.Normalized.all
               then
                  File.Normalized_And_Resolved := File.Normalized;
               else
                  File.Normalized_And_Resolved := new FS_String'
                    (FS_String (Norm) & GNAT.OS_Lib.Directory_Separator);
               end if;
            end if;
         end;
      end if;
   end Resolve_Symlinks;

   ---------------------
   -- Is_Regular_File --
   ---------------------

   overriding function Is_Regular_File
     (File : not null access Native_File_Record) return Boolean is
   begin
      return GNAT.OS_Lib.Is_Regular_File (String (File.Full.all));
   end Is_Regular_File;

   ----------
   -- Size --
   ----------

   overriding function Size
     (File : not null access Native_File_Record) return Long_Integer
   is
      Fd : constant GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Open_Read
        (String (File.Full.all), Fmode => GNAT.OS_Lib.Binary);
      pragma Warnings (Off);
      Result : constant Long_Integer :=
        Long_Integer (GNAT.OS_Lib.File_Length (Fd));
      pragma Warnings (On);
   begin
      GNAT.OS_Lib.Close (Fd);
      return Result;
   end Size;

   ------------------
   -- Is_Directory --
   ------------------

   overriding function Is_Directory
     (File : not null access Native_File_Record) return Boolean is
   begin
      if GNAT.OS_Lib.Directory_Separator = '\'
        and then File.Full'Length > 1
        and then File.Full (File.Full'First .. File.Full'First + 1) = "\\"
      then
         --  There is an issue with (at least) GNAT 6.2 when Is_Directory
         --  returns False for Windows network paths (e.g. \\host\shared\).
         --  In this case, we try to open the directory and see if it works.

         declare
            Dir : GNAT.Directory_Operations.Dir_Type;
         begin
            GNAT.Directory_Operations.Open (Dir, String (File.Full.all));
            GNAT.Directory_Operations.Close (Dir);

            return True;

         exception
            when GNAT.Directory_Operations.Directory_Error =>
               return False;
         end;

      else
         return GNAT.OS_Lib.Is_Directory (String (File.Full.all));
      end if;
   end Is_Directory;

   ----------------------
   -- Is_Symbolic_Link --
   ----------------------

   overriding function Is_Symbolic_Link
     (File : not null access Native_File_Record) return Boolean is
   begin
      return GNAT.OS_Lib.Is_Symbolic_Link (String (File.Full.all));
   end Is_Symbolic_Link;

   ---------------------
   -- File_Time_Stamp --
   ---------------------

   TZ : constant Time_Offset := UTC_Time_Offset;
   --  Time zone cache, assuming that the OS will not change time zones while
   --  this partition is running.

   overriding function File_Time_Stamp
     (File : not null access Native_File_Record) return Ada.Calendar.Time
   is
      T      : constant GNAT.OS_Lib.OS_Time :=
        GNAT.OS_Lib.File_Time_Stamp (String (File.Full.all));
      Year   : GNAT.OS_Lib.Year_Type;
      Month  : GNAT.OS_Lib.Month_Type;
      Day    : GNAT.OS_Lib.Day_Type;
      Hour   : GNAT.OS_Lib.Hour_Type;
      Minute : GNAT.OS_Lib.Minute_Type;
      Second : GNAT.OS_Lib.Second_Type;

      use type GNAT.OS_Lib.OS_Time;
   begin
      if T = GNAT.OS_Lib.Invalid_Time then
         return GNATCOLL.Utils.No_Time;
      end if;

      GNAT.OS_Lib.GM_Split (T, Year, Month, Day, Hour, Minute, Second);

      return Ada.Calendar.Formatting.Time_Of
        (Year       => Year_Number (Year),
         Month      => Month_Number (Month),
         Day        => Day_Number (Day),
         Hour       => Formatting.Hour_Number (Hour),
         Minute     => Formatting.Minute_Number (Minute),
         Second     => Formatting.Second_Number (Second),
         Sub_Second => 0.0,
         Time_Zone  => TZ);
   end File_Time_Stamp;

   -----------------
   -- Is_Readable --
   -----------------

   overriding function Is_Readable
     (File : not null access Native_File_Record) return Boolean is
   begin
      return GNAT.OS_Lib.Is_Readable_File (String (File.Full.all));
   end Is_Readable;

   -----------------
   -- Is_Writable --
   -----------------

   overriding function Is_Writable
     (File : not null access Native_File_Record) return Boolean is
   begin
      return GNAT.OS_Lib.Is_Writable_File (String (File.Full.all));
   end Is_Writable;

   ------------------
   -- Set_Writable --
   ------------------

   overriding procedure Set_Writable
     (File  : not null access Native_File_Record;
      State : Boolean)
   is
   begin
      if State then
         GNAT.OS_Lib.Set_Writable
           (String (File.Full.all));
      else
         GNAT.OS_Lib.Set_Non_Writable
           (String (File.Full.all));
      end if;
   end Set_Writable;

   ------------------
   -- Set_Readable --
   ------------------

   overriding procedure Set_Readable
     (File  : not null access Native_File_Record;
      State : Boolean)
   is
   begin
      if State then
         GNAT.OS_Lib.Set_Readable
           (String (File.Full.all));
      else
         GNAT.OS_Lib.Set_Non_Readable
           (String (File.Full.all));
      end if;
   end Set_Readable;

   ------------
   -- Rename --
   ------------

   overriding procedure Rename
     (From    : not null access Native_File_Record;
      Dest    : not null access Native_File_Record;
      Success : out Boolean)
   is
   begin
      GNAT.OS_Lib.Rename_File
        (String (From.Full.all), String (Dest.Full.all), Success);

   exception
      when others =>
         Success := False;
   end Rename;

   ----------
   -- Copy --
   ----------

   overriding procedure Copy
     (From    : not null access Native_File_Record;
      Dest    : FS_String;
      Success : out Boolean)
   is
   begin
      GNAT.OS_Lib.Copy_File
        (String (From.Full.all), String (Dest), Success,
         Mode => GNAT.OS_Lib.Overwrite, Preserve => GNAT.OS_Lib.Full);

   exception
      when others =>
         Success := False;
   end Copy;

   ------------
   -- Delete --
   ------------

   overriding procedure Delete
     (File    : not null access Native_File_Record;
      Success : out Boolean)
   is
   begin
      GNAT.OS_Lib.Delete_File (String (File.Full.all), Success);
   end Delete;

   ---------------------
   -- Read_Whole_File --
   ---------------------

   overriding function Read_Whole_File
     (File : not null access Native_File_Record)
      return GNAT.Strings.String_Access
   is
   begin
      return GNATCOLL.Mmap.Read_Whole_File (String (File.Full.all));

   exception
      when others =>
         return null;
   end Read_Whole_File;

   ---------------------
   -- Read_Whole_File --
   ---------------------

   overriding function Read_Whole_File
     (File : not null access Native_File_Record)
      return GNATCOLL.Strings.XString
   is
   begin
      return GNATCOLL.Mmap.Read_Whole_File (String (File.Full.all));

   exception
      when others =>
         return GNATCOLL.Strings.Null_XString;
   end Read_Whole_File;

   ----------------
   -- Open_Write --
   ----------------

   overriding procedure Open_Write
     (File   : not null access Native_File_Record;
      Append : Boolean := False;
      FD     : out GNAT.OS_Lib.File_Descriptor;
      Error  : out Ada.Strings.Unbounded.Unbounded_String)
   is
      use type GNAT.OS_Lib.File_Descriptor;

   begin
      if Append then
         FD := GNAT.OS_Lib.Open_Read_Write
           (String (File.Full.all),
            Fmode => GNAT.OS_Lib.Binary);
      else
         FD := GNAT.OS_Lib.Create_File
           (String (File.Full.all),
            Fmode => GNAT.OS_Lib.Binary);
      end if;

      if FD = GNAT.OS_Lib.Invalid_FD then
         Error :=
           Ada.Strings.Unbounded.To_Unbounded_String
             (GNAT.OS_Lib.Errno_Message);

      else
         Error := Ada.Strings.Unbounded.Null_Unbounded_String;
      end if;

      if Append then
         GNAT.OS_Lib.Lseek (FD, 0, GNAT.OS_Lib.Seek_End);
         --  It is impossible to obtain return value of lseek to check for
         --  errors.
      end if;

   exception
      when E : others =>
         FD    := GNAT.OS_Lib.Invalid_FD;
         Error :=
           Ada.Strings.Unbounded.To_Unbounded_String
             (Ada.Exceptions.Exception_Information (E));
   end Open_Write;

   -----------
   -- Close --
   -----------

   overriding procedure Close
     (File    : not null access Native_File_Record;
      FD      : GNAT.OS_Lib.File_Descriptor;
      Success : out Boolean)
   is
      pragma Unreferenced (File);
      use type GNAT.OS_Lib.File_Descriptor;
   begin
      if FD /= GNAT.OS_Lib.Invalid_FD then
         GNAT.OS_Lib.Close (FD);
         Success := True;
      else
         Success := False;
      end if;
   end Close;

   ----------------
   -- Change_Dir --
   ----------------

   overriding function Change_Dir
     (Dir : not null access Native_File_Record)
      return Boolean
   is
   begin
      GNAT.Directory_Operations.Change_Dir (String (Dir.Full.all));
      return True;

   exception
      when others =>
         return False;
   end Change_Dir;

   --------------
   -- Read_Dir --
   --------------

   overriding function Read_Dir
     (Dir        : not null access Native_File_Record;
      Dirs_Only  : Boolean := False;
      Files_Only : Boolean := False) return GNAT.Strings.String_List
   is
      Name : constant String :=
               String (Ensure_Directory (Local_FS, Dir.Full.all));
      D    : GNAT.Directory_Operations.Dir_Type;
      Item : String (1 .. 1024);
      Last : Natural;
      Ret  : GNAT.Strings.String_List_Access;
      Tmp  : GNAT.Strings.String_List_Access;
      N    : Natural := 0;

      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
        (GNAT.Strings.String_List, GNAT.Strings.String_List_Access);

   begin
      GNAT.Directory_Operations.Open (D, String (Dir.Full.all));

      loop
         GNAT.Directory_Operations.Read (D, Item, Last);
         exit when Last = 0;

         if Item (1 .. Last) /= "."
           and then Item (1 .. Last) /= ".."
           and then
             (not Dirs_Only
              or else
                GNAT.OS_Lib.Is_Directory (Name & Item (1 .. Last)))
           and then
             (not Files_Only
              or else
                GNAT.OS_Lib.Is_Regular_File (Name & Item (1 .. Last)))
         then
            if Ret = null then
               Ret := new GNAT.Strings.String_List (1 .. 10);

            elsif N = Ret'Last then
               Tmp := new GNAT.Strings.String_List (1 .. Ret'Length * 2);
               Tmp (Ret'Range) := Ret.all;
               Unchecked_Free (Ret);
               Ret := Tmp;
            end if;

            N := N + 1;
            Ret (N) := new String'(Item (1 .. Last));
         end if;
      end loop;

      GNAT.Directory_Operations.Close (D);

      if N = 0 then
         return (1 .. 0 => <>);
      end if;

      declare
         List : constant GNAT.Strings.String_List := Ret (1 .. N);
      begin
         Unchecked_Free (Ret);
         return List;
      end;
   end Read_Dir;

   --------------
   -- Make_Dir --
   --------------

   overriding function Make_Dir
     (Dir       : not null access Native_File_Record;
      Recursive : Boolean) return Boolean is
   begin
      if Recursive then
         Ada.Directories.Create_Path (String (Dir.Full.all));
      else
         Ada.Directories.Create_Directory (String (Dir.Full.all));
      end if;

      return True;

   exception
      when GNAT.Directory_Operations.Directory_Error =>
         return False;
   end Make_Dir;

   ----------------
   -- Remove_Dir --
   ----------------

   overriding procedure Remove_Dir
     (Dir       : not null access Native_File_Record;
      Recursive : Boolean;
      Success   : out Boolean)
   is
   begin
      GNAT.Directory_Operations.Remove_Dir (String (Dir.Full.all), Recursive);
      Success := True;

   exception
      when GNAT.Directory_Operations.Directory_Error =>
         Success := False;
   end Remove_Dir;

   --------------
   -- Copy_Dir --
   --------------

   overriding procedure Copy_Dir
     (From    : not null access Native_File_Record;
      Dest    : FS_String;
      Success : out Boolean)
   is
   begin
      if not Is_Directory (From) then
         Success := False;
         return;
      end if;

      if not GNAT.OS_Lib.Is_Directory (String (Dest)) then
         begin
            GNAT.Directory_Operations.Make_Dir (String (Dest));
         exception
            when others =>
               Success := False;
               return;
         end;
      end if;

      declare
         Files : GNAT.Strings.String_List := Read_Dir (From);

      begin
         Success := True;

         for F in Files'Range loop
            declare
               Tmp_From : File_Access :=
                            Create
                              (GNATCOLL.Path.Path
                                 (Local_FS,
                                  "",
                                  From.Full.all,
                                  FS_String (Files (F).all)));
               To_Str   : constant FS_String :=
                            GNATCOLL.Path.Path
                              (Local_FS,
                               "",
                               Dest,
                               FS_String (Files (F).all));
            begin

               if Is_Directory (Tmp_From) then
                  Copy_Dir (Tmp_From, To_Str, Success);
                  Unref (Tmp_From);

                  exit when not Success;

               else
                  Copy (Tmp_From, To_Str, Success);
                  Unref (Tmp_From);

                  exit when not Success;

               end if;
            end;

            GNAT.Strings.Free (Files (F));
         end loop;

      exception
         when others =>
            for J in Files'Range loop
               GNAT.Strings.Free (Files (J));
            end loop;

            Success := False;
      end;

   exception
      when others =>
         Success := False;
   end Copy_Dir;

   ---------------------------
   -- Copy_File_Permissions --
   ---------------------------

   overriding procedure Copy_File_Permissions
     (From, To : not null access Native_File_Record;
      Success  : out Boolean) is
   begin
      GNAT.OS_Lib.Copy_File_Attributes
          (From             => String (From.Full.all),
           To               => String (To.Full.all),
           Success          => Success,
           Copy_Timestamp   => False,
           Copy_Permissions => True);
   end Copy_File_Permissions;

end GNATCOLL.IO.Native;