Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/kolekce/d456/DCSLIB25.ZIP/DCRecordStream.pas

Pascal/Delphi Source File | 2001-01-20 | 13KB | 504 lines

unit DCRecordStream;

interface
uses
  Classes, SysUtils, Windows;

const
  RECORD_ROOT_NAME  = 'RSROOT Version 1.0';
  RECORD_FLAG_EMPTY = $01;

type
  TRecordType = packed record
    Flags   : WORD;
    DataSize: WORD;           // ╨ατ∞σ≡ Σαφφ√⌡ Γ ßδεΩσ
    NextData: integer;        // ┼±δΦ ≡ατ∞σ≡ Σαφφ√⌡ ßεδⁿ°σ, ≈σ∞ ≡ατ∞σ≡ ßδεΩα
                              // ≤Ωατα≥σδⁿ φα ±δσΣ≤■∙ΦΘ ßδεΩ ± Σαφφ√∞Φ
    EmptyPtr: integer;        // ╙Ωατα≥σδⁿ φα ∩≤±≥εΘ ßδεΩ (0 Ωεφσ÷ ⌠αΘδα)
                              // ┬ ±δ≤≈ασ:
                              //  1. Ωε≡φσΓεΘ ßδεΩ(ROOT)  -
                              //       ±εΣσ≡µΦ≥ ≤Ωατα≥σδⁿ φα ∩σ≡Γ√Θ ∩≤±≥εΘ ßδεΩ;
                              //  2. ∩≤±≥εΘ ßδεΩ          -
                              //       ≤Ωατα≥σδⁿ φα ±δσΣ≤∙ΦΘ ∩≤±≥εΘ ßδεΩ
  end;

  TRecordStream = class(TFileStream)
  private
    FBlockSize: integer;
    FRootRecord: TRecordType;
    FRootData: Pointer;
    function GetRecordCount: integer;
    function GetRecNo: integer;
    procedure SetRecNo(const Value: integer);
    procedure CreateRootData;
    function ClearRecord(var ARecord: TRecordType): TRecordType;
    procedure SetEmpty(var ARecord: TRecordType; const AEmpty: boolean);
    function GetRecordSize: integer;
    procedure WriteRecord(ARecord: TRecordType; AData: Pointer;
      ADataSize: integer);
    procedure ReadRecord(var ARecord: TRecordType; var AData: Pointer;
      var ADataSize: integer);
  protected
    procedure GetRootData(AData: Pointer); virtual;
    procedure LoadRoot;
    procedure SaveRoot;
    function ReadBlock(var Buffer; Count: Longint): Longint;
    function WriteBlock(const Buffer; Count: Longint): Longint;
    procedure SeekRecord(const AOffset: integer; AOrigin: Word);
    procedure First;
    procedure Last;
    function Append(AData: Pointer; ADataSize: integer): integer;
    procedure Delete(ARecNo: integer);
    procedure WriteData(AData: Pointer; ADataSize: integer);
    procedure ReadData(var AData: Pointer; var ADataSize: integer);
    procedure Next;
    procedure Prior;
    function LockRecord(ARecNo: integer): boolean;
    function UnlockRecord(ARecNo: integer): boolean;
    property RootData: Pointer read FRootData write FRootData;
    property RecordCount: integer read GetRecordCount;
    property RecNo: longint read GetRecNo write SetRecNo;
    property BlockSize: integer read FBlockSize;
    property RootRecord: TRecordType read FRootRecord;
  public
    constructor Create(const AFileName: string; ABlockSize: integer);
    destructor Destroy; override;
  end;

function _intMin(A, B: integer): integer;

implementation

function _intMin(A, B: integer): integer;
{
   -> eax   A
   -> edx   B
   <- eax   A if A < B
            A if A = B
            B if A > B
}
asm
  cmp eax, edx  // ±≡αΓφΦΓασ∞ └ Φ ┬
  jg  @@1       // σ±δΦ eax > edx ΦΣσ∞ ΦΣσ∞ φα @@1
  jmp @@2       // Φφα≈σ Γ√⌡εΣΦ∞
