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