{$MODE OBJFPC}
unit dmmap;

interface

{$IF Defined(WINDOWS)}
  // TODO Check Windows CE/Windows Mobile for generic implementation compability
  //      If it does not work, change WINDOWS to MSWINDOWS
  {$DEFINE MMAP_IMPLEMENTATION_WINDOWS}
  //{$DEFINE MMAP_IMPLEMENTATION_FALLBACK}
{$ELSEIF Defined(UNIX)}
  {$DEFINE MMAP_IMPLEMENTATION_POSIX}
{$ELSE}
  {$DEFINE MMAP_IMPLEMENTATION_FALLBACK}
{$ENDIF}

{$IFDEF MMAP_IMPLEMENTATION_WINDOWS}
uses
  windows;
{$ENDIF}

{$IFDEF MMAP_IMPLEMENTATION_POSIX}
uses
  BaseUnix;
{$ENDIF}

type
PMMappedArea = ^TMMappedArea;
TMMappedArea = object
protected
  FData: PByte;
  FSize: SizeUInt;
public
  function IsValid: Boolean; inline;
  property Data: PByte read FData;
  property Size: SizeUInt read FSize;
end;

TMMappedFile = object(TMMappedArea)
public const
  ERROR_SOURCE_NO       = 0; // No error
  ERROR_SOURCE_SYSTEM   = 1; // Platfrom-specific (errno/GetLastError)
  ERROR_SOURCE_FPC_IO   = 2; // IOResult
  ERROR_SOURCE_MMAP     = 3; // see ERROR_CODE_*

  // if Source = ERROR_SOURCE_MMAP
  ERROR_CODE_NO                 = 0;
  ERROR_CODE_WRONG_ARGUMENTS    = 1;
public type
  PError = ^TError;
  TError = record
    Source: LongInt;                   // ERROR_SOURCE_*
    Code: LongInt;                     // Source-dependent error code
    Desc: array[0 .. 100] of AnsiChar; // Human-readable error description
  end;
public const
  FLAG_PRECHARGE    = 1; // Instead of mmapping load all data to memory
  FLAG_WRITE        = 2; // Open file with write permissions
                         // This library does not provide Flush method so
                         // you should either implement it by yourself or
                         // do not rely on any modification garantee
public
  procedure Init(FileName: PAnsiChar;
                 Flags: LongInt = 0;
                 Error: PError = nil);
  procedure InitW(FileName: PWideChar;
                  Flags: LongInt = 0;
                  Error: PError = nil);
  procedure Done;
private
  {$IF Defined(MMAP_IMPLEMENTATION_WINDOWS)}
  FFile: THandle;
  FHandle: THandle;
  {$ENDIF}
  FFlags: LongInt;
end;

function TryMmapFile(var MmappedFile: TMMappedFile;
                     FileName: PAnsiChar;
                     Flags: LongInt = 0;
                     Error: TMMappedFile.PError = nil): Boolean;
function TryMmapFileW(var MmappedFile: TMMappedFile;
                      FileName: PWideChar;
                      Flags: LongInt = 0;
                      Error: TMMappedFile.PError = nil): Boolean;

implementation

function TMMappedArea.IsValid: Boolean;
begin
  Result := FData <> nil;
end;

procedure ErrorCodeToStr(Code: Cardinal;
                         Buffer: PAnsiChar;
                         Size: Cardinal); inline;
begin
end;

procedure FormatError(Code: Cardinal;
                      CodeContext: PAnsiChar;
                      Buffer: PAnsiChar;
                      Size: Cardinal);
var
  L: LongInt;
begin
  // Copy code infotmation
  L := Length(CodeContext);
  if L > Size then
    L := Size;
  Move(CodeContext^, Buffer^, L + 1);
  Dec(Size, L);
  Inc(Buffer, L);
end;

function FpcIOError(CodeContext: PAnsiChar;
                    Error: TMMappedFile.PError): Boolean;
var
  Code: Word;
begin
  Code := IOResult;
  Result := Code <> 0;
  if Result and (Error <> nil) then begin
    Error^.Source := TMMappedFile.ERROR_SOURCE_FPC_IO;
    Error^.Code := Code;
  end;
