1 {
2 *****************************************************************************
3 This file is part of LazUtils.
4
5 See the file COPYING.modifiedLGPL.txt, included in this distribution,
6 for details about the license.
7 *****************************************************************************
8 }
9 unit LazMethodList;
10
11 {$mode objfpc}{$H+}
12 {$modeswitch advancedrecords}
13
14 interface
15
16 uses
17 Classes, SysUtils, RtlConsts;
18
19 type
20 { TMethodList - array of TMethod }
21
22 TMethodList = class
23 private type
24 TItemsEnumerator = record
25 private
26 Owner: TMethodList;
27 Index: Integer;
28 Reverse: Boolean;
GetCurrentnull29 function GetCurrent: TMethod;
30 public
31 procedure Init(AOwner: TMethodList; AReverse: Boolean);
MoveNextnull32 function MoveNext: Boolean;
GetEnumeratornull33 function GetEnumerator: TItemsEnumerator;
34 property Current: TMethod read GetCurrent;
35 end;
36 private
37 FAllowDuplicates: boolean;
38 FItems: ^TMethod;
39 FCount: integer;
GetItemsnull40 function GetItems(Index: integer): TMethod;
41 procedure SetAllowDuplicates(AValue: boolean);
42 procedure SetItems(Index: integer; const AValue: TMethod);
43 procedure InternalInsert(Index: integer; const AMethod: TMethod);
44 procedure RaiseIndexOutOfBounds(Index: integer);
45 public
46 destructor Destroy; override;
Countnull47 function Count: integer;
NextDownIndexnull48 function NextDownIndex(var Index: integer): boolean;
IndexOfnull49 function IndexOf(const AMethod: TMethod): integer;
50 procedure Assign(Source: TMethodList);
51 procedure Clear;
52 procedure Delete(Index: integer);
53 procedure Remove(const AMethod: TMethod);
54 procedure Add(const AMethod: TMethod);
55 procedure Add(const AMethod: TMethod; AsLast: boolean);
56 procedure Insert(Index: integer; const AMethod: TMethod);
57 procedure Move(OldIndex, NewIndex: integer);
58 procedure RemoveAllMethodsOfObject(const AnObject: TObject);
59 procedure CallNotifyEvents(Sender: TObject); // calls from Count-1 downto 0, all methods must be TNotifyEvent
GetReversedEnumeratornull60 function GetReversedEnumerator: TItemsEnumerator;
GetEnumeratornull61 function GetEnumerator: TItemsEnumerator;
62 public
63 property Items[Index: integer]: TMethod read GetItems write SetItems; default;
64 property AllowDuplicates: boolean read FAllowDuplicates write SetAllowDuplicates; // default false, changed in Lazarus 1.3
65 end;
66
CompareMethodsnull67 function CompareMethods(const m1, m2: TMethod): boolean; inline;
68
69
70 implementation
71
CompareMethodsnull72 function CompareMethods(const m1, m2: TMethod): boolean;
73 begin
74 {$PUSH} {$BOOLEVAL ON}
75 // With a full evaluation of the boolean expression the generated code will not
76 // contain conditional statements, which is more efficient on modern processors
77 Result:=(m1.Code=m2.Code) and (m1.Data=m2.Data);
78 {$POP}
79 end;
80
81 { TMethodList.TItemsEnumerator }
82
TItemsEnumeratornull83 function TMethodList.TItemsEnumerator.GetCurrent: TMethod;
84 begin
85 Result := Owner[Index];
86 end;
87
TItemsEnumeratornull88 function TMethodList.TItemsEnumerator.GetEnumerator: TItemsEnumerator;
89 begin
90 Result := Self;
91 end;
92
93 procedure TMethodList.TItemsEnumerator.Init(AOwner: TMethodList;
94 AReverse: Boolean);
95 begin
96 Owner := AOwner;
97 Reverse := AReverse;
98 if Reverse then
99 Index := AOwner.Count
100 else
101 Index := -1;
102 end;
103
TItemsEnumeratornull104 function TMethodList.TItemsEnumerator.MoveNext: Boolean;
105 begin
106 if Reverse then
107 begin
108 Dec(Index);
109 Result := Index >= 0;
110 end else
111 begin
112 Inc(Index);
113 Result := Index < Owner.Count;
114 end;
115 end;
116
117 { TMethodList }
118
TMethodList.GetItemsnull119 function TMethodList.GetItems(Index: integer): TMethod;
120 begin
121 Result:=FItems[Index];
122 end;
123
TMethodList.GetReversedEnumeratornull124 function TMethodList.GetReversedEnumerator: TItemsEnumerator;
125 begin
126 Result.Init(Self, True);
127 end;
128
129 procedure TMethodList.SetAllowDuplicates(AValue: boolean);
130 var
131 i, j: Integer;
132 begin
133 if FAllowDuplicates=AValue then Exit;
134 FAllowDuplicates:=AValue;
135 if not AllowDuplicates then
136 begin
137 i:=0;
138 while i<FCount do
139 begin
140 j:=i+1;
141 while j<FCount do
142 begin
143 if CompareMethods(FItems[i], FItems[j]) then
144 Delete(j)
145 else
146 inc(j);
147 end;
148 inc(i);
149 end;
150 end;
151 end;
152
153 procedure TMethodList.SetItems(Index: integer; const AValue: TMethod);
154
155 procedure RaiseDuplicate;
156 begin
157 raise EListError.CreateFmt(SDuplicateItem,[AValue.Code]);
158 end;
159
160 begin
161 if (not AllowDuplicates) and (IndexOf(AValue)<>Index) then
162 RaiseDuplicate;
163 FItems[Index]:=AValue;
164 end;
165
166 procedure TMethodList.InternalInsert(Index: integer; const AMethod: TMethod);
167 begin
168 inc(FCount);
169 ReAllocMem(FItems,FCount*SizeOf(TMethod));
170 if Index<FCount then
171 System.Move(FItems[Index],FItems[Index+1],(FCount-Index-1)*SizeOf(TMethod));
172 FItems[Index]:=AMethod;
173 end;
174
175 procedure TMethodList.RaiseIndexOutOfBounds(Index: integer);
176 begin
177 raise EListError.CreateFmt(SListIndexError,[Index]);
178 end;
179
180 destructor TMethodList.Destroy;
181 begin
182 Clear;
183 inherited Destroy;
184 end;
185
GetEnumeratornull186 function TMethodList.GetEnumerator: TItemsEnumerator;
187 begin
188 Result.Init(Self, False);
189 end;
190
TMethodList.Countnull191 function TMethodList.Count: integer;
192 begin
193 if Self<>nil then
194 Result:=FCount
195 else
196 Result:=0;
197 end;
198
TMethodList.NextDownIndexnull199 function TMethodList.NextDownIndex(var Index: integer): boolean;
200 begin
201 if Self<>nil then begin
202 dec(Index);
203 if (Index>=FCount) then
204 Index:=FCount-1;
205 end else
206 Index:=-1;
207 Result:=(Index>=0);
208 end;
209
TMethodList.IndexOfnull210 function TMethodList.IndexOf(const AMethod: TMethod): integer;
211 begin
212 if Self<>nil then begin
213 Result:=FCount-1;
214 while Result>=0 do begin
215 if CompareMethods(FItems[Result], AMethod) then
216 Exit;
217 dec(Result);
218 end;
219 end else
220 Result:=-1;
221 end;
222
223 procedure TMethodList.Assign(Source: TMethodList);
224 var
225 i: Integer;
226 begin
227 Clear;
228 for i := 0 to Source.Count-1 do
229 Add(Source.Items[i]);
230 end;
231
232 procedure TMethodList.Clear;
233 begin
234 ReAllocMem(FItems,0);
235 end;
236
237 procedure TMethodList.Delete(Index: integer);
238 begin
239 dec(FCount);
240 if FCount>Index then
241 System.Move(FItems[Index+1],FItems[Index],(FCount-Index)*SizeOf(TMethod));
242 ReAllocMem(FItems,FCount*SizeOf(TMethod));
243 end;
244
245 procedure TMethodList.Remove(const AMethod: TMethod);
246 var
247 i: integer;
248 begin
249 if Self<>nil then begin
250 i:=IndexOf(AMethod);
251 if i>=0 then Delete(i);
252 end;
253 end;
254
255 procedure TMethodList.Add(const AMethod: TMethod);
256 var
257 i: Integer;
258 begin
259 if AllowDuplicates then
260 i:=-1
261 else
262 i:=IndexOf(AMethod);
263 if (i<0) then
264 begin
265 inc(FCount);
266 ReAllocMem(FItems,FCount*SizeOf(TMethod));
267 end else begin
268 if i=FCount-1 then exit;
269 System.Move(FItems[i+1],FItems[i],SizeOf(TMethod)*(FCount-i-1));
270 end;
271 FItems[FCount-1]:=AMethod;
272 end;
273
274 procedure TMethodList.Add(const AMethod: TMethod; AsLast: boolean);
275 begin
276 if AsLast then
277 Add(AMethod)
278 else
279 Insert(0,AMethod);
280 end;
281
282 procedure TMethodList.Insert(Index: integer; const AMethod: TMethod);
283 var
284 i: Integer;
285 begin
286 if AllowDuplicates then
287 i:=-1
288 else
289 i:=IndexOf(AMethod);
290 if i<0 then
291 begin
292 if (Index<0) or (Index>FCount) then
293 RaiseIndexOutOfBounds(Index);
294 InternalInsert(Index,AMethod)
295 end else
296 Move(i,Index);
297 end;
298
299 procedure TMethodList.Move(OldIndex, NewIndex: integer);
300 var
301 MovingMethod: TMethod;
302 begin
303 if OldIndex=NewIndex then exit;
304 if (NewIndex<0) or (NewIndex>=FCount) then
305 RaiseIndexOutOfBounds(NewIndex);
306 MovingMethod:=FItems[OldIndex];
307 if OldIndex>NewIndex then
308 System.Move(FItems[NewIndex],FItems[NewIndex+1],
309 SizeOf(TMethod)*(OldIndex-NewIndex))
310 else
311 System.Move(FItems[NewIndex+1],FItems[NewIndex],
312 SizeOf(TMethod)*(NewIndex-OldIndex));
313 FItems[NewIndex]:=MovingMethod;
314 end;
315
316 procedure TMethodList.RemoveAllMethodsOfObject(const AnObject: TObject);
317 var
318 i: Integer;
319 begin
320 if Self=nil then exit;
321 i:=FCount-1;
322 while i>=0 do begin
323 if TObject(FItems[i].Data)=AnObject then Delete(i);
324 dec(i);
325 end;
326 end;
327
328 procedure TMethodList.CallNotifyEvents(Sender: TObject);
329 var
330 i: LongInt;
331 begin
332 i:=Count;
333 while NextDownIndex(i) do
334 TNotifyEvent(Items[i])(Sender);
335 end;
336
337 end.
338
339