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