freepascal.compiler/packages/fcl-base/examples/cachetest.pp

{

    Test program for the CacheCls unit
    Copyright (C) 2000 by Sebastian Guenther ([email protected])

    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.
}


program CacheTest;

{$MODE objfpc}

uses Strings, CacheCls;

type
  TCacheTester = class
  private
    TestCache: TCache;
    function TestCacheIsDataEqual(ACache: TCache; AData1, AData2: Pointer): Boolean;
    procedure TestCacheFreeSlot(ACache: TCache; SlotIndex: Integer);
  protected
    procedure AddString(const s: PChar);
    procedure DumpCache;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Run;
  end;



function TCacheTester.TestCacheIsDataEqual(ACache: TCache;
  AData1, AData2: Pointer): Boolean;
begin
  if (not Assigned(AData1)) or (not Assigned(AData2)) then
    Result := (not Assigned(AData1)) and (not Assigned(AData2))
  else
    Result := StrComp(PChar(AData1), PChar(AData2)) = 0;
end;

procedure TCacheTester.TestCacheFreeSlot(ACache: TCache; SlotIndex: Integer);
var
  p: PChar;
begin
  Write('  Cache slot #', SlotIndex, ' has been freed (content: ');
  p := PChar(ACache.Slots[SlotIndex]^.Data);
  if Assigned(p) then
    WriteLn('"', p, '")')
  else
    WriteLn('nil)');
end;

procedure TCacheTester.AddString(const s: PChar);
var
  i: Integer;
begin
  WriteLn('Adding string "', s, '"...');
  i := TestCache.Add(Pointer(s));
  WriteLn('string got cache index #', i);
  WriteLn('New cache state:');
  DumpCache;
  WriteLn;
end;

procedure TCacheTester.DumpCache;
var
  Slot, PrevSlot: PCacheSlot;
begin
  Slot := TestCache.MRUSlot;
  PrevSlot := nil;
  while Assigned(Slot) do
  begin
    Write('  Slot #', Slot^.Index, '  ');
    if Assigned(Slot^.Data) then
      Write('"', PChar(Slot^.Data), '"')
    else
      Write('nil');
    if Slot^.Prev <> PrevSlot then
    begin
      Write('  Slot^.Prev is invalid! (');
      if Assigned(Slot^.Prev) then
        Write('points to #', Slot^.Prev^.Index)
      else
        Write('nil');
      Write(')');
    end;
    WriteLn;
    PrevSlot := Slot;
    Slot := Slot^.Next;
  end;
end;

constructor TCacheTester.Create;
begin
  inherited Create;
  TestCache := TCache.Create(4);
  TestCache.OnIsDataEqual := @TestCacheIsDataEqual;
  TestCache.OnFreeSlot := @TestCacheFreeSlot;

  WriteLn('Initial cache state:');
  DumpCache;
  WriteLn;
end;

destructor TCacheTester.Destroy;
begin
  TestCache.Free;
  inherited Destroy;
end;

procedure TCacheTester.Run;
begin
  AddString('1st');
  AddString('2nd');
  AddString('3rd');
  AddString('4th');
  AddString('5th');
  AddString('3rd');
  AddString('2nd');
  WriteLn('Setting slot count to 2...');
  TestCache.SlotCount := 2;
  WriteLn('Cache state after resize:');
  DumpCache;
  WriteLn;
  AddString('4th');
  WriteLn('Setting slot count to 6...');
  TestCache.SlotCount := 6;
  WriteLn('Cache state after resize:');
  DumpCache;
  WriteLn;
  AddString('5th');
  AddString('6th');
  AddString('7th');
  AddString('8th');
end;


var
  CacheTester: TCacheTester;

begin
  CacheTester := TCacheTester.Create;
  CacheTester.Run;
  CacheTester.Free;
end.