end;

function FpcReadFile(FileName: PAnsiChar;
                     out Data: PByte;
                     out Size: SizeUInt;
                     Error: TMMappedFile.PError): Boolean;
label
  FreeMemExit,
  FileExit;
var
  F: file;
  SavedReturnNilIfGrowHeapFails: Boolean;
  ReadBytes: LongInt;
begin
{$PUSH}{$I-}
  Assign(F, FileName);
  Reset(F, 1);
  if FpcIOError('(FileReset)', Error) then
    Exit(False);

  Size := FileSize(F);
  if FpcIOError('(FileSize)', Error) then
    goto FileExit;

  SavedReturnNilIfGrowHeapFails := ReturnNilIfGrowHeapFails;
  ReturnNilIfGrowHeapFails := True;
  Data := GetMem(Size);
  ReturnNilIfGrowHeapFails := SavedReturnNilIfGrowHeapFails;
  if Data = nil then begin
    // TODO fill Error
    goto FileExit;
  end;

  BlockRead(F, Data^, Size, ReadBytes);
  if FpcIOError('(BlockRead)', Error) then
    goto FreeMemExit;
  if ReadBytes <> Size then begin
    // TODO fill Error
    goto FreeMemExit;
  end;

  Close(F);
  Exit(True);

FreeMemExit:
  FreeMem(Data);

FileExit:
  Close(F);
  Exit(False);
{$POP}
end;

function FpcReadFileW(FileName: PWideChar;
                     out Data: PByte;
                     out Size: SizeUInt;
                     Error: TMMappedFile.PError): Boolean;
label
  FreeMemExit,
  FileExit;
var
  F: file;
  SavedReturnNilIfGrowHeapFails: Boolean;
  ReadBytes: LongInt;
begin
{$PUSH}{$I-}
  Assign(F, FileName);
  Reset(F);
  if FpcIOError('(FileReset)', Error) then
    Exit(False);

  Size := FileSize(F);
  if FpcIOError('(FileSize)', Error) then
    goto FileExit;

  SavedReturnNilIfGrowHeapFails := ReturnNilIfGrowHeapFails;
  ReturnNilIfGrowHeapFails := True;
  Data := GetMem(Size);
  ReturnNilIfGrowHeapFails := SavedReturnNilIfGrowHeapFails;
  if Data = nil then begin
    // TODO fill Error
    goto FileExit;
  end;

  BlockRead(F, Data^, Size, ReadBytes);
  if FpcIOError('(BlockRead)', Error) then
    goto FreeMemExit;
  if ReadBytes <> Size then begin
    // TODO fill Error
    goto FreeMemExit;
  end;

  Close(F);
  Exit(True);

FreeMemExit:
  FreeMem(Data);

FileExit:
  Close(F);
  Exit(False);
{$POP}
end;

{$IFDEF MMAP_IMPLEMENTATION_WINDOWS}
procedure WindowsFormatError(Code: Cardinal;
                             CodeContext: PAnsiChar;
                             Buffer: PAnsiChar;
                             Size: Cardinal);
var
  L: LongInt;
begin
  // Copy code infotmation
  L := Length(CodeContext);
  if L > Size then
    L := Size;
  Move(CodeContext^, Buffer^, L + 1);
  Dec(Size, L);
  Inc(Buffer, L);

  FormatMessageA(
      FORMAT_MESSAGE_FROM_SYSTEM or
      FORMAT_MESSAGE_IGNORE_INSERTS,
      nil,
      Code,
      MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US),
      Buffer,
      Size,
      nil);

  // FormatMessage adds new lines to the result, we want to remove it
  L := Length(Buffer) - 1;
  while (L >= 0) and
        ((Buffer[L] = AnsiChar(13)) or (Buffer[L] = AnsiChar(10))) do
    Dec(L);
  Buffer[L + 1] := #0;
end;

procedure WindowsGetLastError(CodeContext: PAnsiChar;
                              Error: TMMappedFile.PError); inline;
