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