1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
{
Test program for the CacheCls unit
Copyright (C) 2000 by Sebastian Guenther (sg@freepascal.org)
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.
|
