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 LazClasses;
10 
11 {$mode objfpc}{$H+}
12 
13 interface
14 
15 uses
16   sysutils, Classes,
17   // LazUtils
18   LazMethodList;
19 
20 type
21 
22   { TFreeNotifyingObject }
23 
24   TFreeNotifyingObject = class
25   private
26     FFreeNotificationList: TMethodList;
27   public
28     destructor Destroy; override;
29     procedure AddFreeNotification(ANotification: TNotifyEvent);
30     procedure RemoveFreeNotification(ANotification: TNotifyEvent);
31   end;
32 
33   { TRefCountedObject }
34 
35   TRefCountedObject = class(TFreeNotifyingObject)
36   private
37     FRefCount, FInDecRefCount: Integer;
38     {$IFDEF WITH_REFCOUNT_DEBUG}
39     {$IFDEF WITH_REFCOUNT_LEAK_DEBUG}
40     FDebugNext, FDebugPrev: TRefCountedObject;
41     {$ENDIF}
42     FDebugList: TStringList;
43     FInDestroy: Boolean;
44     procedure DbgAddName(DebugIdAdr: Pointer = nil; DebugIdTxt: String = '');
45     procedure DbgRemoveName(DebugIdAdr: Pointer = nil; DebugIdTxt: String = '');
46     {$ENDIF}
47   protected
48     procedure DoFree; virtual;
49     procedure DoReferenceAdded; virtual;
50     procedure DoReferenceReleased; virtual;
51     property  RefCount: Integer read FRefCount;
52   public
53     constructor Create;
54     destructor  Destroy; override;
55     procedure AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''){$ENDIF};
56     procedure ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''){$ENDIF};
57     {$IFDEF WITH_REFCOUNT_DEBUG}
58     procedure DbgRenameReference(DebugIdAdr: Pointer; DebugIdTxt: String);
59     procedure DbgRenameReference(OldDebugIdAdr: Pointer; OldDebugIdTxt: String; DebugIdAdr: Pointer; DebugIdTxt: String = '');
60     {$ENDIF}
61   end;
62 
63   { TRefCntObjList }
64 
65   TRefCntObjList = class(TList)
66   protected
67     procedure Notify(Ptr: Pointer; Action: TListNotification); override;
68   end;
69 
70 
71 procedure ReleaseRefAndNil(var ARefCountedObject {$IFDEF WITH_REFCOUNT_DEBUG}; DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''{$ENDIF});
72 procedure NilThenReleaseRef(var ARefCountedObject {$IFDEF WITH_REFCOUNT_DEBUG}; DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''{$ENDIF});
73 
74 implementation
75 {$IFDEF WITH_REFCOUNT_DEBUG}
76 uses LazLoggerBase;
77 {$IFDEF WITH_REFCOUNT_LEAK_DEBUG}
78 var FUnfreedRefObjList: TRefCountedObject = nil;
79 {$ENDIF}
80 {$ENDIF}
81 
82 { TFreeNotifyingObject }
83 
84 destructor TFreeNotifyingObject.Destroy;
85 begin
86   if FFreeNotificationList <> nil then
87     FFreeNotificationList.CallNotifyEvents(Self);
88   inherited Destroy;
89   FreeAndNil(FFreeNotificationList);
90 end;
91 
92 procedure TFreeNotifyingObject.AddFreeNotification(ANotification: TNotifyEvent);
93 begin
94   if FFreeNotificationList = nil then
95     FFreeNotificationList := TMethodList.Create;
96   FFreeNotificationList.Add(TMethod(ANotification));
97 end;
98 
99 procedure TFreeNotifyingObject.RemoveFreeNotification(ANotification: TNotifyEvent);
100 begin
101   if FFreeNotificationList = nil then
102     exit;
103   FFreeNotificationList.Remove(TMethod(ANotification));
104 end;
105 
106 { TRefCountedObject }
107 
108 procedure TRefCountedObject.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''){$ENDIF};
109 begin
110   {$IFDEF WITH_REFCOUNT_DEBUG}
111   Assert(not FInDestroy, 'Adding reference while destroying');
112   DbgAddName(DebugIdAdr, DebugIdTxt);
113   {$ENDIF}
114   Inc(FRefcount);
115   // call only if overridden
116   If TMethod(@DoReferenceAdded).Code <> Pointer(@TRefCountedObject.DoReferenceAdded) then
117     DoReferenceAdded;
118 end;
119 
120 {$IFDEF WITH_REFCOUNT_DEBUG}
121 procedure TRefCountedObject.DbgAddName(DebugIdAdr: Pointer; DebugIdTxt: String);
122 var
123   s: String;
124 begin
125   if FDebugList = nil then FDebugList := TStringList.Create;
126   if (DebugIdAdr <> nil) or (DebugIdTxt <> '') then
127     s := inttostr(PtrUInt(DebugIdAdr))+': '+DebugIdTxt
128   else
129     s := 'not named';
130   if FDebugList.indexOf(s) < 0 then
131     FDebugList.AddObject(s, TObject(1))
132   else begin
133     if s <> 'not named' then
134       debugln(['TRefCountedObject.AddReference Duplicate ref ', s]);
135     FDebugList.Objects[FDebugList.IndexOf(s)] :=
136       TObject(PtrUint(FDebugList.Objects[FDebugList.IndexOf(s)])+1);
137   end;
138 end;
139 
140 procedure TRefCountedObject.DbgRemoveName(DebugIdAdr: Pointer; DebugIdTxt: String);
141 var
142   s: String;
143 begin
144   if FDebugList = nil then FDebugList := TStringList.Create;
145   if (DebugIdAdr <> nil) or (DebugIdTxt <> '') then
146     s := inttostr(PtrUInt(DebugIdAdr))+': '+DebugIdTxt
147   else
148     s := 'not named';
149   assert(FDebugList.indexOf(s) >= 0, 'Has reference (entry) for '+s);
150   assert(PtrUint(FDebugList.Objects[FDebugList.IndexOf(s)]) > 0, 'Has reference (> 0) for '+s);
151   if PtrUint(FDebugList.Objects[FDebugList.IndexOf(s)]) = 1 then
152     FDebugList.Delete(FDebugList.IndexOf(s))
153   else
154     FDebugList.Objects[FDebugList.IndexOf(s)] :=
155       TObject(PtrInt(FDebugList.Objects[FDebugList.IndexOf(s)])-1);
156 end;
157 {$ENDIF}
158 
159 procedure TRefCountedObject.DoFree;
160 begin
161   {$IFDEF WITH_REFCOUNT_DEBUG}
162   Assert(not FInDestroy, 'TRefCountedObject.DoFree: Double destroy');
163   FInDestroy := True;
164   {$ENDIF}
165   Self.Free;
166 end;
167 
168 procedure TRefCountedObject.DoReferenceAdded;
169 begin
170   //
171 end;
172 
173 procedure TRefCountedObject.DoReferenceReleased;
174 begin
175   //
176 end;
177 
178 constructor TRefCountedObject.Create;
179 begin
180   FRefCount := 0;
181   FInDecRefCount := 0;
182   {$IFDEF WITH_REFCOUNT_DEBUG}
183   if FDebugList = nil then
184     FDebugList := TStringList.Create;
185   {$IFDEF WITH_REFCOUNT_LEAK_DEBUG}
186   FDebugNext := FUnfreedRefObjList;
187   FUnfreedRefObjList := Self;
188   if FDebugNext <> nil then FDebugNext.FDebugPrev := Self;
189   {$ENDIF}
190   {$ENDIF}
191   inherited;
192 end;
193 
194 destructor TRefCountedObject.Destroy;
195 begin
196   {$IFDEF WITH_REFCOUNT_DEBUG}
197   FreeAndNil(FDebugList);
198   {$IFDEF WITH_REFCOUNT_LEAK_DEBUG}
199   if not( (FDebugPrev=nil) and (FDebugNext = nil) and (FUnfreedRefObjList <> self) ) then begin
200     if FDebugPrev <> nil then begin
201       Assert(FDebugPrev.FDebugNext = Self);
202       FDebugPrev.FDebugNext := FDebugNext;
203     end
204     else begin
205       Assert(FUnfreedRefObjList = Self);
206       FUnfreedRefObjList := FDebugNext;
207     end;
208     if FDebugNext <> nil then begin
209       Assert(FDebugNext.FDebugPrev = Self);
210       FDebugNext.FDebugPrev := FDebugPrev;
211     end;
212   end;
213   {$ENDIF}
214   {$ENDIF}
215   Assert(FRefcount = 0, 'Destroying referenced object');
216   inherited;
217 end;
218 
219 procedure TRefCountedObject.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''){$ENDIF};
220 begin
221   if Self = nil then exit;
222   {$IFDEF WITH_REFCOUNT_DEBUG}
223   DbgRemoveName(DebugIdAdr, DebugIdTxt);
224   {$ENDIF}
225   Assert(FRefCount > 0, 'TRefCountedObject.ReleaseReference  RefCount > 0');
226 
227   Dec(FRefCount);
228   inc(FInDecRefCount);
229   // call only if overridden
230 
231   // Do not check for RefCount = 0, since this was done, by whoever decreased it;
232   If TMethod(@DoReferenceReleased).Code <> Pointer(@TRefCountedObject.DoReferenceReleased) then
233     DoReferenceReleased;
234 
235   dec(FInDecRefCount);
236   if (FRefCount = 0) and (FInDecRefCount = 0) then
237     DoFree;
238 end;
239 
240 {$IFDEF WITH_REFCOUNT_DEBUG}
241 procedure TRefCountedObject.DbgRenameReference(DebugIdAdr: Pointer; DebugIdTxt: String);
242 begin
243   DbgRemoveName(nil, '');
244   DbgAddName(DebugIdAdr, DebugIdTxt);
245 end;
246 
247 procedure TRefCountedObject.DbgRenameReference(OldDebugIdAdr: Pointer; OldDebugIdTxt: String;
248   DebugIdAdr: Pointer; DebugIdTxt: String);
249 begin
250   DbgRemoveName(OldDebugIdAdr, OldDebugIdTxt);
251   DbgAddName(DebugIdAdr, DebugIdTxt);
252 end;
253 {$ENDIF}
254 
255 { TRefCntObjList }
256 
257 procedure TRefCntObjList.Notify(Ptr: Pointer; Action: TListNotification);
258 begin
259   case Action of
260     lnAdded:   TRefCountedObject(Ptr).AddReference;
261     lnExtracted,
262     lnDeleted: TRefCountedObject(Ptr).ReleaseReference;
263   end;
264 end;
265 
266 procedure ReleaseRefAndNil(var ARefCountedObject {$IFDEF WITH_REFCOUNT_DEBUG}; DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''{$ENDIF});
267 begin
268   Assert( (Pointer(ARefCountedObject) = nil) or
269           (TObject(ARefCountedObject) is TRefCountedObject),
270          'ReleaseRefAndNil requires TRefCountedObject');
271 
272   if Pointer(ARefCountedObject) = nil then
273     exit;
274 
275   if (TObject(ARefCountedObject) is TRefCountedObject) then
276     TRefCountedObject(ARefCountedObject).ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr, DebugIdTxt){$ENDIF};
277   Pointer(ARefCountedObject) := nil;
278 end;
279 
280 procedure NilThenReleaseRef(var ARefCountedObject {$IFDEF WITH_REFCOUNT_DEBUG}; DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''{$ENDIF});
281 var
282   RefObj: TRefCountedObject;
283 begin
284   Assert( (Pointer(ARefCountedObject) = nil) or
285           (TObject(ARefCountedObject) is TRefCountedObject),
286          'ReleaseRefAndNil requires TRefCountedObject');
287 
288   if Pointer(ARefCountedObject) = nil then
289     exit;
290 
291   if (TObject(ARefCountedObject) is TRefCountedObject) then
292     RefObj := TRefCountedObject(ARefCountedObject)
293   else RefObj := nil;
294   Pointer(ARefCountedObject) := nil;
295 
296   if RefObj <> nil then
297     RefObj.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr, DebugIdTxt){$ENDIF};
298 end;
299 
300 end .
301 
302