{$IFNDEF FPC_DOTTEDUNITS}
unit dbf_pgfile;
{$ENDIF FPC_DOTTEDUNITS}
{
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2022 by Pascal Ganaye,Micha Nelissen and other members of the
    Free Pascal development team

    DBF  paging file support

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
interface

{$I dbf_common.inc}

{$IFDEF FPC_DOTTEDUNITS}
uses
  System.Classes,
  System.SysUtils,
  Data.Dbf.Common;
{$ELSE FPC_DOTTEDUNITS}
uses
  Classes,
  SysUtils,
  dbf_common;
{$ENDIF FPC_DOTTEDUNITS}

//const
//  MaxHeaders = 256;

type
  EPagedFile = Exception;

  TPagedFileMode = (pfNone, pfMemoryCreate, pfMemoryOpen, pfExclusiveCreate, 
    pfExclusiveOpen, pfReadWriteCreate, pfReadWriteOpen, pfReadOnly);

  // access levels:
  //
  // - memory            create
  // - exclusive         create/open
  // - read/write        create/open
  // - readonly                 open
  //
  // - memory            -*-share: N/A          -*-locks: disabled    -*-indexes: read/write
  // - exclusive_create  -*-share: deny write   -*-locks: disabled    -*-indexes: read/write
  // - exclusive_open    -*-share: deny write   -*-locks: disabled    -*-indexes: read/write
  // - readwrite_create  -*-share: deny none    -*-locks: enabled     -*-indexes: read/write
  // - readwrite_open    -*-share: deny none    -*-locks: enabled     -*-indexes: read/write
  // - readonly          -*-share: deny none    -*-locks: disabled    -*-indexes: readonly

  TPagedFile = class(TObject)
  protected
    FStream: TStream;
    FHeaderOffset: Integer;
    FHeaderSize: Integer;
    FRecordSize: Integer;
    FPageSize: Integer;         { need for MDX, where recordsize <> pagesize }
    FRecordCount: Integer;      { actually FPageCount, but we want to keep existing code }
    FPagesPerRecord: Integer;
    FCachedSize: Integer;
    FCachedRecordCount: Integer;
    FHeader: PAnsiChar;
    FActive: Boolean;
    FNeedRecalc: Boolean;
    FHeaderModified: Boolean;
    FPageOffsetByHeader: Boolean;   { do pages start after header or just at BOF? }
    FMode: TPagedFileMode;
    FTempMode: TPagedFileMode;
    FUserMode: TPagedFileMode;
    FAutoCreate: Boolean;
    FNeedLocks: Boolean;
    FVirtualLocks: Boolean;
    FFileLocked: Boolean;
    FFileName: string;
    FBufferPtr: Pointer;
    FBufferAhead: Boolean;
    FBufferPage: Integer;
    FBufferOffset: Integer;
    FBufferSize: Integer;
    FBufferReadSize: Integer;
    FBufferMaxSize: Integer;
    FBufferModified: Boolean;
    FWriteError: Boolean;
    FUseAutoInc: Boolean;
  protected
    procedure SetHeaderOffset(NewValue: Integer); virtual;
    procedure SetRecordSize(NewValue: Integer); virtual;
    procedure SetHeaderSize(NewValue: Integer); virtual;
    procedure SetPageSize(NewValue: Integer);
    procedure SetPageOffsetByHeader(NewValue: Boolean); virtual;
    procedure SetRecordCount(NewValue: Integer);
    procedure SetBufferAhead(NewValue: Boolean);
    procedure SetFileName(const NewName: string);
    procedure SetStream(NewStream: TStream);
    function  LockSection(const Offset, Length: Cardinal; const Wait: Boolean): Boolean; virtual;
    function  UnlockSection(const Offset, Length: Cardinal): Boolean; virtual;
    procedure UpdateBufferSize;
    procedure RecalcPagesPerRecord;
    procedure ReadHeader;
    // Write header to stream
    procedure FlushHeader;
    procedure FlushBuffer;
    function  ReadChar: Byte;
    procedure WriteChar(c: Byte);
    // Check if position in cache. If not, enlarge cache.
    procedure CheckCachedSize(const APosition: Integer);
    procedure SynchronizeBuffer(IntRecNum: Integer);
    function  Read(Buffer: Pointer; ASize: Integer): Integer;
    function  ReadBlock(const BlockPtr: Pointer; const ASize, APosition: Integer): Integer;
    function  SingleReadRecord(IntRecNum: Integer; Buffer: Pointer): Integer;
    procedure WriteBlock(const BlockPtr: Pointer; const ASize, APosition: Integer);
    procedure SingleWriteRecord(IntRecNum: Integer; Buffer: Pointer);
    function  GetRecordCount: Integer;
    procedure UpdateCachedSize(CurrPos: Integer);

    property VirtualLocks: Boolean read FVirtualLocks write FVirtualLocks;
  public
    constructor Create;
    destructor Destroy; override;

    procedure CloseFile; virtual;
    procedure OpenFile; virtual;
    procedure DeleteFile;
    procedure TryExclusive; virtual;
    procedure EndExclusive; virtual;
    procedure CheckExclusiveAccess;
    procedure DisableForceCreate;
    function  CalcPageOffset(const PageNo: Integer): Integer;
    function  IsRecordPresent(IntRecNum: Integer): boolean;
    function  ReadRecord(IntRecNum: Integer; Buffer: Pointer): Integer; virtual;
    procedure WriteRecord(IntRecNum: Integer; Buffer: Pointer); virtual;
    procedure WriteHeader; virtual;
    function  FileCreated: Boolean;
    function  IsSharedAccess: Boolean;
    procedure ResetError;

    function  LockPage(const PageNo: Integer; const Wait: Boolean): Boolean;
    function  LockAllPages(const Wait: Boolean): Boolean;
    procedure UnlockPage(const PageNo: Integer);
    procedure UnlockAllPages;

    procedure Flush; virtual;

    property Active: Boolean read FActive;
    // If yes, create file if it doesn't exist.
    // Only write this property when closed!
    property AutoCreate: Boolean read FAutoCreate write FAutoCreate;
    // only write this property when closed!
    property Mode: TPagedFileMode read FMode write FMode;
    property TempMode: TPagedFileMode read FTempMode;
    property NeedLocks: Boolean read FNeedLocks;
    property HeaderOffset: Integer read FHeaderOffset write SetHeaderOffset;
    property HeaderSize: Integer read FHeaderSize write SetHeaderSize;
    property RecordSize: Integer read FRecordSize write SetRecordSize;
    property PageSize: Integer read FPageSize write SetPageSize;
    property PagesPerRecord: Integer read FPagesPerRecord;
    property RecordCount: Integer read GetRecordCount write SetRecordCount;
    property CachedRecordCount: Integer read FCachedRecordCount;
    property PageOffsetByHeader: Boolean read FPageOffsetbyHeader write SetPageOffsetByHeader;
    property FileLocked: Boolean read FFileLocked;
    property Header: PAnsiChar read FHeader;
    property FileName: string read FFileName write SetFileName;
    property Stream: TStream read FStream write SetStream;
    property BufferAhead: Boolean read FBufferAhead write SetBufferAhead;
    property WriteError: Boolean read FWriteError;
    property UseAutoInc: Boolean read FUseAutoInc write FUseAutoInc;
  end;

implementation

{$IFDEF FPC_DOTTEDUNITS}
uses
{$ifdef WINDOWS}
  WinApi.Windows,
{$else}
{$ifdef KYLIX}
  Libc, 
{$endif}  
  System.Types, Data.Dbf.Wtil,
{$endif}
  Data.Dbf.Str;
{$ELSE FPC_DOTTEDUNITS}
uses
{$ifdef WINDOWS}
  Windows,
{$else}
{$ifdef KYLIX}
  Libc, 
{$endif}  
  Types, dbf_wtil,
{$endif}
  dbf_str;
{$ENDIF FPC_DOTTEDUNITS}

//====================================================================
// TPagedFile
//====================================================================
constructor TPagedFile.Create;
begin
  FFileName := EmptyStr;
  FHeaderOffset := 0;
  FHeaderSize := 0;
  FRecordSize := 0;
  FRecordCount := 0;
  FPageSize := 0;
  FPagesPerRecord := 0;
  FActive := false;
  FHeaderModified := false;
  FPageOffsetByHeader := true;
  FNeedLocks := false;
  FMode := pfReadOnly;
  FTempMode := pfNone;
  FAutoCreate := false;
  FVirtualLocks := true;
  FFileLocked := false;
  FHeader := nil;
  FBufferPtr := nil;
  FBufferAhead := false;
  FBufferModified := false;
  FBufferSize := 0;
  FBufferMaxSize := 0;
  FBufferOffset := 0;
  FWriteError := false;

  inherited;
end;

destructor TPagedFile.Destroy;
begin
  // close physical file
  if FFileLocked then UnlockAllPages;
  CloseFile;
  FFileLocked := false;

  // free mem
  if FHeader <> nil then
    FreeMem(FHeader);

  inherited;
end;

procedure TPagedFile.OpenFile;
var
  fileOpenMode: Word;
begin
  if FActive then exit;  

  // store user specified mode
  FUserMode := FMode;
  if not (FMode in [pfMemoryCreate, pfMemoryOpen]) then
  begin
    // test if file exists
    if not FileExists(FFileName) then
    begin
      // if auto-creating, adjust mode
      if FAutoCreate then case FMode of
        pfExclusiveOpen:             FMode := pfExclusiveCreate;
        pfReadWriteOpen, pfReadOnly: FMode := pfReadWriteCreate;
      end;
      // it seems the VCL cannot share a file that is created?
      // create file first, then open it in requested mode
      // filecreated means 'to be created' in this context ;-)
      if FileCreated then
        FileClose(FileCreate(FFileName))
      else
        raise EPagedFile.CreateFmt(STRING_FILE_NOT_FOUND,[FFileName]);
    end;
    // specify open mode
    case FMode of
      pfExclusiveCreate: fileOpenMode := fmOpenReadWrite or fmShareDenyWrite;
      pfExclusiveOpen:   fileOpenMode := fmOpenReadWrite or fmShareDenyWrite;
      pfReadWriteCreate: fileOpenMode := fmOpenReadWrite or fmShareDenyNone;
      pfReadWriteOpen:   fileOpenMode := fmOpenReadWrite or fmShareDenyNone;
    else    // => readonly
                         fileOpenMode := fmOpenRead or fmShareDenyNone;
    end;
    // open file
    FStream := TFileStream.Create(FFileName, fileOpenMode);
    // if creating, then empty file
    if FileCreated then
      FStream.Size := 0;
  end else begin
    if FStream = nil then
    begin
      FMode := pfMemoryCreate;
      FStream := TMemoryStream.Create;
    end;
  end;
  // init size var
  FCachedSize := Stream.Size;
  // update whether we need locking
{$ifdef _DEBUG}
  FNeedLocks := true;
{$else}
  FNeedLocks := IsSharedAccess;
{$endif}
  FActive := true;
  // allocate memory for bufferahead
  UpdateBufferSize;
end;

procedure TPagedFile.CloseFile;
begin
  if FActive then
  begin
    FlushHeader;
    FlushBuffer;
    // don't free the user's stream
    if not (FMode in [pfMemoryOpen, pfMemoryCreate]) then
      FreeAndNil(FStream);
    // free bufferahead buffer
    FreeMemAndNil(FBufferPtr);

    // mode possibly overridden in case of auto-created file
    FMode := FUserMode;
    FActive := false;
    FCachedRecordCount := 0;
  end;
end;

procedure TPagedFile.DeleteFile;
begin
  // opened -> we can not delete
  if not FActive then
    {$IFDEF FPC_DOTTEDUNITS}System.{$ENDIF}SysUtils.DeleteFile(FileName);
end;

function TPagedFile.FileCreated: Boolean;
const
  CreationModes: array [pfNone..pfReadOnly] of Boolean =
    (false, true, false, true, false, true, false, false);
//   node, memcr, memop, excr, exopn, rwcr, rwopn, rdonly
begin
  Result := CreationModes[FMode];
end;

function TPagedFile.IsSharedAccess: Boolean;
const
  SharedAccessModes: array [pfNone..pfReadOnly] of Boolean =
    (false, false, false, false, false, true, true,  true);
//   node,  memcr, memop, excr,  exopn, rwcr, rwopn, rdonly
begin
  Result := SharedAccessModes[FMode];
end;

procedure TPagedFile.CheckExclusiveAccess;
begin
  // in-memory => exclusive access!
  if IsSharedAccess then
    raise EDbfError.Create(STRING_NEED_EXCLUSIVE_ACCESS);
end;

function TPagedFile.CalcPageOffset(const PageNo: Integer): Integer;
begin
  //todo: verify: this looks suspicious: check if we should uniformly use
  // either FPageSize*PageNo as in the case without header offset
  // or (FPageSize*(PageNo-1))
  if not FPageOffsetByHeader then
    Result := FPageSize * PageNo
  else if PageNo = 0 then
    Result := 0
  else
    Result := FHeaderOffset + FHeaderSize + (FPageSize * (PageNo - 1))
end;

procedure TPagedFile.CheckCachedSize(const APosition: Integer);
begin
  // file expanded?
  if APosition > FCachedSize then
  begin
    FCachedSize := APosition;
    FNeedRecalc := true;
  end;
end;

function TPagedFile.Read(Buffer: Pointer; ASize: Integer): Integer;
begin
  // if we cannot read due to a lock, then wait a bit
  repeat
    Result := FStream.Read(Buffer^, ASize);
    if Result = 0 then
    begin
      // translation to linux???
      if GetLastError = ERROR_LOCK_VIOLATION then
      begin
        // wait a bit until block becomes available
        Sleep(1);
      end else begin
        // return empty block
        exit;
      end;
    end else
      exit;
  until false;
end;

procedure TPagedFile.UpdateCachedSize(CurrPos: Integer);
begin
  // have we added a record?
  if CurrPos > FCachedSize then
  begin
    // update cached size, always at end
    repeat
      Inc(FCachedSize, FRecordSize);
      Inc(FRecordCount, PagesPerRecord);
    until FCachedSize >= CurrPos;
  end;
end;

procedure TPagedFile.FlushBuffer;
begin
  if FBufferAhead and FBufferModified then
  begin
    WriteBlock(FBufferPtr, FBufferSize, FBufferOffset);
    FBufferModified := false;
  end;
end;

function TPagedFile.SingleReadRecord(IntRecNum: Integer; Buffer: Pointer): Integer;
begin
  Result := ReadBlock(Buffer, RecordSize, CalcPageOffset(IntRecNum));
end;

procedure TPagedFile.SingleWriteRecord(IntRecNum: Integer; Buffer: Pointer);
begin
  WriteBlock(Buffer, RecordSize, CalcPageOffset(IntRecNum));
end;

procedure TPagedFile.SynchronizeBuffer(IntRecNum: Integer);
begin
  // record outside buffer, flush previous buffer
  FlushBuffer;
  // read new set of records
  FBufferPage := IntRecNum;
  FBufferOffset := CalcPageOffset(IntRecNum);
  if FBufferOffset + FBufferMaxSize > FCachedSize then
    FBufferReadSize := FCachedSize - FBufferOffset
  else
    FBufferReadSize := FBufferMaxSize;
  FBufferSize := FBufferReadSize;
  FBufferReadSize := ReadBlock(FBufferPtr, FBufferReadSize, FBufferOffset);
end;

function TPagedFile.IsRecordPresent(IntRecNum: Integer): boolean;
begin
  // if in shared mode, recordcount can only increase, check if recordno
  // in range for cached recordcount
  if not IsSharedAccess or (IntRecNum > FCachedRecordCount) then
    FCachedRecordCount := RecordCount;
  Result := (0 <= IntRecNum) and (IntRecNum <= FCachedRecordCount);
end;

function TPagedFile.ReadRecord(IntRecNum: Integer; Buffer: Pointer): Integer;
var
  Offset: Integer;
begin
  if FBufferAhead then
  begin
    Offset := (IntRecNum - FBufferPage) * PageSize;
    if (FBufferPage <> -1) and (FBufferPage <= IntRecNum) and
        (Offset+RecordSize <= FBufferReadSize) then
    begin
      // have record in buffer, nothing to do here
    end else begin
      // need to update buffer
      SynchronizeBuffer(IntRecNum);
      // check if enough bytes read
      if RecordSize > FBufferReadSize then
      begin
        Result := 0;
        exit;
      end;
      // reset offset into buffer
      Offset := 0;
    end;
    // now we have this record in buffer
    Move(PAnsiChar(FBufferPtr)[Offset], Buffer^, RecordSize);
    // successful
    Result := RecordSize;
  end else begin
    // no buffering
    Result := SingleReadRecord(IntRecNum, Buffer);
  end;
end;

procedure TPagedFile.WriteRecord(IntRecNum: Integer; Buffer: Pointer);
var
  RecEnd: Integer;
begin
  if FBufferAhead then
  begin
    RecEnd := (IntRecNum - FBufferPage + PagesPerRecord) * PageSize;
    if (FBufferPage <> -1) and (FBufferPage <= IntRecNum) and
        (RecEnd <= FBufferMaxSize) then
    begin
      // extend buffer?
      if RecEnd > FBufferSize then
        FBufferSize := RecEnd;
    end else begin
      // record outside buffer, need to synchronize first
      SynchronizeBuffer(IntRecNum);
      RecEnd := PagesPerRecord * PageSize;
    end;
    // we can write this record to buffer
    Move(Buffer^, PAnsiChar(FBufferPtr)[RecEnd-RecordSize], RecordSize);
    FBufferModified := true;
    // update cached size
    UpdateCachedSize(FBufferOffset+RecEnd);
  end else begin
    // no buffering
    SingleWriteRecord(IntRecNum, Buffer);
    // update cached size
    UpdateCachedSize(FStream.Position);
  end;
end;

procedure TPagedFile.SetBufferAhead(NewValue: Boolean);
begin
  if FBufferAhead <> NewValue then
  begin
    FlushBuffer;
    FBufferAhead := NewValue;
    UpdateBufferSize;
  end;
end;

procedure TPagedFile.SetStream(NewStream: TStream);
begin
  if not FActive then
    FStream := NewStream;
end;

procedure TPagedFile.SetFileName(const NewName: string);
begin
  if not FActive then
    FFileName := NewName;
end;

procedure TPagedFile.UpdateBufferSize;
begin
  if FBufferAhead then
  begin
    FBufferMaxSize := 65536;
    if RecordSize <> 0 then
      Dec(FBufferMaxSize, FBufferMaxSize mod PageSize);
  end else begin
    FBufferMaxSize := 0;
  end;

  if FBufferPtr <> nil then
    FreeMem(FBufferPtr);
  if FBufferAhead and (FBufferMaxSize <> 0) then
    GetMem(FBufferPtr, FBufferMaxSize)
  else
    FBufferPtr := nil;
  FBufferPage := -1;
  FBufferOffset := -1;
  FBufferModified := false;
end;

procedure TPagedFile.WriteHeader;
begin
  FHeaderModified := true;
  if FNeedLocks then
    FlushHeader;
end;

procedure TPagedFile.FlushHeader;
begin
  if FHeaderModified then
  begin
    FStream.Position := FHeaderOffset;
    FWriteError := (FStream.Write(FHeader^, FHeaderSize) = 0) or FWriteError;
    // test if written new header
    if FStream.Position > FCachedSize then
    begin
      // new header -> record count unknown
      FCachedSize := FStream.Position;
      FNeedRecalc := true;
    end;
    FHeaderModified := false;
  end;
end;

procedure TPagedFile.ReadHeader;
   { assumes header is large enough }
var
  size: Integer;
begin
  // save changes before reading new header
  FlushHeader;
  // check if header length zero
  if FHeaderSize <> 0 then
  begin
    // get size left in file for header
    size := FStream.Size - FHeaderOffset;
    // does header start before EOF?
    if size >= 0 then
    begin
      // go to header start
      FStream.Position := FHeaderOffset;
      // whole header in file?
      if size >= FHeaderSize then
      begin
        // read header, nothing to be cleared
        Read(FHeader, FHeaderSize);
        size := FHeaderSize;
      end else begin
        // read what we can, clear rest
        Read(FHeader, size);
      end;
    end else begin
      // clear header
      size := 0;
    end;
    FillChar(FHeader[size], FHeaderSize-size, 0);
  end;
end;

procedure TPagedFile.TryExclusive;
const NewTempMode: array[pfReadWriteCreate..pfReadOnly] of TPagedFileMode =
    (pfReadWriteOpen, pfReadWriteOpen, pfReadOnly);
begin
  // already in temporary exclusive mode?
  if (FTempMode = pfNone) and IsSharedAccess then
  begin
    // save temporary mode, if now creating, then reopen non-create
    FTempMode := NewTempMode[FMode];
    // try exclusive mode
    CloseFile;
    FMode := pfExclusiveOpen;
    try
      OpenFile;
    except
      on EFOpenError do
      begin
        // we failed, reopen normally
        EndExclusive;
      end;
    end;
  end;
end;

procedure TPagedFile.EndExclusive;
begin
  // are we in temporary file mode?
  if FTempMode <> pfNone then
  begin
    CloseFile;
    FMode := FTempMode;
    FTempMode := pfNone;
    OpenFile;
  end;
end;

procedure TPagedFile.DisableForceCreate;
begin
  case FMode of
    pfExclusiveCreate: FMode := pfExclusiveOpen;
    pfReadWriteCreate: FMode := pfReadWriteOpen;
  end;
end;

procedure TPagedFile.SetHeaderOffset(NewValue: Integer);
//
// *) assumes is called right before SetHeaderSize
//
begin
  if FHeaderOffset <> NewValue then
  begin
    FlushHeader;
    FHeaderOffset := NewValue;
  end;
end;

procedure TPagedFile.SetHeaderSize(NewValue: Integer);
begin
  if FHeaderSize <> NewValue then
  begin
    FlushHeader;
    if (FHeader <> nil) and (NewValue <> 0) then
      FreeMem(FHeader);
    FHeaderSize := NewValue;
    if FHeaderSize <> 0 then
      GetMem(FHeader, FHeaderSize);
    FNeedRecalc := true;
    ReadHeader;
  end;
end;

procedure TPagedFile.SetRecordSize(NewValue: Integer);
begin
  if FRecordSize <> NewValue then
  begin
    FRecordSize := NewValue;
    FPageSize := NewValue;
    FNeedRecalc := true;
    RecalcPagesPerRecord;
  end;
end;

procedure TPagedFile.SetPageSize(NewValue: Integer);
begin
  if FPageSize <> NewValue then
  begin
    FPageSize := NewValue;
    FNeedRecalc := true;
    RecalcPagesPerRecord;
    UpdateBufferSize;
  end;
end;

procedure TPagedFile.RecalcPagesPerRecord;
begin
  if FPageSize = 0 then
    FPagesPerRecord := 0
  else
    FPagesPerRecord := FRecordSize div FPageSize;
end;

function TPagedFile.GetRecordCount: Integer;
var
  currSize: Integer;
begin
  // file size changed?
  if FNeedLocks then
  begin
    currSize := FStream.Size;
    if currSize <> FCachedSize then
    begin
      FCachedSize := currSize;
      FNeedRecalc := true;
    end;
  end;

  // try to optimize speed
  if FNeedRecalc then
  begin
    // no file? test flags
    if (FPageSize = 0) or not FActive then
      FRecordCount := 0
    else
    if FPageOffsetByHeader then
      FRecordCount := (FCachedSize - FHeaderSize - FHeaderOffset) div FPageSize
    else
      FRecordCount := FCachedSize div FPageSize;
    if FRecordCount < 0 then
      FRecordCount := 0;

    // count updated
    FNeedRecalc := false;
  end;
  Result := FRecordCount;
end;

procedure TPagedFile.SetRecordCount(NewValue: Integer);
begin
  if RecordCount <> NewValue then
  begin
    if FPageOffsetByHeader then
      FCachedSize := FHeaderSize + FHeaderOffset + FPageSize * NewValue
    else
      FCachedSize := FPageSize * NewValue;
//    FCachedSize := CalcPageOffset(NewValue);
    FRecordCount := NewValue;
    FStream.Size := FCachedSize;
  end;
end;

procedure TPagedFile.SetPageOffsetByHeader(NewValue: Boolean);
begin
  if FPageOffsetByHeader <> NewValue then
  begin
    FPageOffsetByHeader := NewValue;
    FNeedRecalc := true;
  end;
end;

procedure TPagedFile.WriteChar(c: Byte);
begin
  FWriteError := (FStream.Write(c, 1) = 0) or FWriteError;
end;

function TPagedFile.ReadChar: Byte;
begin
  Read(@Result, 1);
end;

procedure TPagedFile.Flush;
begin
end;

function TPagedFile.ReadBlock(const BlockPtr: Pointer; const ASize, APosition: Integer): Integer;
begin
  FStream.Position := APosition;
  CheckCachedSize(APosition);
  Result := Read(BlockPtr, ASize);
end;

procedure TPagedFile.WriteBlock(const BlockPtr: Pointer; const ASize, APosition: Integer);
  // assumes a lock is held if necessary prior to calling this function
begin
  FStream.Position := APosition;
  CheckCachedSize(APosition);
  FWriteError := (FStream.Write(BlockPtr^, ASize) = 0) or FWriteError;
end;

procedure TPagedFile.ResetError;
begin
  FWriteError := false;
end;

// BDE compatible lock offset found!
const
{$ifdef WINDOWS}
  LockOffset = $EFFFFFFE;       // BDE compatible
  FileLockSize = 2;
{$else}
  LockOffset = $7FFFFFFF;
  FileLockSize = 1;
{$endif}

// dBase supports maximum of a billion records
  LockStart  = LockOffset - 1000000000;

function TPagedFile.LockSection(const Offset, Length: Cardinal; const Wait: Boolean): Boolean;
{$ifndef wince}
  // assumes FNeedLock = true
var
  Failed: Boolean;
{$endif wince}
begin
{$ifdef wince}
  Result := True;
{$else}
  // FNeedLocks => FStream is of type TFileStream
  Failed := false;
  repeat
    Result := LockFile(TFileStream(FStream).Handle, Offset, 0, Length, 0);
    // test if lock violation, then wait a bit and try again
    if not Result and Wait then
    begin
      if (GetLastError = ERROR_LOCK_VIOLATION) then
        Sleep(10)
      else
        Failed := true;
    end;
  until Result or not Wait or Failed;
{$endif wince}
end;

function TPagedFile.UnlockSection(const Offset, Length: Cardinal): Boolean;
begin
{$ifdef wince}
  Result := True;
{$else}
  Result := UnlockFile(TFileStream(FStream).Handle, Offset, 0, Length, 0);
{$endif wince}
end;

function TPagedFile.LockAllPages(const Wait: Boolean): Boolean;
var
  Offset: Cardinal;
  Length: Cardinal;
begin
  // do we need locking?
  if FNeedLocks and not FFileLocked then
  begin
    if FVirtualLocks then
    begin
{$ifdef SUPPORT_UINT32_CARDINAL}
      Offset := LockStart;
      Length := LockOffset - LockStart + FileLockSize;
{$else}
      // delphi 3 has strange types:
      // cardinal 0..2 GIG ?? does it produce correct code?
      Offset := Cardinal(LockStart);
      Length := Cardinal(LockOffset) - Cardinal(LockStart) + FileLockSize;
{$endif}
    end else begin
      Offset := 0;
      Length := $7FFFFFFF;
    end;
    // lock requested section
    Result := LockSection(Offset, Length, Wait);
    FFileLocked := Result;
  end else
    Result := true;
end;

procedure TPagedFile.UnlockAllPages;
var
  Offset: Cardinal;
  Length: Cardinal;
begin
  // do we need locking?
  if FNeedLocks and FFileLocked then
  begin
    if FVirtualLocks then
    begin
{$ifdef SUPPORT_UINT32_CARDINAL}
      Offset := LockStart;
      Length := LockOffset - LockStart + FileLockSize;
{$else}
      // delphi 3 has strange types:
      // cardinal 0..2 GIG ?? does it produce correct code?
      Offset := Cardinal(LockStart);
      Length := Cardinal(LockOffset) - Cardinal(LockStart) + FileLockSize;
{$endif}
    end else begin
      Offset := 0;
      Length := $7FFFFFFF;
    end;
    // unlock requested section
    // FNeedLocks => FStream is of type TFileStream
    FFileLocked := not UnlockSection(Offset, Length);
  end;
end;

function TPagedFile.LockPage(const PageNo: Integer; const Wait: Boolean): Boolean;
var
  Offset: Cardinal;
  Length: Cardinal;
begin
  // do we need locking?
  if FNeedLocks and not FFileLocked then
  begin
    if FVirtualLocks then
    begin
      Offset := LockOffset - Cardinal(PageNo);
      Length := 1;
    end else begin
      Offset := CalcPageOffset(PageNo);
      Length := RecordSize;
    end;
    // lock requested section
    Result := LockSection(Offset, Length, Wait);
  end else
    Result := true;
end;

procedure TPagedFile.UnlockPage(const PageNo: Integer);
var
  Offset: Cardinal;
  Length: Cardinal;
begin
  // do we need locking?
  if FNeedLocks and not FFileLocked then
  begin
    // calc offset + length
    if FVirtualLocks then
    begin
      Offset := LockOffset - Cardinal(PageNo);
      Length := 1;
    end else begin
      Offset := CalcPageOffset(PageNo);
      Length := RecordSize;
    end;
    // unlock requested section
    // FNeedLocks => FStream is of type TFileStream
    UnlockSection(Offset, Length);
  end;
end;

end.