begin
  if Error <> nil then begin
    Error^.Source := TMMappedFile.ERROR_SOURCE_SYSTEM;
    Error^.Code := windows.GetLastError;
    WindowsFormatError(Error^.Code,
                       CodeContext,
                       @Error^.Desc[0],
                       Length(Error^.Desc));
  end;
end;

function WindowsUtf8ToWide(Utf8: PAnsiChar;
                           Buffer: PWideChar;
                           Len: Cardinal;
                           Error: TMMappedFile.PError): Boolean;
begin
  Result := 0 <> windows.MultiByteToWideChar(CP_UTF8,
                                             MB_ERR_INVALID_CHARS,
                                             Utf8,
                                             StrLen(Utf8) + 1,
                                             Buffer,
                                             Len);
  if not Result then
    WindowsGetLastError('(MultiByteToWideChar) ', Error);
end;

function WindowsCreateFile(FileName: PWideChar;
                           Flags: LongInt;
                           out Handle: windows.Handle;
                           Error: TMMappedFile.PError): Boolean; inline;
var
  DesiredAccess: Cardinal;
  ShareMode: Cardinal;
  FlagsAndAttributes: Cardinal;
begin
  if Flags and TMMappedFile.FLAG_WRITE <> 0 then begin
    DesiredAccess := GENERIC_READ and GENERIC_WRITE;
    ShareMode := FILE_SHARE_READ or FILE_SHARE_WRITE;
    FlagsAndAttributes := FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED;
  end else begin
    DesiredAccess := GENERIC_READ;
    ShareMode := FILE_SHARE_READ;
    FlagsAndAttributes := FILE_ATTRIBUTE_NORMAL;
  end;

  Handle := CreateFileW(
                FileName,
                DesiredAccess,
                ShareMode,
                nil,
                OPEN_EXISTING,
                FlagsAndAttributes,
                INVALID_HANDLE_VALUE);

  Result := Handle <> INVALID_HANDLE_VALUE;

  if not Result then
    WindowsGetLastError('(CreateFileW) ', Error);
end;

function WindowsGetFileSize(const Handle: windows.Handle;
                            out Size: SizeUInt;
                            Error: TMMappedFile.PError): Boolean; inline;
var
  SL, SH: Cardinal;
begin
  SL := GetFileSize(Handle, @SH);
  if SL = INVALID_FILE_SIZE then begin
    WindowsGetLastError('(GetFileSize) ', Error);
    Exit(False);
  end;
  Size := SL or (SH shl 16);
  Exit(True);
end;

function WindowsCreateFileMapping(const File_: Handle;
                                  Flags: LongInt;
                                  out Mapping: windows.Handle;
                                  Error: TMMappedFile.PError): Boolean; inline;
var
  Protect: Cardinal;
begin
  if Flags and TMMappedFile.FLAG_WRITE <> 0 then begin
    Protect := PAGE_READWRITE;
  end else
    Protect := PAGE_READONLY;

  Mapping := CreateFileMappingA(File_, nil, Protect, 0, 0,nil);

  Result := Mapping <> 0;

  if not Result then
    WindowsGetLastError('(CreateFileMappingA) ', Error);
end;

function WindowsMapViewOfFile(const Mapping: windows.Handle;
                              Flags: LongInt;
                              out Data: PByte;
                              Error: TMMappedFile.PError): Boolean; inline;
var
  DesiredAccess: Cardinal;
begin
  if Flags and TMMappedFile.FLAG_WRITE <> 0 then begin
    DesiredAccess := FILE_MAP_WRITE;
  end else
    DesiredAccess := FILE_MAP_READ;

  Data := MapViewOfFile(Mapping, DesiredAccess, 0, 0, 0);

  Result := Data <> nil;

  if not Result then
    WindowsGetLastError('(MapViewOfFile) ', Error);
end;

procedure WindowsUnmapViewOfFile(Data: Pointer); inline;
begin
  if Data <> nil then
    windows.UnmapViewOfFile(Data);
end;

procedure WindowsCloseFile(const File_: windows.Handle); inline;
begin
  if File_ <> 0 then
    CloseHandle(File_);
end;

