unit dbf_memo;

interface

{$I dbf_common.inc}

uses
  Classes,
  dbf_pgfile,
  dbf_common;

type

//====================================================================

  { TMemoFile }

  TMemoFile = class(TPagedFile)
  private
    procedure SetDBFVersion(AValue: TXBaseVersion);
  protected
    FDbfFile: pointer;
    FDbfVersion: TXBaseVersion;
    FEmptySpaceFiller: Char; //filler for unused header and memo data
    FMemoRecordSize: Integer;
    FOpened: Boolean;
    FBuffer: PChar;
  protected
    function  GetBlockLen: Integer; virtual; abstract;
    function  GetMemoSize: Integer; virtual; abstract;
    function  GetNextFreeBlock: Integer; virtual; abstract;
    procedure SetNextFreeBlock(BlockNo: Integer); virtual; abstract;
    procedure SetBlockLen(BlockLen: Integer); virtual; abstract;
  public
    constructor Create(ADbfFile: pointer);
    destructor Destroy; override;

    procedure Open;
    procedure Close;

    procedure ReadMemo(BlockNo: Integer; DestStream: TStream);
    procedure WriteMemo(var BlockNo: Integer; ReadSize: Integer; Src: TStream);

    property DbfVersion: TXBaseVersion read FDbfVersion write SetDBFVersion;
    property MemoRecordSize: Integer read FMemoRecordSize write FMemoRecordSize;
  end;

  { TFoxProMemoFile }
  // (Visual) Foxpro memo file support
  TFoxProMemoFile = class(TMemoFile)
  protected
    function  GetBlockLen: Integer; override;
    function  GetMemoSize: Integer; override;
    function  GetNextFreeBlock: Integer; override;
    procedure SetNextFreeBlock(BlockNo: Integer); override;
    procedure SetBlockLen(BlockLen: Integer); override;
  end;

  // DBaseIII+ memo file support:
  TDbaseMemoFile = class(TMemoFile)
  protected
    function  GetBlockLen: Integer; override;
    function  GetMemoSize: Integer; override;
    function  GetNextFreeBlock: Integer; override;
    procedure SetNextFreeBlock(BlockNo: Integer); override;
    procedure SetBlockLen(BlockLen: Integer); override;
  end;

  { TNullMemoFile, a kind of /dev/null memofile ;-) }
  { - inv: FHeaderModified == false!! (otherwise will try to write FStream) }
  { - inv: FHeaderSize == 0 }
  { - inv: FNeedLocks == false }
  { - WriteTo must NOT be used }
  { - WriteChar must NOT be used }

  TNullMemoFile = class(TMemoFile)
  protected
    procedure SetHeaderOffset(NewValue: Integer); override;
    procedure SetRecordSize(NewValue: Integer); override;
    procedure SetHeaderSize(NewValue: Integer); override;

    function  LockSection(const Offset, Length: Cardinal; const Wait: Boolean): Boolean; override;
    function  UnlockSection(const Offset, Length: Cardinal): Boolean; override;

    function  GetBlockLen: Integer; override;
    function  GetMemoSize: Integer; override;
    function  GetNextFreeBlock: Integer; override;
    procedure SetNextFreeBlock(BlockNo: Integer); override;
    procedure SetBlockLen(BlockLen: Integer); override;

  public
    constructor Create(ADbfFile: pointer);

    procedure CloseFile; override;
    procedure OpenFile; override;

    function  ReadRecord(IntRecNum: Integer; Buffer: Pointer): Integer; override;
    procedure WriteRecord(IntRecNum: Integer; Buffer: Pointer); override;
  end;

  PInteger = ^Integer;
  TMemoFileClass = class of TMemoFile;

implementation

uses
  SysUtils, dbf_dbffile;