@@1:
  mov eax, edx  // τα∩Φ±√Γασ∞ Γ ┬ Γ Result
@@2:
end;

function _intCompare(A, B: integer): integer;
{
   -> eax   A
   -> edx   B
   <- eax   -1 if A < B
             0 if A = B
             1 if A > B
}
asm
  cmp eax, edx  // ±≡αΓφΦΓασ∞ └ Φ ┬
  jge @@1       // σ±δΦ eax >= edx ΦΣσ∞ ΦΣσ∞ φα @@1
  mov eax, -1   // eax < edx
  jmp @@3
@@1:
  cmp eax, edx  // ±≡αΓφΦΓασ∞ └ Φ ┬
  jg @@2        // σ±δΦ eax > edx ΦΣσ∞ ΦΣσ∞ φα @@2
  mov eax, 0    // eax = edx
  jmp @@3
@@2:
  mov eax, 1    // eax > edx
@@3:
end;

{ THeaderStream }

function TRecordStream.Append(AData: Pointer; ADataSize: integer): integer;
 var
  ARecord: TRecordType;
begin
  if FRootRecord.EmptyPtr = 0 then
  begin
    Seek(0, 2);
    Result := RecNo;
    WriteRecord(ClearRecord(ARecord), AData, ADataSize);
  end
  else begin
    RecNo  := FRootRecord.EmptyPtr;
    Result := RecNo;
    WriteData(AData, ADataSize);
  end;
end;

constructor TRecordStream.Create(const AFileName: string; ABlockSize: integer);
begin
  FBlockSize := ABlockSize;
  CreateRootData;
  if not FileExists(AFileName) then
  begin
    inherited Create(AFileName, fmCreate or fmShareDenyNone);
    SaveRoot;
    GetRootData(FRootData);
    ClearRecord(FRootRecord);
    FRootRecord.DataSize := FBlockSize;
  end
  else begin
    inherited Create(AFileName, fmOpenReadWrite or fmShareDenyNone);
    LoadRoot;
  end;
end;

destructor TRecordStream.Destroy;
begin
  SaveRoot;
  FreeMem(RootData, BlockSize);
  inherited;
end;

procedure TRecordStream.First;
begin
  Seek(0, 0);
end;

function TRecordStream.GetRecNo: integer;
begin
  Result := Position div GetRecordSize;
end;

function TRecordStream.GetRecordCount: integer;
begin
  Result := Size div GetRecordSize;
end;

procedure TRecordStream.Last;
begin
  Seek(-GetRecordSize, 2);
end;

procedure TRecordStream.Next;
begin
  if RecNo < (RecordCount-1) then SeekRecord(1, 1);
end;

procedure TRecordStream.Prior;
begin
  if RecNo > 0 then SeekRecord(-1, 1);
end;

procedure TRecordStream.ReadData(var AData: Pointer; var ADataSize: integer);
 var
  ARecord: TRecordType;
begin
  ReadRecord(ARecord, AData, ADataSize);
end;

procedure TRecordStream.SeekRecord(const AOffset: integer; AOrigin: Word);
begin
  Seek(AOffset*GetRecordSize, AOrigin);
end;

procedure TRecordStream.SetRecNo(const Value: integer);
begin
  if Value > 0 then
    Position := Value * GetRecordSize;
end;

procedure TRecordStream.SaveRoot;
 var
  pBlock: Pointer;
begin
  First;
  GetMem(pBlock, GetRecordSize);
  LockFile(Handle, 0, 0, 1, 0);
  try
    FillChar(pBlock^, GetRecordSize, 0);
    Move(FRootRecord, pBlock^, SizeOf(TRecordType));
    Move(RootData^, (PChar(pBlock)+SizeOf(TRecordType))^, BlockSize);
    Write(pBlock^, GetRecordSize);
  finally
    FreeMem(pBlock, GetRecordSize);
    UnLockFile(Handle, 0, 0, 1, 0);
  end;
end;

procedure TRecordStream.WriteData(AData: Pointer; ADataSize: integer);
 var
  ARecord: TRecordType;
  pBlock: Pointer;
