libgnatcoll16.1.0-dev 17.0.2017-3 / usr / share / ada / adainclude / gnatcoll / gnatcoll-mmap.adb

------------------------------------------------------------------------------
--                             G N A T C O L L                              --
--                                                                          --
--                     Copyright (C) 2007-2017, 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.                            --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- 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.IO_Exceptions;
with Ada.Unchecked_Deallocation;
with GNATCOLL.Mmap.System;       use GNATCOLL.Mmap.System;
with GNATCOLL.Strings;           use GNATCOLL.Strings;
with System;                     use System;
with System.Storage_Elements;    use System.Storage_Elements;

package body GNATCOLL.Mmap is

   type Mapped_File_Record is record
      Current_Region     : Mapped_Region;
      --  The legacy API enables only one region to be mapped, directly
      --  associated with the mapped file. This references this region.

      File               : System_File;
      --  Underlying OS-level file
   end record;

   type Mapped_Region_Record is record
      File          : Mapped_File;
      --  The file this region comes from. Be careful: for reading file, it is
      --  valid to have it closed before one of its regions is free'd.

      Write         : Boolean;
      --  Whether the file this region comes from is open for writing.

      Data          : Standard.System.Address :=
         Standard.System.Null_Address;
      --  Unbounded access to the mapped content.

      System_Offset : File_Size;
      --  Position in the file of the first byte actually mapped in memory

      User_Offset   : File_Size;
      --  Position in the file of the first byte requested by the user

      System_Size   : File_Size;
      --  Size of the region actually mapped in memory

      User_Size     : File_Size;
      --  Size of the region requested by the user

      Mapped        : Boolean;
      --  Whether this region is actually memory mapped

      Mutable       : Boolean;
      --  If the file is opened for reading, wheter this region is writable

      Buffer        : GNAT.Strings.String_Access;
      --  When this region is not actually memory mapped, contains the
      --  requested bytes.

      Mapping       : System_Mapping;
      --  Underlying OS-level data for the mapping, if any
   end record;

   Invalid_Mapped_Region_Record : constant Mapped_Region_Record :=
     (null, False, Standard.System.Null_Address, 0, 0, 0, 0, False,
      False, null, Invalid_System_Mapping);
   Invalid_Mapped_File_Record : constant Mapped_File_Record :=
     (Invalid_Mapped_Region, Invalid_System_File);

   Empty_String : constant String := "";
   --  Used to provide a valid empty Data for empty files, for instanc.

   procedure Dispose is new Ada.Unchecked_Deallocation
     (Mapped_File_Record, Mapped_File);
   procedure Dispose is new Ada.Unchecked_Deallocation
     (Mapped_Region_Record, Mapped_Region);

   procedure Compute_Data (Region : Mapped_Region);
   --  Fill the Data field according to system and user offsets. The region
   --  must actually be mapped or bufferized.

   procedure From_Disk (Region : Mapped_Region);
   --  Read a region of some file from the disk.
   --  Doesn't use the mmap system call.

   procedure To_Disk (Region : Mapped_Region);
   --  Write the region of the file back to disk if necessary, and free memory

   ---------------
   -- Open_Read --
   ---------------

   function Open_Read
     (Filename              : String;
      Use_Mmap_If_Available : Boolean := True) return Mapped_File
   is
      File : constant System_File :=
         Open_Read (Filename, Use_Mmap_If_Available);
   begin
      return new Mapped_File_Record'
        (Current_Region => Invalid_Mapped_Region,
         File           => File);
   end Open_Read;

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

   function Open_Write
     (Filename              : String;
      Use_Mmap_If_Available : Boolean := True) return Mapped_File
   is
      File : constant System_File :=
         Open_Write (Filename, Use_Mmap_If_Available);
   begin
      return new Mapped_File_Record'
        (Current_Region => Invalid_Mapped_Region,
         File           => File);
   end Open_Write;

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

   procedure Close (File : in out Mapped_File) is
   begin
      --  Closing a closed file is allowed and should do nothing

      if File = Invalid_Mapped_File then
         return;
      end if;

      if File.Current_Region /= null then
         Free (File.Current_Region);
      end if;

      if File.File /= Invalid_System_File then
         Close (File.File);
      end if;

      Dispose (File);
   end Close;

   ----------
   -- Free --
   ----------

   procedure Free (Region : in out Mapped_Region) is
      Ignored : Integer;
      pragma Unreferenced (Ignored);
   begin
      --  Freeing an already free'd file is allowed and should do nothing

      if Region = Invalid_Mapped_Region then
         return;
      end if;

      if Region.Mapping /= Invalid_System_Mapping then
         Dispose_Mapping (Region.Mapping);
      end if;
      To_Disk (Region);
      Dispose (Region);
   end Free;

   ----------
   -- Read --
   ----------

   procedure Read
     (File    : Mapped_File;
      Region  : in out Mapped_Region;
      Offset  : File_Size := 0;
      Length  : File_Size := 0;
      Mutable : Boolean := False;
      Advice  : Use_Advice := Use_Normal)
   is
      File_Length      : constant File_Size := GNATCOLL.Mmap.Length (File);

      Req_Offset       : constant File_Size := Offset;
      Req_Length       : File_Size := Length;
      --  Offset and Length of the region to map, used to adjust mapping
      --  bounds, reflecting what the user will see.

      Region_Allocated : Boolean := False;
   begin
      --  If this region comes from another file, or simply if the file is
      --  writeable, we cannot re-use this mapping: free it first.

      if Region /= Invalid_Mapped_Region
        and then
          (Region.File /= File or else File.File.Write)
      then
         Free (Region);
      end if;

      if Region = Invalid_Mapped_Region then
         Region := new Mapped_Region_Record'(Invalid_Mapped_Region_Record);
         Region_Allocated := True;
      end if;

      Region.File := File;

      if Req_Offset >= File_Length then
         --  If the requested offset goes beyond file size, map nothing

         Req_Length := 0;

      elsif Length = 0
        or else
          Length > File_Length - Req_Offset
      then
         --  If Length is 0 or goes beyond file size, map till end of file

         Req_Length := File_Length - Req_Offset;

      else
         Req_Length := Length;
      end if;

      --  Past this point, the offset/length the user will see is fixed. On the
      --  other hand, the system offset/length is either already defined, from
      --  a previous mapping, or it is set to 0. In the latter case, the next
      --  step will set them according to the mapping.

      Region.User_Offset := Req_Offset;
      Region.User_Size := Req_Length;

      --  If the requested region is inside an already mapped region, adjust
      --  user-requested data and do nothing else.

      if (File.File.Write or else Region.Mutable = Mutable)
        and then
        Req_Offset >= Region.System_Offset
        and then
            (Req_Offset + Req_Length
             <= Region.System_Offset + Region.System_Size)
      then
         Region.User_Offset := Req_Offset;
         Compute_Data (Region);
         return;

      elsif Region.Buffer /= null then
         --  Otherwise, as we are not going to re-use the buffer, free it

         GNAT.Strings.Free (Region.Buffer);
         Region.Buffer := null;

      elsif Region.Mapping /= Invalid_System_Mapping then
         --  Otherwise, there is a memory mapping that we need to unmap.
         Dispose_Mapping (Region.Mapping);
      end if;

      --  mmap() will sometimes return NULL when the file exists but is empty,
      --  which is not what we want, so in the case of a zero length file we
      --  fall back to read(2)/write(2)-based mode.

      if File_Length > 0 and then File.File.Mapped then

         Region.System_Offset := Req_Offset;
         Region.System_Size := Req_Length;
         Create_Mapping
           (File.File,
            Region.System_Offset, Region.System_Size,
            Mutable,
            Region.Mapping,
            Advice);
         Region.Mapped := True;
         Region.Mutable := Mutable;

      else
         --  There is no alignment requirement when manually reading the file.

         Region.System_Offset := Req_Offset;
         Region.System_Size := Req_Length;
         Region.Mapped := False;
         Region.Mutable := True;
         From_Disk (Region);
      end if;

      Region.Write := File.File.Write;
      Compute_Data (Region);

   exception
      when others =>
         --  Before propagating any exception, free any region we allocated
         --  here.

         if Region_Allocated then
            Dispose (Region);
         end if;
         raise;
   end Read;

   ----------
   -- Read --
   ----------

   procedure Read
     (File    : Mapped_File;
      Offset  : File_Size := 0;
      Length  : File_Size := 0;
      Mutable : Boolean := False)
   is
   begin
      Read (File, File.Current_Region, Offset, Length, Mutable);
   end Read;

   ----------
   -- Read --
   ----------

   function Read
     (File    : Mapped_File;
      Offset  : File_Size := 0;
      Length  : File_Size := 0;
      Mutable : Boolean := False;
      Advice  : Use_Advice := Use_Normal) return Mapped_Region
   is
      Region  : Mapped_Region := Invalid_Mapped_Region;
   begin
      Read (File, Region, Offset, Length, Mutable, Advice);
      return Region;
   end Read;

   ------------
   -- Length --
   ------------

   function Length (File : Mapped_File) return File_Size is
   begin
      return File.File.Length;
   end Length;

   ------------
   -- Offset --
   ------------

   function Offset (Region : Mapped_Region) return File_Size is
   begin
      return Region.User_Offset;
   end Offset;

   ------------
   -- Offset --
   ------------

   function Offset (File : Mapped_File) return File_Size is
   begin
      return Offset (File.Current_Region);
   end Offset;

   ---------------
   -- Data_Size --
   ---------------

   function Data_Size (Region : Mapped_Region) return File_Size is
   begin
      return Region.User_Size;
   end Data_Size;

   ---------------
   -- Data_Size --
   ---------------

   function Data_Size (File : Mapped_File) return File_Size is
   begin
      return Data_Size (File.Current_Region);
   end Data_Size;

   ------------------
   -- Data_Address --
   ------------------

   function Data_Address (Region : Mapped_Region)
      return Standard.System.Address is
   begin
      return Region.Data;
   end Data_Address;

   ------------------
   -- Data_Address --
   ------------------

   function Data_Address (File : Mapped_File)
      return Standard.System.Address is
   begin
      return Data_Address (File.Current_Region);
   end Data_Address;

   ----------------
   -- Is_Mutable --
   ----------------

   function Is_Mutable (Region : Mapped_Region) return Boolean is
   begin
      return Region.Mutable or Region.Write;
   end Is_Mutable;

   ----------------
   -- Is_Mmapped --
   ----------------

   function Is_Mmapped (File : Mapped_File) return Boolean is
   begin
      return File.File.Mapped;
   end Is_Mmapped;

   -------------------
   -- Get_Page_Size --
   -------------------

   function Get_Page_Size return Positive is
      Result : constant File_Size := Get_Page_Size;
   begin
      return Positive (Result);
   end Get_Page_Size;

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

   function Read_Whole_File
     (Filename           : String;
      Empty_If_Not_Found : Boolean := False) return GNAT.Strings.String_Access
   is
      File   : Mapped_File := Open_Read (Filename);
      Region : Mapped_Region renames File.Current_Region;
      Result : String_Access;
   begin
      Read (File);

      if Region.Data /= Standard.System.Null_Address then
         Result := new String'
            (String (Data (Region) (1 .. Integer (Last (Region)))));

      elsif Region.Buffer /= null then
         Result := Region.Buffer;
         Region.Buffer := null;  --  So that it is not deallocated
      end if;

      Close (File);

      return Result;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         if Empty_If_Not_Found then
            return new String'("");
         else
            return null;
         end if;

      when others =>
         Close (File);
         return null;
   end Read_Whole_File;

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

   function Read_Whole_File
     (Filename           : String) return GNATCOLL.Strings.XString
   is
      File   : Mapped_File := Open_Read (Filename);
      Region : Mapped_Region renames File.Current_Region;
      Result : XString;
   begin
      Read (File);

      if Region.Data /= Standard.System.Null_Address then
         Result.Set (String (Data (Region) (1 .. Last (Region))));

      elsif Region.Buffer /= null then
         Result.Set (Region.Buffer.all);
      end if;

      Close (File);

      return Result;

   exception
      when Ada.IO_Exceptions.Name_Error =>
         return GNATCOLL.Strings.Null_XString;

      when others =>
         Close (File);
         return GNATCOLL.Strings.Null_XString;
   end Read_Whole_File;

   ---------------
   -- From_Disk --
   ---------------

   procedure From_Disk (Region : Mapped_Region) is
   begin
      pragma Assert (Region.File.all /= Invalid_Mapped_File_Record);
      pragma Assert (Region.Buffer = null);

      Region.Buffer := Read_From_Disk
        (Region.File.File, Region.User_Offset, Region.User_Size);
      Region.Mapped := False;
   end From_Disk;

   -------------
   -- To_Disk --
   -------------

   procedure To_Disk (Region : Mapped_Region) is
   begin
      if Region.Write and then Region.Buffer /= null then
         pragma Assert (Region.File.all /= Invalid_Mapped_File_Record);
         Write_To_Disk
           (Region.File.File,
            Region.User_Offset, Region.User_Size,
            Region.Buffer);
      end if;

      GNAT.Strings.Free (Region.Buffer);
      Region.Buffer := null;
   end To_Disk;

   ------------------
   -- Compute_Data --
   ------------------

   procedure Compute_Data (Region : Mapped_Region) is
      Data_Shift : constant Storage_Offset :=
         Storage_Offset (Region.User_Offset - Region.System_Offset);
   begin
      if Region.User_Size = 0 then
         Region.Data := Empty_String'Address;
      elsif Region.Mapped then
         Region.Data := Region.Mapping.Address + Data_Shift;
      else
         Region.Data := Region.Buffer.all'Address + Data_Shift;
      end if;
   end Compute_Data;

end GNATCOLL.Mmap;