unit smMappedFile;

interface

uses
  System.SysUtils, System.Classes;

type
  TMappedFileStream = class(TStream)
  private
    FFileName: string;
    FHandle: THandle;       // file handle
    FMappedBase: Int64;     // mapping start position
    FMappedSize: NativeInt; // current size of mapping window
    FMapping: THandle;      // handle of file mapping
    FBufferSeek: NativeInt; // file pointer in mapped view
    FDefMapSize: NativeInt; // default size of mapping window
    FMemory: PByte;         // address of mapping window
    FFileSize: Int64;       // available file size
  protected
    function GetSize: Int64; override;
    procedure SetSize(const NewSize: Int64); override;
    procedure RemapAtPosition(RemapBase: Int64);
  public
    constructor Create(const AFileName: string; MapWindowSize: NativeInt = 16777216);
    destructor Destroy; override;
    function Read(var Buffer; Count: Integer): Longint; override;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
    function Write(const Buffer; Count: Integer): Longint; override;
    property FileName: string read FFileName;
  end;

implementation

uses
  Winapi.Windows, System.RTLConsts;

resourcestring
  sMappedFileIsEmpty = 'Can not map view of zero-length file %s.';
  sSeekBeyondRange   = 'File pointer moved beyond file bounds.';
  sFileMappingError  = 'Error mapping view to file.';
  sStreamIsReadOnly  = 'Stream is read-only.';

function Min(A, B: Cardinal): Cardinal;
begin
  Result := A;
  if B < A then
    Result := B
end;

{ TMappedFileStream }

constructor TMappedFileStream.Create(const AFileName: string; MapWindowSize: NativeInt = 16777216);
begin
  inherited Create;
  FHandle := FileOpen(AFileName, fmOpenRead or fmShareDenyWrite);
  if FHandle = INVALID_HANDLE_VALUE then
    raise EFOpenError.CreateResFmt(@SFOpenErrorEx, [ExpandFileName(AFileName), SysErrorMessage(GetLastError)]);
  FFileName := AFileName;
  PCardinal(@FFileSize)^ := GetFileSize(FHandle, PByte(@FFileSize) + 4);
  if FFileSize = 0 then
    raise EFileStreamError.CreateResFmt(@sMappedFileIsEmpty, [ExpandFileName(AFileName)]);
  FMapping := CreateFileMapping(FHandle, nil, PAGE_READONLY, 0, 0, nil);
  RemapAtPosition(FMappedBase);
end;

destructor TMappedFileStream.Destroy;
begin
  if FMemory <> nil then
    UnmapViewOfFile(FMemory);
  CloseHandle(FMapping);
  FileClose(FHandle);
  inherited;
end;

procedure TMappedFileStream.RemapAtPosition(RemapBase: Int64);
var
  OldBase: Int64;
begin
  OldBase := FMappedBase;
  if FMemory <> nil then
    UnmapViewOfFile(FMemory);
  if FFileSize < FDefMapSize then 
  begin
    FMappedSize := FFileSize;
    FMappedBase := 0;
  end else 
  begin
    FMappedSize := FDefMapSize;
    if FFileSize - RemapBase < FDefMapSize then
      FMappedBase := FFileSize - FDefMapSize
    else 
      FMappedBase := RemapBase;
  end;
  FBufferSeek := FBufferSeek - (OldBase - FMappedBase);
  FMemory := MapViewOfFile(FMapping, PAGE_READONLY, Int64Rec(FMappedBase).Hi, Int64Rec(FMappedBase).Lo, FMappedSize);
  if FMemory = nil then
    raise EStreamError.CreateRes(@sFileMappingError);
end;

function TMappedFileStream.GetSize: Int64;
begin
  Result := FFileSize;
end;

function TMappedFileStream.Read(var Buffer; Count: Integer): Longint;
var
  BytesToRead: Integer;
begin
  Result := 0;
  while (Result < Count) and (FMappedBase + FBufferSeek < FFileSize) do 
  begin
    if FBufferSeek >= FMappedSize then
      RemapAtPosition(FMappedBase + FMappedSize);
    BytesToRead := Min(FMappedSize - FBufferSeek, Count - Result);
    Move((FMemory + FBufferSeek)^, (PByte(Buffer) + Result)^, BytesToRead);
    Inc(Result, BytesToRead);
  end;
end;

function TMappedFileStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var
  FilePointer: Int64;
begin
  case Origin of
    soCurrent: FilePointer := FMappedBase + FBufferSeek + Offset;
    soEnd: FilePointer := FFileSize + Offset;
  else
    FilePointer := Offset; // soBeginning
  end;
  if (FilePointer < 0) or (FilePointer > FFileSize) then
    raise EStreamError.CreateRes(@sSeekBeyondRange);
  if (FilePointer < FMappedBase) or ((FilePointer - FMappedBase) >= FMappedSize) then 
  begin
    FMappedBase := FilePointer;
    FBufferSeek := 0;
    RemapAtPosition(FMappedBase);
  end else 
    FBufferSeek := FilePointer - FMappedBase;
  Result := FilePointer;
end;

procedure TMappedFileStream.SetSize(const NewSize: Int64);
begin
  raise EStreamError.CreateRes(@sStreamIsReadOnly);
end;

function TMappedFileStream.Write(const Buffer; Count: Integer): Longint;
begin
  raise EStreamError.CreateRes(@sStreamIsReadOnly);
end;

end.