begin
  GetMem(pBlock, GetRecordSize);
  try
    ReadBlock(pBlock^, GetRecordSize);
    Move(pBlock^, ARecord, SizeOf(TRecordType));
    WriteRecord(ARecord, AData, ADataSize);
  finally
    FreeMem(pBlock, GetRecordSize);
  end;
end;

procedure TRecordStream.LoadRoot;
 var
  ADataSize: integer;
begin
  First;
  ReadRecord(FRootRecord, FRootData, ADataSize);
end;

procedure TRecordStream.Delete(ARecNo: Integer);
 var
  AEmptyRecNo, ANextData: integer;
  ARecord: TRecordType;
  pBlock: Pointer;
begin
  AEmptyRecNo := FRootRecord.EmptyPtr;

  GetMem(pBlock, GetRecordSize);
  try
    RecNo     := ARecNo;
    ANextData := ARecNo;

    while (ANextData <> 0) and (Position < Size) do
    begin

      ReadBlock(pBlock^, GetRecordSize);
      Move(pBlock^, ARecord, SizeOf(TRecordType));

      SetEmpty(ARecord, True);
      with ARecord do
      begin
        EmptyPtr    := AEmptyRecNo;
        AEmptyRecNo := ANextData;
        ANextData   := ARecord.NextData;
        NextData    := 0;
      end;

      FillChar((PChar(pBlock)+SizeOf(TRecordType))^, FBlockSize, 0);
      Move(ARecord, pBlock^, SizeOf(TRecordType));

      if ANextData <> 0 then
      begin
        Write(pBlock^, GetRecordSize);
        RecNo := ANextData;
      end
      else
        WriteBlock(pBlock^, GetRecordSize);

    end;

    FRootRecord.EmptyPtr := RecNo;

  finally
    FreeMem(pBlock, GetRecordSize);
  end;
end;

procedure TRecordStream.CreateRootData;
begin
  GetMem(FRootData, BlockSize);
  FillChar(RootData^, BlockSize, 0);
end;

procedure TRecordStream.GetRootData(AData: Pointer);
begin
  Move(RECORD_ROOT_NAME, AData^, Length(RECORD_ROOT_NAME));
end;

procedure TRecordStream.SetEmpty(var ARecord: TRecordType;
  const AEmpty: boolean);
begin
  if AEmpty then
    ARecord.Flags := ARecord.Flags or RECORD_FLAG_EMPTY
  else
    ARecord.Flags := ARecord.Flags and (RECORD_FLAG_EMPTY xor $FF)
end;

function TRecordStream.GetRecordSize: integer;
begin
  Result := SizeOf(TRecordType) + FBlockSize;
end;

procedure TRecordStream.ReadRecord(var ARecord: TRecordType;
  var AData: Pointer; var ADataSize: Integer);
 var
  pBlock: Pointer;
  ABlockOffset: integer;
begin
  ABlockOffset := 0;
  GetMem(pBlock, GetRecordSize);
  try
    ReadBlock(pBlock^, GetRecordSize);
    Move(pBlock^, ARecord, SizeOf(TRecordType));

    ADataSize := ARecord.DataSize;
    ReallocMem(AData, ADataSize);

    Move((PChar(pBlock)+SizeOf(TRecordType))^, (PChar(AData)+ABlockOffset)^,
          _intMin(ADataSize, BlockSize));

    while ARecord.NextData <> 0 do
    begin
       Inc(ABlockOffset, BlockSize);

       RecNo := ARecord.NextData;
       ReadBlock(pBlock^, GetRecordSize);

       Move(pBlock^, ARecord, SizeOf(TRecordType));
       Move((PChar(pBlock)+SizeOf(TRecordType))^, (PChar(AData)+ABlockOffset)^,
             _intMin(ARecord.DataSize, BlockSize));

    end;

  finally
    FreeMem(pBlock, GetRecordSize);
  end;
end;

