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 Delete(Index: integer);
51 procedure Remove(const AMethod: TMethod);
52 procedure Add(const AMethod: TMethod);
53 procedure Add(const AMethod: TMethod; AsLast: boolean);
54 procedure Insert(Index: integer; const AMethod: TMethod);
55 procedure Move(OldIndex, NewIndex: integer);
56 procedure RemoveAllMethodsOfObject(const AnObject: TObject);
57 procedure CallNotifyEvents(Sender: TObject); // calls from Count-1 downto 0, all methods must be TNotifyEvent
GetReversedEnumeratornull58 function GetReversedEnumerator: TItemsEnumerator;
GetEnumeratornull59 function GetEnumerator: TItemsEnumerator;
60 public
61 property Items[Index: integer]: TMethod read GetItems write SetItems; default;
62 property AllowDuplicates: boolean read FAllowDuplicates write SetAllowDuplicates; // default false, changed in Lazarus 1.3
63 end;
64
CompareMethodsnull65 function CompareMethods(const m1, m2: TMethod): boolean;
66
67
68 implementation
69
CompareMethodsnull70 function CompareMethods(const m1, m2: TMethod): boolean;
71 begin
72 Result:=(m1.Code=m2.Code) and (m1.Data=m2.Data);
73 end;
74
75 { TMethodList.TItemsEnumerator }
76
TItemsEnumeratornull77 function TMethodList.TItemsEnumerator.GetCurrent: TMethod;
78 begin
79 Result := Owner[Index];
80 end;
81
TItemsEnumeratornull82 function TMethodList.TItemsEnumerator.GetEnumerator: TItemsEnumerator;
83 begin
84 Result := Self;
85 end;
86
87 procedure TMethodList.TItemsEnumerator.Init(AOwner: TMethodList;
88 AReverse: Boolean);
89 begin
90 Owner := AOwner;
91 Reverse := AReverse;
92 if Reverse then
93 Index := AOwner.Count
94 else
95 Index := -1;
96 end;
97
TItemsEnumeratornull98 function TMethodList.TItemsEnumerator.MoveNext: Boolean;
99 begin
100 if Reverse then
101 begin
102 Dec(Index);
103 Result := Index >= 0;
104 end else
105 begin
106 Inc(Index);
107 Result := Index < Owner.Count;
108 end;
109 end;
110
111 { TMethodList }
112
TMethodList.GetItemsnull113 function TMethodList.GetItems(Index: integer): TMethod;
114 begin
115 Result:=FItems[Index];
116 end;
117
TMethodList.GetReversedEnumeratornull118 function TMethodList.GetReversedEnumerator: TItemsEnumerator;
119 begin
120 Result.Init(Self, True);
121 end;
122
123 procedure TMethodList.SetAllowDuplicates(AValue: boolean);
124 var
125 i, j: Integer;
126 begin
127 if FAllowDuplicates=AValue then Exit;
128 FAllowDuplicates:=AValue;
129 if not AllowDuplicates then
130 begin
131 i:=0;
132 while i<FCount do
133 begin
134 j:=i+1;
135 while j<FCount do
136 begin
137 if (FItems[i].Code=FItems[j].Code)
138 and (FItems[i].Data=FItems[j].Data) then
139 Delete(j)
140 else
141 inc(j);
142 end;
143 inc(i);
144 end;
145 end;
146 end;
147
148 procedure TMethodList.SetItems(Index: integer; const AValue: TMethod);
149
150 procedure RaiseDuplicate;
151 begin
152 raise EListError.CreateFmt(SDuplicateItem,[AValue.Code]);
153 end;
154
155 begin
156 if (not AllowDuplicates) and (IndexOf(AValue)<>Index) then
157 RaiseDuplicate;
158 FItems[Index]:=AValue;
159 end;
160
161 procedure TMethodList.InternalInsert(Index: integer; const AMethod: TMethod);
162 begin
163 inc(FCount);
164 ReAllocMem(FItems,FCount*SizeOf(TMethod));
165 if Index<FCount then
166 System.Move(FItems[Index],FItems[Index+1],(FCount-Index-1)*SizeOf(TMethod));
167 FItems[Index]:=AMethod;
168 end;
169
170 procedure TMethodList.RaiseIndexOutOfBounds(Index: integer);
171 begin
172 raise EListError.CreateFmt(SListIndexError,[Index]);
173 end;
174
175 destructor TMethodList.Destroy;
176 begin
177 ReAllocMem(FItems,0);
178 inherited Destroy;
179 end;
180
GetEnumeratornull181 function TMethodList.GetEnumerator: TItemsEnumerator;
182 begin
183 Result.Init(Self, False);
184 end;
185
TMethodList.Countnull186 function TMethodList.Count: integer;
187 begin
188 if Self<>nil then
189 Result:=FCount
190 else
191 Result:=0;
192 end;
193
TMethodList.NextDownIndexnull194 function TMethodList.NextDownIndex(var Index: integer): boolean;
195 begin
196 if Self<>nil then begin
197 dec(Index);
198 if (Index>=FCount) then
199 Index:=FCount-1;
200 end else
201 Index:=-1;
202 Result:=(Index>=0);
203 end;
204
TMethodList.IndexOfnull205 function TMethodList.IndexOf(const AMethod: TMethod): integer;
206 begin
207 if Self<>nil then begin
208 Result:=FCount-1;
209 while Result>=0 do begin
210 if (FItems[Result].Code=AMethod.Code)
211 and (FItems[Result].Data=AMethod.Data) then exit;
212 dec(Result);
213 end;
214 end else
215 Result:=-1;
216 end;
217
218 procedure TMethodList.Delete(Index: integer);
219 begin
220 dec(FCount);
221 if FCount>Index then
222 System.Move(FItems[Index+1],FItems[Index],(FCount-Index)*SizeOf(TMethod));
223 ReAllocMem(FItems,FCount*SizeOf(TMethod));
224 end;
225
226 procedure TMethodList.Remove(const AMethod: TMethod);
227 var
228 i: integer;
229 begin
230 if Self<>nil then begin
231 i:=IndexOf(AMethod);
232 if i>=0 then Delete(i);
233 end;
234 end;
235
236 procedure TMethodList.Add(const AMethod: TMethod);
237 var
238 i: Integer;
239 begin
240 if AllowDuplicates then
241 i:=-1
242 else
243 i:=IndexOf(AMethod);
244 if (i<0) then
245 begin
246 inc(FCount);
247 ReAllocMem(FItems,FCount*SizeOf(TMethod));
248 end else begin
249 if i=FCount-1 then exit;
250 System.Move(FItems[i+1],FItems[i],SizeOf(TMethod)*(FCount-i-1));
251 end;
252 FItems[FCount-1]:=AMethod;
253 end;
254
255 procedure TMethodList.Add(const AMethod: TMethod; AsLast: boolean);
256 begin
257 if AsLast then
258 Add(AMethod)
259 else
260 Insert(0,AMethod);
261 end;
262
263 procedure TMethodList.Insert(Index: integer; const AMethod: TMethod);
264 var
265 i: Integer;
266 begin
267 if AllowDuplicates then
268 i:=-1
269 else
270 i:=IndexOf(AMethod);
271 if i<0 then
272 begin
273 if (Index<0) or (Index>FCount) then
274 RaiseIndexOutOfBounds(Index);
275 InternalInsert(Index,AMethod)
276 end else
277 Move(i,Index);
278 end;
279
280 procedure TMethodList.Move(OldIndex, NewIndex: integer);
281 var
282 MovingMethod: TMethod;
283 begin
284 if OldIndex=NewIndex then exit;
285 if (NewIndex<0) or (NewIndex>=FCount) then
286 RaiseIndexOutOfBounds(NewIndex);
287 MovingMethod:=FItems[OldIndex];
288 if OldIndex>NewIndex then
289 System.Move(FItems[NewIndex],FItems[NewIndex+1],
290 SizeOf(TMethod)*(OldIndex-NewIndex))
291 else
292 System.Move(FItems[NewIndex+1],FItems[NewIndex],
293 SizeOf(TMethod)*(NewIndex-OldIndex));
294 FItems[NewIndex]:=MovingMethod;
295 end;
296
297 procedure TMethodList.RemoveAllMethodsOfObject(const AnObject: TObject);
298 var
299 i: Integer;
300 begin
301 if Self=nil then exit;
302 i:=FCount-1;
303 while i>=0 do begin
304 if TObject(FItems[i].Data)=AnObject then Delete(i);
305 dec(i);
306 end;
307 end;
308
309 procedure TMethodList.CallNotifyEvents(Sender: TObject);
310 var
311 i: LongInt;
312 begin
313 i:=Count;
314 while NextDownIndex(i) do
315 TNotifyEvent(Items[i])(Sender);
316 end;
317
318 end.
319
320