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     FCritSect: TRTLCriticalSection;
44     FInDestroy: Boolean;
45     procedure DbgAddName(DebugIdAdr: Pointer = nil; DebugIdTxt: String = '');
46     procedure DbgRemoveName(DebugIdAdr: Pointer = nil; DebugIdTxt: String = '');
47     {$ENDIF}
48   protected
49     procedure DoFree; virtual;
50     procedure DoReferenceAdded; virtual;
51     procedure DoReferenceReleased; virtual;
52     property  RefCount: Integer read FRefCount;
53   public
54     constructor Create;
55     destructor  Destroy; override;
56     (* AddReference
57        AddReference/ReleaseReference can be used in Threads.
58        However a thread may only call those, if either
59        - the thread already holds a refernce (and no other thread will release that ref)
60        - the thread just created this, and no other thread has (yet) access to the object
61        - the thread is in a critical section, preventing other threads from decreasing the ref.
62     *)
63     procedure AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''){$ENDIF};
64     procedure ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''){$ENDIF};
65     {$IFDEF WITH_REFCOUNT_DEBUG}
66     procedure DbgRenameReference(DebugIdAdr: Pointer; DebugIdTxt: String);
67     procedure DbgRenameReference(OldDebugIdAdr: Pointer; OldDebugIdTxt: String; DebugIdAdr: Pointer; DebugIdTxt: String = '');
68     {$ENDIF}
69   end;
70 
71   { TRefCntObjList }
72 
73   TRefCntObjList = class(TList)
74   protected
75     procedure Notify(Ptr: Pointer; Action: TListNotification); override;
76   end;
77 
78 
79 procedure ReleaseRefAndNil(var ARefCountedObject {$IFDEF WITH_REFCOUNT_DEBUG}; DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''{$ENDIF});
80 procedure NilThenReleaseRef(var ARefCountedObject {$IFDEF WITH_REFCOUNT_DEBUG}; DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''{$ENDIF});
81 
82 implementation
83 {$IFDEF WITH_REFCOUNT_DEBUG}
84 uses LazLoggerBase;
85 {$IFDEF WITH_REFCOUNT_LEAK_DEBUG}
86 var FUnfreedRefObjList: TRefCountedObject = nil;
87 {$ENDIF}
88 {$ENDIF}
89 
90 { TFreeNotifyingObject }
91 
92 destructor TFreeNotifyingObject.Destroy;
93 begin
94   if FFreeNotificationList <> nil then
95     FFreeNotificationList.CallNotifyEvents(Self);
96   inherited Destroy;
97   FreeAndNil(FFreeNotificationList);
98 end;
99 
100 procedure TFreeNotifyingObject.AddFreeNotification(ANotification: TNotifyEvent);
101 begin
102   if FFreeNotificationList = nil then
103     FFreeNotificationList := TMethodList.Create;
104   FFreeNotificationList.Add(TMethod(ANotification));
105 end;
106 
107 procedure TFreeNotifyingObject.RemoveFreeNotification(ANotification: TNotifyEvent);
108 begin
109   if FFreeNotificationList = nil then
110     exit;
111   FFreeNotificationList.Remove(TMethod(ANotification));
112 end;
113 
114 { TRefCountedObject }
115 
116 procedure TRefCountedObject.AddReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''){$ENDIF};
117 begin
118   {$IFDEF WITH_REFCOUNT_DEBUG}
119   Assert(not FInDestroy, 'Adding reference while destroying');
120   DbgAddName(DebugIdAdr, DebugIdTxt);
121   {$ENDIF}
122   InterLockedIncrement(FRefCount);
123   // call only if overridden
124   If TMethod(@DoReferenceAdded).Code <> Pointer(@TRefCountedObject.DoReferenceAdded) then
125     DoReferenceAdded;
126 end;
127 
128 {$IFDEF WITH_REFCOUNT_DEBUG}
129 procedure TRefCountedObject.DbgAddName(DebugIdAdr: Pointer; DebugIdTxt: String);
130 var
131   s: String;
132 begin
133 // TODO: critical section
134   EnterCriticalsection(FCritSect);
135   try
136   if FDebugList = nil then FDebugList := TStringList.Create;
137   if (DebugIdAdr <> nil) or (DebugIdTxt <> '') then
138     s := inttostr(PtrUInt(DebugIdAdr))+': '+DebugIdTxt
139   else
140     s := 'not named';
141   if FDebugList.indexOf(s) < 0 then
142     FDebugList.AddObject(s, TObject(1))
143   else begin
144     if s <> 'not named' then
145       debugln(['TRefCountedObject.AddReference Duplicate ref ', s]);
146     FDebugList.Objects[FDebugList.IndexOf(s)] :=
147       TObject(PtrUint(FDebugList.Objects[FDebugList.IndexOf(s)])+1);
148   end;
149   finally
150     LeaveCriticalsection(FCritSect);
151   end;
152 end;
153 
154 procedure TRefCountedObject.DbgRemoveName(DebugIdAdr: Pointer; DebugIdTxt: String);
155 var
156   s: String;
157 begin
158   EnterCriticalsection(FCritSect);
159   try
160   if FDebugList = nil then FDebugList := TStringList.Create;
161   if (DebugIdAdr <> nil) or (DebugIdTxt <> '') then
162     s := inttostr(PtrUInt(DebugIdAdr))+': '+DebugIdTxt
163   else
164     s := 'not named';
165   assert(FDebugList.indexOf(s) >= 0, 'Has reference (entry) for '+s);
166   assert(PtrUint(FDebugList.Objects[FDebugList.IndexOf(s)]) > 0, 'Has reference (> 0) for '+s);
167   if PtrUint(FDebugList.Objects[FDebugList.IndexOf(s)]) = 1 then
168     FDebugList.Delete(FDebugList.IndexOf(s))
169   else
170     FDebugList.Objects[FDebugList.IndexOf(s)] :=
171       TObject(PtrInt(FDebugList.Objects[FDebugList.IndexOf(s)])-1);
172   finally
173     LeaveCriticalsection(FCritSect);
174   end;
175 end;
176 {$ENDIF}
177 
178 procedure TRefCountedObject.DoFree;
179 begin
180   {$IFDEF WITH_REFCOUNT_DEBUG}
181   Assert(not FInDestroy, 'TRefCountedObject.DoFree: Double destroy');
182   FInDestroy := True;
183   {$ENDIF}
184   Self.Free;
185 end;
186 
187 procedure TRefCountedObject.DoReferenceAdded;
188 begin
189   //
190 end;
191 
192 procedure TRefCountedObject.DoReferenceReleased;
193 begin
194   //
195 end;
196 
197 constructor TRefCountedObject.Create;
198 begin
199   FRefCount := 0;
200   FInDecRefCount := 0;
201   {$IFDEF WITH_REFCOUNT_DEBUG}
202   if FDebugList = nil then
203     FDebugList := TStringList.Create;
204   InitCriticalSection(FCritSect);
205   {$IFDEF WITH_REFCOUNT_LEAK_DEBUG}
206   FDebugNext := FUnfreedRefObjList;
207   FUnfreedRefObjList := Self;
208   if FDebugNext <> nil then FDebugNext.FDebugPrev := Self;
209   {$ENDIF}
210   {$ENDIF}
211   inherited;
212 end;
213 
214 destructor TRefCountedObject.Destroy;
215 begin
216   {$IFDEF WITH_REFCOUNT_DEBUG}
217   FreeAndNil(FDebugList);
218   DoneCriticalsection(FCritSect);
219   {$IFDEF WITH_REFCOUNT_LEAK_DEBUG}
220   if not( (FDebugPrev=nil) and (FDebugNext = nil) and (FUnfreedRefObjList <> self) ) then begin
221     if FDebugPrev <> nil then begin
222       Assert(FDebugPrev.FDebugNext = Self);
223       FDebugPrev.FDebugNext := FDebugNext;
224     end
225     else begin
226       Assert(FUnfreedRefObjList = Self);
227       FUnfreedRefObjList := FDebugNext;
228     end;
229     if FDebugNext <> nil then begin
230       Assert(FDebugNext.FDebugPrev = Self);
231       FDebugNext.FDebugPrev := FDebugPrev;
232     end;
233   end;
234   {$ENDIF}
235   {$ENDIF}
236   Assert(FRefcount = 0, 'Destroying referenced object');
237   inherited;
238 end;
239 
240 procedure TRefCountedObject.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''){$ENDIF};
241 var
242   lc: Integer;
243 begin
244   if Self = nil then exit;
245   {$IFDEF WITH_REFCOUNT_DEBUG}
246   DbgRemoveName(DebugIdAdr, DebugIdTxt);
247   {$ENDIF}
248   Assert(FRefCount > 0, 'TRefCountedObject.ReleaseReference  RefCount > 0');
249 
250   InterLockedIncrement(FInDecRefCount);
251   InterLockedDecrement(FRefCount);
252   // call only if overridden
253 
254   // Do not check for RefCount = 0, since this was done, by whoever decreased it;
255   If TMethod(@DoReferenceReleased).Code <> Pointer(@TRefCountedObject.DoReferenceReleased) then
256     DoReferenceReleased;
257 
258   lc := InterLockedDecrement(FInDecRefCount);
259   if lc = 0 then begin
260     ReadBarrier;
261     if (FRefCount = 0) then
262       DoFree;
263   end;
264 end;
265 
266 {$IFDEF WITH_REFCOUNT_DEBUG}
267 procedure TRefCountedObject.DbgRenameReference(DebugIdAdr: Pointer; DebugIdTxt: String);
268 begin
269   DbgRemoveName(nil, '');
270   DbgAddName(DebugIdAdr, DebugIdTxt);
271 end;
272 
273 procedure TRefCountedObject.DbgRenameReference(OldDebugIdAdr: Pointer; OldDebugIdTxt: String;
274   DebugIdAdr: Pointer; DebugIdTxt: String);
275 begin
276   DbgRemoveName(OldDebugIdAdr, OldDebugIdTxt);
277   DbgAddName(DebugIdAdr, DebugIdTxt);
278 end;
279 {$ENDIF}
280 
281 { TRefCntObjList }
282 
283 procedure TRefCntObjList.Notify(Ptr: Pointer; Action: TListNotification);
284 begin
285   case Action of
286     lnAdded:   TRefCountedObject(Ptr).AddReference;
287     lnExtracted,
288     lnDeleted: TRefCountedObject(Ptr).ReleaseReference;
289   end;
290 end;
291 
292 procedure ReleaseRefAndNil(var ARefCountedObject {$IFDEF WITH_REFCOUNT_DEBUG}; DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''{$ENDIF});
293 begin
294   Assert( (Pointer(ARefCountedObject) = nil) or
295           (TObject(ARefCountedObject) is TRefCountedObject),
296          'ReleaseRefAndNil requires TRefCountedObject');
297 
298   if Pointer(ARefCountedObject) = nil then
299     exit;
300 
301   if (TObject(ARefCountedObject) is TRefCountedObject) then
302     TRefCountedObject(ARefCountedObject).ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr, DebugIdTxt){$ENDIF};
303   Pointer(ARefCountedObject) := nil;
304 end;
305 
306 procedure NilThenReleaseRef(var ARefCountedObject {$IFDEF WITH_REFCOUNT_DEBUG}; DebugIdAdr: Pointer = nil; DebugIdTxt: String = ''{$ENDIF});
307 var
308   RefObj: TRefCountedObject;
309 begin
310   Assert( (Pointer(ARefCountedObject) = nil) or
311           (TObject(ARefCountedObject) is TRefCountedObject),
312          'ReleaseRefAndNil requires TRefCountedObject');
313 
314   if Pointer(ARefCountedObject) = nil then
315     exit;
316 
317   if (TObject(ARefCountedObject) is TRefCountedObject) then
318     RefObj := TRefCountedObject(ARefCountedObject)
319   else RefObj := nil;
320   Pointer(ARefCountedObject) := nil;
321 
322   if RefObj <> nil then
323     RefObj.ReleaseReference{$IFDEF WITH_REFCOUNT_DEBUG}(DebugIdAdr, DebugIdTxt){$ENDIF};
324 end;
325 
326 end .
327 
328