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