blob: ff236ec67e5af3923c2ede666e2953ff12c6e2ea (
plain)
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
|
{$ifdef fpc}
{$mode delphi}
{$endif fpc}
{ Some (delphi) applications expect that the QueryInterface method is invoked as first
priority to query for an interface and GetInterface as 2nd priority }
uses
sysutils;
type
ITest = interface
['{E80B0A2E-96ED-4F38-A6AC-E4E0B59F27F3}']
end;
TTest = class(TObject, IUnknown, ITest)
private
refcount: integer;
public
function QueryInterface(const iid : tguid;out obj) : Hresult;stdcall;
function _AddRef : longint;stdcall;
function _Release : longint;stdcall;
end;
var
called: Boolean = False;
function TTest.QueryInterface(const IID: TGUID; out Obj): Hresult; stdcall;
begin
called := true;
if getinterface(iid,obj) then
result:=S_OK
else
result:=longint(E_NOINTERFACE);
end;
function TTest._AddRef : longint;stdcall;
begin
Inc(refcount);
result := refcount;
end;
function TTest._Release : longint;stdcall;
begin
Dec(refcount);
result := refcount;
end;
var
r: TTest;
i: ITest;
procedure get(out obj: ITest);
begin
obj := r as ITest;
end;
begin
r := TTest.Create;
r._AddRef;
if not supports(r, ITest, i) or not called or (r.refcount<>2) then
Halt(1);
called := false;
i := nil;
get(i);
if (i=nil) or not called or (r.refcount<>2) then
Halt(1);
i := nil;
r._Release;
end.
|