procedure WindowsCloseMapping(const Mapping: windows.Handle); inline;
begin
  if Mapping <> 0 then
    CloseHandle(Mapping);
end;

procedure WindowsFreeMMapedFileResources(var MMappedFile: TMMappedFile);
begin
  WindowsUnmapViewOfFile(MMappedFile.FData);
  WindowsCloseMapping(MMappedFile.FHandle);
  WindowsCloseFile(MMappedFile.FFile);
end;
{$ENDIF}

{$IFDEF MMAP_IMPLEMENTATION_POSIX}
procedure PosixGetLastError(Error: TMMappedFile.PError);
var
  S: AnsiString;
begin
  if Error <> nil then begin
    Error^.Source := TMMappedFile.ERROR_SOURCE_SYSTEM;
    Error^.Code := fpGetErrno;
    Str(Error^.Code, S);
    Move(PAnsiChar(S)^, Error^.Desc[0], Length(S) + 1);
  end;
end;

function PosixOpenFile(FileName: PAnsiChar;
                       Flags: LongInt;
                       out File_: LongInt;
                       Error: TMMappedFile.PError): Boolean; inline;
begin
  if Flags and TMMappedFile.FLAG_WRITE <> 0 then begin
    File_ := FpOpen(FileName, O_RDWR, 0);
  end else
    File_ := FpOpen(FileName, O_RDONLY, 0);

  Result := File_ >= 0;

  if not Result then
    PosixGetLastError(Error);
end;

function PosixGetFileSize(File_: LongInt;
                          out Size: SizeUInt;
                          Error: TMMappedFile.PError): Boolean; inline;
var
  Stat: BaseUnix.Stat;
begin
  Result := FpFStat(File_, Stat) = 0;
  if Result then begin
    Size := Stat.st_size;
  end else
    PosixGetLastError(Error);
end;


function PosixMmapFile(const File_: LongInt;
                       Flags: LongInt;
                       out Data: PByte;
                       Size: SizeUInt;
                       Error: TMMappedFile.PError): Boolean; inline;
begin
  if Flags and TMMappedFile.FLAG_WRITE <> 0 then begin
    Data := FpMmap(
              nil,
              Size,
              PROT_READ or PROT_WRITE,
              MAP_SHARED {or MAP_NOCORE},
              File_,
              0);
  end else
    Data := FpMmap(
              nil,
              Size,
              PROT_READ,
              MAP_SHARED {or MAP_NOCORE},
              File_,
              0);

  Result := Data <> Pointer(-1);

  if not Result then
    PosixGetLastError(Error);
end;

procedure PosixCloseFile(const File_: LongInt);
begin
  FpClose(File_);
end;

procedure PosixFreeMMapedFileResources(var MMappedFile: TMMappedFile); inline;
begin
  FpMUnMap(MMappedFile.FData, MMappedFile.FSize);
end;
{$ENDIF}

procedure TMMappedFile.Init(FileName: PAnsiChar;
                              Flags: LongInt = 0;
                              Error: PError = nil);
const
  ERROR_DESC_CONFLICTED_FLAGS: PAnsiChar = 'both FLAG_WRITE and FLAG_PRECHARGE can''t be specified at the same';
{$IFDEF MMAP_IMPLEMENTATION_FALLBACK}
  ERROR_DESC_UNSUPPORTED_WRITE: PAnsiChar = 'FLAG_WRITE is not supported on this platform';
{$ENDIF}
var
  Buffer: array[0..260] of WideChar;
{$IFDEF MMAP_IMPLEMENTATION_POSIX}
  Handle: LongInt;
{$ENDIF}
begin
  FData := nil;
  FSize := 0;

  if Error <> nil then begin
    Error^.Source := 0;
    Error^.Code := 0;
    Error^.Desc[0] := #0;
  end;