//====================================================================
//=== Memo and binary fields support
//====================================================================
type
  // DBase III+ dbt memo file
  // (Visual) FoxPro note: integers are in Big Endian: high byte first
  // http://msdn.microsoft.com/en-us/library/aa975374%28VS.71%29.aspx
  PDbtHdr = ^rDbtHdr;
  rDbtHdr = record
    NextBlock : dword;                  // 0..3
    // Dummy in DBaseIII; size of blocks in memo file; default 512 bytes
    // (Visual) FoxPro: 4..5 unused; use only bytes 6..7
    BlockSize : dword;                  // 4..7
    // DBF file name without extension
    DbfFile   : array [0..7] of Byte;   // 8..15
    // DBase III only: version number $03
    bVer      : Byte;                   // 16
    Dummy2    : array [17..19] of Byte; // 17..19
    // Block length in bytes; DBaseIII: always $01
    BlockLen  : Word;                   // 20..21
    Dummy3    : array [22..511] of Byte;// 22..511 First block; garbage contents
  end;

  PFptHdr = ^rFptHdr;
  rFptHdr = record
    NextBlock : dword;
    Dummy     : array [4..5] of Byte;
    BlockLen  : Word;                   // 20..21
    Dummy3    : array [8..511] of Byte;
  end;

  // Header of a memo data block:
  // (Visual) FoxPro note: integers are in Big Endian: high byte first
  PBlockHdr = ^rBlockHdr;
  rBlockHdr = record
    // DBase IV(+) identifier: $FF $FF $08 $00
    // (Visual) FoxPro: $00 picture, $01 text/memo, $02 object
    MemoType  : Cardinal; // 0..3
    // Length of memo field
    MemoSize  : Cardinal; // 4..7
    // memo data             8..N
  end;


procedure TMemoFile.SetDBFVersion(AValue: TXBaseVersion);
begin
  if FDbfVersion=AValue then Exit;
  FDbfVersion:=AValue;
  if AValue in [xFoxPro, xVisualFoxPro] then
    // Visual Foxpro writes 0s itself, so mimic it
    FEmptySpaceFiller:=#0
  else
    FEmptySpaceFiller:=' ';
end;

//==========================================================
//============ Dbtfile
//==========================================================
constructor TMemoFile.Create(ADbfFile: pointer);
begin
  // init vars
  FBuffer := nil;
  FOpened := false;

  FEmptySpaceFiller:=' '; //default

  // call inherited
  inherited Create;

  FDbfFile := ADbfFile;
  FTempMode := TDbfFile(ADbfFile).TempMode;
end;

destructor TMemoFile.Destroy;
begin
  // close file
  Close;

  // call ancestor
  inherited;
end;

procedure TMemoFile.Open;
begin
  if not FOpened then
  begin
    // memo pages count start from begining of file!
    PageOffsetByHeader := false;

    // open physical file
    OpenFile;

    // read header
    HeaderSize := 512;

    // determine version
    if FDbfVersion = xBaseIII then
      PDbtHdr(Header)^.bVer := 3;
    VirtualLocks := false;

    if FileCreated or (HeaderSize = 0) then
    begin
      if (FMemoRecordSize = 0) or (FMemoRecordSize > HeaderSize) then
        SetNextFreeBlock(1)
      else
        SetNextFreeBlock(HeaderSize div FMemoRecordSize);
      SetBlockLen(FMemoRecordSize);
      WriteHeader;
    end;

    RecordSize := GetBlockLen;
    // checking for right blocksize not needed for foxpro?
    // todo: why exactly are we testing for 0x7F?
    // mod 128 <> 0 <-> and 0x7F <> 0
    if (RecordSize = 0) and
      ((FDbfVersion in [xFoxPro,xVisualFoxPro]) or ((RecordSize and $7F) <> 0)) then
    begin
      SetBlockLen(64); //(Visual) FoxPro docs suggest 512 is default; however it is 64: see
      //http://technet.microsoft.com/en-us/subscriptions/d6e1ah7y%28v=vs.90%29.aspx
      RecordSize := 64;
      WriteHeader;
    end
    else if (RecordSize = 0) then
    begin
      SetBlockLen(512); //dbase default
      RecordSize := 512;
      WriteHeader;
    end;

    // get memory for temporary buffer
    GetMem(FBuffer, RecordSize+2);
    FBuffer[RecordSize] := #0;
    FBuffer[RecordSize+1] := #0;

    // now open
    FOpened := true;
  end;