procedure TRecordStream.WriteRecord(ARecord: TRecordType; AData: Pointer;
  ADataSize: Integer);
 var
  pBlock: Pointer;
  ABlockOffset: integer;
  AEmptyPtr: integer;
  ACompare: integer;
  ANextData: integer;
  lFirstBlock: boolean;
begin
  if ADataSize < 0 then Exit;

  GetMem(pBlock, GetRecordSize);

  try
    ANextData    := 0;
    ABlockOffset := 0;
    lFirstBlock  := True;

    while ABlockOffset < ADataSize do
    begin

      if Position < Size then
      begin
        if not lFirstBlock then
        begin
          ReadBlock(pBlock^, GetRecordSize);
          Move(pBlock^, ARecord, SizeOf(TRecordType));
        end
        else
          lFirstBlock := False;
        ANextData := ARecord.NextData;
        AEmptyPtr := ARecord.NextData;
      end
      else begin
        FillChar(ARecord, SizeOf(ARecord), 0);
        ANextData := 0;
        AEmptyPtr := 0;
      end;

      if AEmptyPtr = 0 then
      begin
        AEmptyPtr := ARecord.EmptyPtr;
        if AEmptyPtr <> 0 then
          FRootRecord.EmptyPtr := AEmptyPtr
        else
        begin
          if FRootRecord.EmptyPtr <> RecNo then
            AEmptyPtr := FRootRecord.EmptyPtr
          else
            FRootRecord.EmptyPtr := 0;
        end
      end;

      with ARecord do
      begin
        EmptyPtr  := 0;
        SetEmpty(ARecord, False);
        ACompare := _intCompare(BlockSize, ADataSize-ABlockOffset);
        case ACompare of
          -1:
            begin
              if AEmptyPtr <> 0 then
                NextData := AEmptyPtr
              else
                NextData := RecordCount+1;
              DataSize := ADataSize;
            end;
           0:
             begin
               NextData := 0;
               DataSize := ADataSize;
             end;
           1:
             begin
               NextData := 0;
               DataSize := ADataSize-ABlockOffset;
             end;
        end;
      end;

      FillChar(pBlock^, GetRecordSize, 0);
      Move((PChar(AData)+ABlockOffset)^, (PChar(pBlock)+SizeOf(TRecordType))^,
           _intMin(BlockSize, ADataSize-ABlockOffset));

      Move(ARecord, pBlock^, SizeOf(TRecordType));
      Inc(ABlockOffset, BlockSize);

      if ARecord.NextData <> 0 then
      begin
        Write(pBlock^, GetRecordSize);
        if ARecord.NextData > RecordCount then
        begin
          RecNo := RecordCount;
          while ARecord.NextData > RecordCount do
          begin
            FillChar(pBlock^, GetRecordSize, 0);
            WriteBlock(pBlock^, GetRecordSize);
          end;
        end;
        RecNo := ARecord.NextData;
      end
      else begin
        WriteBlock(pBlock^, GetRecordSize);
      end;

    end;

    if (ANextData <> 0) and (ANextData <> RecNo) then Delete(ANextData);

  finally
    FreeMem(pBlock, GetRecordSize);
  end;

end;

function TRecordStream.ClearRecord(var ARecord: TRecordType): TRecordType;
begin
  FillChar(ARecord, SizeOf(ARecord), 0);
  SetEmpty(ARecord, True);
  Result := ARecord;
end;

function TRecordStream.ReadBlock(var Buffer; Count: Integer): Longint;
begin
  Result := Read(Buffer,Count);
  Prior;
end;

function TRecordStream.WriteBlock(const Buffer; Count: Integer): Longint;
begin
  Result := Write(Buffer,Count);
  Prior;
end;

function TRecordStream.LockRecord(ARecNo: integer): boolean;
begin
  while not LockFile(Handle, ARecNo*GetRecordSize, 0, GetRecordSize, 0) do
  begin
    Sleep(50);
  end;
  Result := True;
end;

function TRecordStream.UnlockRecord(ARecNo: integer): boolean;
begin
  Result := UnlockFile(Handle, ARecNo*GetRecordSize, 0, GetRecordSize, 0);
end;

end.