{$IFDEF MMAP_IMPLEMENTATION_FALLBACK}
  if Flags and FLAG_WRITE <> 0 then begin
    if Error <> nil then begin
      Error^.Source := ERROR_SOURCE_MMAP;
      Error^.Code := ERROR_CODE_WRONG_ARGUMENTS;
      Move(ERROR_DESC_UNSUPPORTED_WRITE^,
           Error^.Desc[0],
           Length(ERROR_DESC_UNSUPPORTED_WRITE) + 1);
    end;
    FData := nil;
    FSize := 0;
    Exit;
  end;
  Flags := Flags or FLAG_PRECHARGE;
{$ENDIF}

  FFlags := Flags;

  if Flags and FLAG_PRECHARGE <> 0 then begin
    if Flags and FLAG_WRITE <> 0 then begin
      if Error <> nil then begin
        Error^.Source := ERROR_SOURCE_MMAP;
        Error^.Code := ERROR_CODE_WRONG_ARGUMENTS;
        Move(ERROR_DESC_CONFLICTED_FLAGS^,
             Error^.Desc[0],
             Length(ERROR_DESC_CONFLICTED_FLAGS) + 1);
      end;
      Exit;
    end;
    if not FpcReadFile(FileName, FData, FSize, Error) then begin
      FData := nil;
      FSize := 0;
    end;
    Exit;
  end;

{$IFDEF MMAP_IMPLEMENTATION_WINDOWS}
  if not WindowsUtf8ToWide(FileName, @Buffer[0], Length(Buffer), Error) then
    Exit;
  InitW(@Buffer[0], Flags, Error);
{$ENDIF}

{$IFDEF MMAP_IMPLEMENTATION_POSIX}
  if not PosixOpenFile(FileName, Flags, Handle, Error) then
    Exit;
  if not PosixGetFileSize(Handle, FSize, Error) then begin
    PosixCloseFile(Handle);
    Exit;
  end;
  if not PosixMmapFile(Handle, Flags, FData, FSize, Error) then begin
    PosixCloseFile(Handle);
    FData := nil;
    Exit;
  end;
  PosixCloseFile(Handle);
{$ENDIF}
end;

procedure TMMappedFile.InitW(FileName: PWideChar;
                               Flags: LongInt = 0;
                               Error: PError = nil);
begin
{$IFDEF MMAP_IMPLEMENTATION_WINDOWS}
  if not WindowsCreateFile(FileName, Flags, FFile, Error) then
    Exit;

  if not WindowsGetFileSize(FFile, FSize, Error) or
     not WindowsCreateFileMapping(FFile, Flags, FHandle, Error) then begin
    WindowsCloseFile(FFile);
    Exit;
  end;

  if not WindowsMapViewOfFile(FHandle, Flags, FData, Error) then begin
    WindowsCloseMapping(FFile);
    WindowsCloseFile(FFile);
    FData := nil;
  end;
{$ENDIF}

{$IFDEF MMAP_IMPLEMENTATION_FALLBACK}
  if not FpcReadFileW(FileName, FData, FSize, Error) then begin
    FData := nil;
    FSize := 0;
  end;
{$ENDIF}
end;

procedure TMMappedFile.Done;
begin
  if FData = nil then
    Exit;

  if FFlags and FLAG_PRECHARGE <> 0 then begin
    FreeMem(FData);
    FData := nil;
    Exit;
  end;

{$IFDEF MMAP_IMPLEMENTATION_WINDOWS}
  WindowsFreeMMapedFileResources(Self);
{$ENDIF}

{$IFDEF MMAP_IMPLEMENTATION_POSIX}
  PosixFreeMMapedFileResources(Self);
{$ENDIF}

  FData := nil;
end;

function TryMmapFile(var MmappedFile: TMMappedFile;
                     FileName: PAnsiChar;
                     Flags: LongInt = 0;
                     Error: TMMappedFile.PError = nil): Boolean;
begin
  MmappedFile.Init(FileName, Flags, Error);
  Result := MmappedFile.IsValid;
  if not Result then
    MmappedFile.Done;
end;

function TryMmapFileW(var MmappedFile: TMMappedFile;
                      FileName: PWideChar;
                      Flags: LongInt = 0;
                      Error: TMMappedFile.PError = nil): Boolean;
begin
  MmappedFile.InitW(FileName, Flags, Error);
  Result := MmappedFile.IsValid;
  if not Result then
    MmappedFile.Done;
end;

end.
