diff --git a/.gitattributes b/.gitattributes index 9dc9038172..00ef6a947f 100644 --- a/.gitattributes +++ b/.gitattributes @@ -8315,6 +8315,7 @@ tests/tbs/tb0567.pp svneol=native#text/plain tests/tbs/tb0568.pp svneol=native#text/plain tests/tbs/tb0569.pp svneol=native#text/pascal tests/tbs/tb0570.pp svneol=native#text/plain +tests/tbs/tb0571.pas svneol=native#text/plain tests/tbs/tb205.pp svneol=native#text/plain tests/tbs/ub0060.pp svneol=native#text/plain tests/tbs/ub0069.pp svneol=native#text/plain diff --git a/tests/tbs/tb0571.pas b/tests/tbs/tb0571.pas new file mode 100644 index 0000000000..ff236ec67e --- /dev/null +++ b/tests/tbs/tb0571.pas @@ -0,0 +1,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.