1{ %opt=-g-h } 2 3program project1; 4 5{$mode objfpc}{$H+} 6 7uses 8 {$IFDEF UNIX}{$IFDEF UseCThreads} 9 cthreads, 10 {$ENDIF}{$ENDIF} 11 Classes, sysutils 12 { you can add units after this }; 13 14type 15 { TInterfacedObj } 16 17 TInterfacedObj = class(TObject, IUnknown) 18 private 19 FOwner:TInterfacedObj; 20 FDestructorCalled:boolean; 21 22 function GetInterface(const iid: tguid; out obj): longint; 23 procedure Log(const Str:string); 24 protected 25 FRefCount : longint; 26 public 27 function QueryInterface(constref iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 28 function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 29 function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 30 31 constructor Create; 32 33 procedure AfterConstruction;override; 34 procedure BeforeDestruction;override; 35 class function NewInstance : TObject;override; 36 37 property Owner:TInterfacedObj read FOwner write FOwner; 38 end; 39 40 41 IIntf1 = interface 42 ['{EFB94FA8-4F38-4E44-8D12-74A84D07A78C}'] 43 end; 44 45 IIntf2 = interface 46 ['{EBC4A858-7BAC-4310-8426-E52B449D022A}'] 47 procedure Print; 48 procedure SetI(const S:string); 49 end; 50 51 TClass1 = class(TInterfacedObj, IIntf1) 52 53 end; 54 55 { TClass2 } 56 57 TClass2 = class(TInterfacedObj, IIntf2) 58 i:string; 59 procedure Print; 60 procedure SetI(const S:string); 61 end; 62 63 TClass3 = class(TClass1, IIntf2) 64 private 65 FIntf2:IIntf2; 66 property Intf2Prop:IIntf2 read FIntf2 implements IIntf2; 67 public 68 constructor Create; 69 end; 70 71{ TClass2 } 72 73procedure TClass2.Print; 74begin 75 WriteLn('Print ', i); 76end; 77 78procedure TClass2.SetI(const S: string); 79begin 80 i:=S; 81end; 82 83 { TInterfacedObj } 84 85 const Err = HResult($80004002); 86 function TInterfacedObj.GetInterface(const iid: tguid; out obj): longint; 87 begin 88 if inherited GetInterface(IID, Obj) then 89 Result:=0 90 else 91 Result:=Err; 92 end; 93 94 procedure TInterfacedObj.Log(const Str: string); 95 begin 96 WriteLn(Format('%s Obj=$%P class=%s RefCount=%d', [Str, Pointer(Self), ClassName, FRefCount])); 97 end; 98 99function TInterfacedObj.QueryInterface(constref iid: tguid; out obj): longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 100 begin 101 Result:=GetInterface(iid, obj); 102 103 //try to find interface in Owner 104 if (FOwner <> nil) and (Result = Err) then 105 Result:=FOwner.QueryInterface(iid, obj); 106 end; 107 108 function TInterfacedObj._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};[public,alias:'TInterfacedObj_AddRef']; 109 begin 110 if not FDestructorCalled then 111 begin 112 _addref:=interlockedincrement(frefcount); 113 Log('AddRef'); 114 115 if FOwner <> nil then 116 FOwner._AddRef; 117 end; 118 end; 119 120 function TInterfacedObj._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; 121 begin 122 if FDestructorCalled then Exit; 123 124 _Release:=interlockeddecrement(frefcount); 125 Log('Release'); 126 if _Release=0 then 127 begin 128 FDestructorCalled:=True; 129 130 Log('Destroy'); 131 self.destroy; 132 end 133 else 134 if FOwner <> nil then 135 FOwner._Release; 136 end; 137 138 procedure TInterfacedObj.AfterConstruction; 139 begin 140 { we need to fix the refcount we forced in newinstance } 141 { further, it must be done in a thread safe way } 142 //declocked(frefcount); 143 interlockeddecrement(frefcount); 144 Log('AfterConstruction'); 145 end; 146 147 procedure TInterfacedObj.BeforeDestruction; 148 begin 149 Log('BeforeDestruction'); 150 if frefcount<>0 then 151 raise Exception.Create('Cannot free object still referenced.'); 152 end; 153 154 class function TInterfacedObj.NewInstance : TObject; 155 begin 156 NewInstance:=inherited NewInstance; 157 if NewInstance<>nil then 158 TInterfacedObj(NewInstance).frefcount:=1; 159 end; 160 161 constructor TInterfacedObj.Create; 162 begin 163 FDestructorCalled:=false; 164 inherited Create; 165 FOwner:=nil; 166 end; 167 168 169{ TClass2 } 170 171constructor TClass3.Create; 172var O:TClass2; 173begin 174 inherited Create; 175 O:=TClass2.Create; 176 FIntf2:=O; 177 O.Owner:=Self; 178 179 FIntf2.SetI('AAA'); //this line is crucial for bug reproducing 180end; 181 182var O:TClass3; 183 I1:IIntf1; 184 I2:IIntf2; 185begin 186 HaltOnNotReleased := true; 187 O:=TClass3.Create; 188 I1:=O; 189 190 //at this moment O object is already freed in rev.15156+ !!! 191 I2:=I1 as IIntf2; 192 I2.Print; 193 Writeln('ok'); 194end. 195 196