end;

procedure TMemoFile.Close;
begin
  if FOpened then
  begin
    // close physical file
    CloseFile;

    // free mem
    if FBuffer <> nil then
      FreeMemAndNil(Pointer(FBuffer));

    // now closed
    FOpened := false;
  end;
end;

procedure TMemoFile.ReadMemo(BlockNo: Integer; DestStream: TStream);
var
  bytesLeft,numBytes,dataStart: Integer;
  done: Boolean;
  lastc: char;
  endMemo: PChar;
begin
  // clear dest
  DestStream.Position := 0;
  DestStream.Size := 0;
  // no block to read?
  if (BlockNo<=0) or (RecordSize=0) then
    exit;
  // read first block
  numBytes := ReadRecord(BlockNo, @FBuffer[0]);
  if numBytes = 0 then
  begin
    // EOF reached?
    exit;
  end else
  if numBytes < RecordSize then
    FillChar(FBuffer[numBytes], RecordSize-numBytes, #0);

  bytesLeft := GetMemoSize;
  // bytesLeft <> -1 -> memo size is known (FoxPro, dBase4)
  // bytesLeft =  -1 -> memo size unknown (dBase3)
  if bytesLeft <> -1 then
  begin
    dataStart := 8;
    DestStream.Size := bytesLeft;
    while bytesLeft > 0 do
    begin
      // get number of bytes to be read
      numBytes := bytesLeft;
      // too much for this block?
      if numBytes > RecordSize - dataStart then
        numBytes := RecordSize - dataStart;
      // read block to stream
      DestStream.Write(FBuffer[dataStart], numBytes);
      // numBytes done
      dec(bytesLeft, numBytes);
      // still need to read bytes?
      if bytesLeft > 0 then
      begin
        // read next block
        inc(BlockNo);
        dataStart := 0;
        ReadRecord(BlockNo, @FBuffer[0]);
      end;
    end;
  end else begin
    // e.g. dbase III memo
    done := false;
    repeat
      // scan for EOF marker/field terminator
      endMemo := MemScan(FBuffer, $1A, RecordSize);
      // EOF found?
      if endMemo <> nil then
      begin
        // really EOF? expect another 1A or null character
        if (endMemo-FBuffer < RecordSize - 1) and
          ((endMemo[1] = #$1A) or (endMemo[1] = #0)) then
        begin
          done := true; //found the end
          numBytes := endMemo - FBuffer;
        end else begin
          // no, fake ending
          numBytes := RecordSize;
        end;
      end else begin
        numBytes := RecordSize;
      end;
      // write to stream
      DestStream.Write(FBuffer[0], numBytes);
{
      for i := 0 to RecordSize-2 do
      begin
        if (FBuffer[i]=#$1A) and (FBuffer[i+1]=#$1A) then
        begin
          if i>0 then
            DestStream.Write(FBuffer[0], i);
          done := true;
          break;
        end;
      end;
}
      if not done then
      begin
{
        DestStream.Write(FBuffer[0], 512);
}
        lastc := FBuffer[RecordSize-1];
        inc(BlockNo);
        if ReadRecord(BlockNo, @FBuffer[0]) > 0 then
        begin
          // check if immediate terminator at begin of block
          done := (lastc = #$1A) and ((FBuffer[0] = #$1A) or (FBuffer[0] = #0));
          // if so, written one character too much
          if done then
            DestStream.Size := DestStream.Size - 1;
        end else begin
          // error while reading, stop
          done := true;
        end;
      end;
    until done;
  end;
end;

procedure TMemoFile.WriteMemo(var BlockNo: Integer; ReadSize: Integer; Src: TStream);
var
  bytesBefore: Integer;
  bytesAfter: Integer;
  totsize: Integer;
  readBytes: Integer;
  append: Boolean;
  tmpRecNo: Integer;
begin
  // if no data to write, then don't create new block
  if Src.Size = 0 then
  begin
    BlockNo := 0;
  end else begin
    if FDbfVersion >= xBaseIV then      // dBase4 or FoxPro type
    begin
      bytesBefore := SizeOf(rBlockHdr);
      bytesAfter := 0;
    end else begin                      // dBase3 type, Clipper?
      bytesBefore := 0;
      bytesAfter := 2;
    end;
//    if ((bytesBefore + Src.Size + bytesAfter + PDbtHdr(Header).BlockLen-1) div PDbtHdr(Header).BlockLen)
//        <= ((ReadSize + PDbtHdr(Header).BlockLen-1) div PDbtHdr(Header).BlockLen) then
    // If null memo is used, recordsize may be 0. Test for that.
    if (RecordSize=0) or (((bytesBefore + Src.Size + bytesAfter + RecordSize-1) div RecordSize)
        <= ((ReadSize + RecordSize-1) div RecordSize)) then
    begin
      append := false;
    end else begin
      append := true;
      // modifying header -> lock memo header
      LockPage(0, true);
      BlockNo := GetNextFreeBlock;
      if BlockNo = 0 then
      begin
        SetNextFreeBlock(1);
        BlockNo := 1;
      end;
    end;
    tmpRecNo := BlockNo;
    Src.Position := 0;
    FillChar(FBuffer[0], RecordSize, FEmptySpaceFiller);

    if bytesBefore=8 then //Field header
    begin
      totsize := Src.Size + bytesBefore + bytesAfter;
      if not(FDbfVersion in [xFoxPro,xVisualFoxPro]) then
      begin
        PBlockHdr(FBuffer)^.MemoType := SwapIntLE($0008FFFF);
        PBlockHdr(FBuffer)^.MemoSize := SwapIntLE(totsize);
      end else begin
        PBlockHdr(FBuffer)^.MemoType := SwapIntLE($01000000);
        PBlockHdr(FBuffer)^.MemoSize := SwapIntBE(Src.Size);
      end;
    end;
    repeat
      // read bytes, don't overwrite header
      readBytes := Src.Read(FBuffer[bytesBefore], RecordSize{PDbtHdr(Header).BlockLen}-bytesBefore);
      // end of input data reached? check if we need to write block terminators
      while (readBytes < RecordSize - bytesBefore) and (bytesAfter > 0) do
      begin
        FBuffer[readBytes] := #$1A; //block terminator
        Inc(readBytes);
        Dec(bytesAfter);
      end;
      // have we read anything that needs to be written?
      if readBytes > 0 then
      begin
        // clear any unused space
        FillChar(FBuffer[bytesBefore+readBytes], RecordSize-readBytes-bytesBefore, FEmptySpaceFiller);

        // write to disk
        WriteRecord(tmpRecNo, @FBuffer[0]);
        Inc(tmpRecNo);
      end else break;
      // first block read, second block can start at beginning
      bytesBefore := 0;
    until false;

    if append then
    begin
      SetNextFreeBlock(tmpRecNo);
      WriteHeader;
      UnlockPage(0);
    end;
  end;
end;

// ------------------------------------------------------------------
// dBase specific helper routines
// ------------------------------------------------------------------

function  TDbaseMemoFile.GetBlockLen: Integer;
begin
  // Can you tell me why the header of dbase3 memo contains 1024 and is 512 ?
  // answer: BlockLen is not a valid field in memo db3 header
  if FDbfVersion = xBaseIII then
    Result := 512
  else
    Result := SwapWordLE(PDbtHdr(Header)^.BlockLen);
end;

function  TDbaseMemoFile.GetMemoSize: Integer;
begin
  // dBase4 memofiles contain a small 'header'
  if (FDbfVersion<>xBaseIII) and (PInteger(@FBuffer[0])^ = Integer(SwapIntLE($0008FFFF))) then
    // Subtract size of the block header itself:
    Result := SwapIntLE(PBlockHdr(FBuffer)^.MemoSize)-8
  else
    Result := -1;
end;

function  TDbaseMemoFile.GetNextFreeBlock: Integer;
begin
  Result := SwapIntLE(PDbtHdr(Header)^.NextBlock);
end;

procedure TDbaseMemoFile.SetNextFreeBlock(BlockNo: Integer);
begin
  PDbtHdr(Header)^.NextBlock := SwapIntLE(BlockNo);
end;

procedure TDbaseMemoFile.SetBlockLen(BlockLen: Integer);
begin
  // DBase III does not support block sizes<>512 bytes
  if (FDbfVersion<>xBaseIII) then
    PDbtHdr(Header)^.BlockLen := SwapWordLE(BlockLen);
end;

// ------------------------------------------------------------------
// FoxPro specific helper routines
// ------------------------------------------------------------------

function  TFoxProMemoFile.GetBlockLen: Integer;
begin
  Result := SwapWordBE(PFptHdr(Header)^.BlockLen);
end;

function  TFoxProMemoFile.GetMemoSize: Integer;
begin
  Result := SwapIntBE(PBlockHdr(FBuffer)^.MemoSize);
end;

function  TFoxProMemoFile.GetNextFreeBlock: Integer;
begin
  Result := SwapIntBE(PFptHdr(Header)^.NextBlock);
end;

procedure TFoxProMemoFile.SetNextFreeBlock(BlockNo: Integer);
begin
  PFptHdr(Header)^.NextBlock := SwapIntBE(dword(BlockNo));
end;

procedure TFoxProMemoFile.SetBlockLen(BlockLen: Integer);
begin
  PFptHdr(Header)^.BlockLen := SwapWordBE(dword(BlockLen));
end;

// ------------------------------------------------------------------
// NULL file (no file) specific helper routines
// ------------------------------------------------------------------

constructor TNullMemoFile.Create(ADbfFile: pointer);
begin
  inherited;
end;

procedure TNullMemoFile.OpenFile;
begin
end;

procedure TNullMemoFile.CloseFile;
begin
end;

procedure TNullMemoFile.SetHeaderOffset(NewValue: Integer);
begin
  inherited SetHeaderOffset(0);
end;

procedure TNullMemoFile.SetRecordSize(NewValue: Integer);
begin
  inherited SetRecordSize(0);
end;

procedure TNullMemoFile.SetHeaderSize(NewValue: Integer);
begin
  inherited SetHeaderSize(0);
end;

function  TNullMemoFile.LockSection(const Offset, Length: Cardinal; const Wait: Boolean): Boolean;
begin
  Result := true;
end;

function  TNullMemoFile.UnlockSection(const Offset, Length: Cardinal): Boolean;
begin
  Result := true;
end;

function  TNullMemoFile.GetBlockLen: Integer;
begin
  Result := 0;
end;

function  TNullMemoFile.GetMemoSize: Integer;
begin
  Result := 0;
end;

function  TNullMemoFile.GetNextFreeBlock: Integer;
begin
  Result := 0;
end;

procedure TNullMemoFile.SetNextFreeBlock(BlockNo: Integer);
begin
end;

procedure TNullMemoFile.SetBlockLen(BlockLen: Integer);
begin
end;

function  TNullMemoFile.ReadRecord(IntRecNum: Integer; Buffer: Pointer): Integer;
begin
  Result := 0;
end;

procedure TNullMemoFile.WriteRecord(IntRecNum: Integer; Buffer: Pointer);
begin
end;

end.