| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- S Y S T E M . M M A P . O S _ I N T E R F A C E -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2007-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/>. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Ada.IO_Exceptions; |
| with System.Strings; use System.Strings; |
| |
| with System.OS_Lib; |
| pragma Unreferenced (System.OS_Lib); |
| -- Only used to generate same runtime dependencies and same binder file on |
| -- GNU/Linux and Windows. |
| |
| package body System.Mmap.OS_Interface is |
| |
| use Win; |
| |
| function Align |
| (Addr : File_Size) return File_Size; |
| -- Align some offset/length to the lowest page boundary |
| |
| function Open_Common |
| (Filename : String; |
| Use_Mmap_If_Available : Boolean; |
| Write : Boolean) return System_File; |
| |
| function From_UTF8 (Path : String) return Wide_String; |
| -- Convert from UTF-8 to Wide_String |
| |
| --------------- |
| -- From_UTF8 -- |
| --------------- |
| |
| function From_UTF8 (Path : String) return Wide_String is |
| function MultiByteToWideChar |
| (Codepage : Interfaces.C.unsigned; |
| Flags : Interfaces.C.unsigned; |
| Mbstr : Address; |
| Mb : Natural; |
| Wcstr : Address; |
| Wc : Natural) return Integer; |
| pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar"); |
| |
| Current_Codepage : Interfaces.C.unsigned; |
| pragma Import (C, Current_Codepage, "__gnat_current_codepage"); |
| |
| Len : Natural; |
| begin |
| -- Compute length of the result |
| Len := MultiByteToWideChar |
| (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0); |
| if Len = 0 then |
| raise Constraint_Error; |
| end if; |
| |
| declare |
| -- Declare result |
| Res : Wide_String (1 .. Len); |
| begin |
| -- And compute it |
| Len := MultiByteToWideChar |
| (Current_Codepage, 0, |
| Path'Address, Path'Length, |
| Res'Address, Len); |
| if Len = 0 then |
| raise Constraint_Error; |
| end if; |
| return Res; |
| end; |
| end From_UTF8; |
| |
| ----------------- |
| -- Open_Common -- |
| ----------------- |
| |
| function Open_Common |
| (Filename : String; |
| Use_Mmap_If_Available : Boolean; |
| Write : Boolean) return System_File |
| is |
| dwDesiredAccess, dwShareMode : DWORD; |
| PageFlags : DWORD; |
| |
| W_Filename : constant Wide_String := |
| From_UTF8 (Filename) & Wide_Character'Val (0); |
| File_Handle, Mapping_Handle : HANDLE; |
| |
| SizeH : aliased DWORD; |
| Size : File_Size; |
| begin |
| if Write then |
| dwDesiredAccess := GENERIC_READ + GENERIC_WRITE; |
| dwShareMode := 0; |
| PageFlags := Win.PAGE_READWRITE; |
| else |
| dwDesiredAccess := GENERIC_READ; |
| dwShareMode := Win.FILE_SHARE_READ; |
| PageFlags := Win.PAGE_READONLY; |
| end if; |
| |
| -- Actually open the file |
| |
| File_Handle := CreateFile |
| (W_Filename'Address, dwDesiredAccess, dwShareMode, |
| null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0); |
| |
| if File_Handle = Win.INVALID_HANDLE_VALUE then |
| return Invalid_System_File; |
| end if; |
| |
| -- Compute its size |
| |
| Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access)); |
| |
| if Size = Win.INVALID_FILE_SIZE then |
| return Invalid_System_File; |
| end if; |
| |
| if SizeH /= 0 and then File_Size'Size > 32 then |
| Size := Size + (File_Size (SizeH) * 2 ** 32); |
| end if; |
| |
| -- Then create a mapping object, if needed. On Win32, file memory |
| -- mapping is always available. |
| |
| if Use_Mmap_If_Available then |
| Mapping_Handle := |
| Win.CreateFileMapping |
| (File_Handle, null, PageFlags, |
| 0, DWORD (Size), Standard.System.Null_Address); |
| else |
| Mapping_Handle := Win.INVALID_HANDLE_VALUE; |
| end if; |
| |
| return |
| (Handle => File_Handle, |
| Mapped => Use_Mmap_If_Available, |
| Mapping_Handle => Mapping_Handle, |
| Write => Write, |
| Length => Size); |
| end Open_Common; |
| |
| --------------- |
| -- Open_Read -- |
| --------------- |
| |
| function Open_Read |
| (Filename : String; |
| Use_Mmap_If_Available : Boolean := True) return System_File is |
| begin |
| return Open_Common (Filename, Use_Mmap_If_Available, False); |
| end Open_Read; |
| |
| ---------------- |
| -- Open_Write -- |
| ---------------- |
| |
| function Open_Write |
| (Filename : String; |
| Use_Mmap_If_Available : Boolean := True) return System_File is |
| begin |
| return Open_Common (Filename, Use_Mmap_If_Available, True); |
| end Open_Write; |
| |
| ----------- |
| -- Close -- |
| ----------- |
| |
| procedure Close (File : in out System_File) is |
| Ignored : BOOL; |
| pragma Unreferenced (Ignored); |
| begin |
| Ignored := CloseHandle (File.Mapping_Handle); |
| Ignored := CloseHandle (File.Handle); |
| File.Handle := Win.INVALID_HANDLE_VALUE; |
| File.Mapping_Handle := Win.INVALID_HANDLE_VALUE; |
| end Close; |
| |
| -------------------- |
| -- Read_From_Disk -- |
| -------------------- |
| |
| function Read_From_Disk |
| (File : System_File; |
| Offset, Length : File_Size) return System.Strings.String_Access |
| is |
| Buffer : String_Access := new String (1 .. Integer (Length)); |
| |
| Pos : DWORD; |
| NbRead : aliased DWORD; |
| pragma Unreferenced (Pos); |
| begin |
| Pos := Win.SetFilePointer |
| (File.Handle, LONG (Offset), null, Win.FILE_BEGIN); |
| |
| if Win.ReadFile |
| (File.Handle, Buffer.all'Address, |
| DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE |
| then |
| System.Strings.Free (Buffer); |
| raise Ada.IO_Exceptions.Device_Error; |
| end if; |
| return Buffer; |
| end Read_From_Disk; |
| |
| ------------------- |
| -- Write_To_Disk -- |
| ------------------- |
| |
| procedure Write_To_Disk |
| (File : System_File; |
| Offset, Length : File_Size; |
| Buffer : System.Strings.String_Access) |
| is |
| Pos : DWORD; |
| NbWritten : aliased DWORD; |
| pragma Unreferenced (Pos); |
| begin |
| pragma Assert (File.Write); |
| Pos := Win.SetFilePointer |
| (File.Handle, LONG (Offset), null, Win.FILE_BEGIN); |
| |
| if Win.WriteFile |
| (File.Handle, Buffer.all'Address, |
| DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE |
| then |
| raise Ada.IO_Exceptions.Device_Error; |
| end if; |
| end Write_To_Disk; |
| |
| -------------------- |
| -- Create_Mapping -- |
| -------------------- |
| |
| procedure Create_Mapping |
| (File : System_File; |
| Offset, Length : in out File_Size; |
| Mutable : Boolean; |
| Mapping : out System_Mapping) |
| is |
| Flags : DWORD; |
| begin |
| if File.Write then |
| Flags := Win.FILE_MAP_WRITE; |
| elsif Mutable then |
| Flags := Win.FILE_MAP_COPY; |
| else |
| Flags := Win.FILE_MAP_READ; |
| end if; |
| |
| -- Adjust offset and mapping length to account for the required |
| -- alignment of offset on page boundary. |
| |
| declare |
| Queried_Offset : constant File_Size := Offset; |
| begin |
| Offset := Align (Offset); |
| |
| -- First extend the length to compensate the offset shift, then align |
| -- it on the upper page boundary, so that the whole queried area is |
| -- covered. |
| |
| Length := Length + Queried_Offset - Offset; |
| Length := Align (Length + Get_Page_Size - 1); |
| |
| -- But do not exceed the length of the file |
| if Offset + Length > File.Length then |
| Length := File.Length - Offset; |
| end if; |
| end; |
| |
| if Length > File_Size (Integer'Last) then |
| raise Ada.IO_Exceptions.Device_Error; |
| else |
| Mapping := Invalid_System_Mapping; |
| Mapping.Address := |
| Win.MapViewOfFile |
| (File.Mapping_Handle, Flags, |
| 0, DWORD (Offset), SIZE_T (Length)); |
| Mapping.Length := Length; |
| end if; |
| end Create_Mapping; |
| |
| --------------------- |
| -- Dispose_Mapping -- |
| --------------------- |
| |
| procedure Dispose_Mapping |
| (Mapping : in out System_Mapping) |
| is |
| Ignored : BOOL; |
| pragma Unreferenced (Ignored); |
| begin |
| Ignored := Win.UnmapViewOfFile (Mapping.Address); |
| Mapping := Invalid_System_Mapping; |
| end Dispose_Mapping; |
| |
| ------------------- |
| -- Get_Page_Size -- |
| ------------------- |
| |
| function Get_Page_Size return File_Size is |
| SystemInfo : aliased SYSTEM_INFO; |
| begin |
| GetSystemInfo (SystemInfo'Unchecked_Access); |
| return File_Size (SystemInfo.dwAllocationGranularity); |
| end Get_Page_Size; |
| |
| ----------- |
| -- Align -- |
| ----------- |
| |
| function Align |
| (Addr : File_Size) return File_Size is |
| begin |
| return Addr - Addr mod Get_Page_Size; |
| end Align; |
| |
| end System.Mmap.OS_Interface; |
