unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
IMyInterface = interface
['{CEC89718-0B2D-4BA5-886F-03FF11955644}']
function GetSelf:TObject;
function _ReferenceCounted:boolean;
end;
{ TMyInterfacedObjectNoRefCount }
TMyInterfacedObjectNoRefCount = class(TObject, IUnknown, IMyInterface)
private
protected
function _AddRef:longint;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};
function _Release:longint;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): {$IFDEF LINUX}Longint;cdecl{$ELSE}HResult;stdcall{$ENDIF};
public
function GetSelf:TObject;virtual;
function _ReferenceCounted:boolean;virtual;
end;
TMyInterface = interface
procedure DoSometing;
end;
TMyOtherIntf = interface(TMyInterface)
end;
{ TMyClass }
TMyClass = class(TMyInterfacedObjectNoRefCount,TMyOtherIntf)
public
destructor Destroy;override;
procedure DoSometing;
end;
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
function GetMyInterface:TMyOtherIntf;
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
procedure FreeInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} X);
{$IFDEF AUTOREFCOUNT}
begin
end;
{$ELSE}
var
obj : TObject;
p : ^Pointer;
a1 : IUnknown;
a2 : IMyInterface;
procedure GetIMyInterface;
begin
// The following assignment in FPC causes RecCount to be incremented twice
// while DCC only once. This is because FPC increments with the call to
// QueryInterface (DCC doesn't). The temp result is released (decremented)
// on exit from this nested method. So the net effect is only one increment.
// If this assignment were done in the main routine the temp result would be
// released in the tidy up for FreeInterface after the object had been freed
// causing an AV.
// This method works in both FPC and DCC. Except in routine that call
// FreeInterface that also have a temporary reference to this interface.
a2 := a1 as IMyInterface;
end;
begin
a1 := IUnknown(X);
if not assigned(a1) then
exit;
try
// a2 := a1 as IMyInterface; // Uncomment for AV
GetIMyInterface; // Uncomment for work
except
exit;
end;
if not a2._ReferenceCounted then
begin
obj := a2.GetSelf;
a1 := nil;
a2 := nil;
obj.Free;
p := Pointer(@X);
p^ := nil;
end
else
a1 := nil;
end;
{ TMyInterfacedObjectNoRefCount }
function TMyInterfacedObjectNoRefCount._AddRef: longint; stdcall;
begin
result := -1
end;
function TMyInterfacedObjectNoRefCount._Release: longint; stdcall;
begin
result := -1
end;
function TMyInterfacedObjectNoRefCount.QueryInterface(constref IID: TGUID; out
Obj): HResult; stdcall;
const
E_NOINTERFACE = HResult($80004002);
begin
if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
end;
function TMyInterfacedObjectNoRefCount.GetSelf: TObject;
begin
result := self;
end;
function TMyInterfacedObjectNoRefCount._ReferenceCounted: boolean;
begin
result := false;
end;
{$ENDIF}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
myIntf : TMyInterface;
begin
MyIntf:=GetMyInterface;
FreeInterface(MyIntf);
end;
function TForm1.GetMyInterface: TMyOtherIntf;
begin
result := TMyClass.Create;
end;
{ TMyClass }
destructor TMyClass.Destroy;
begin
inherited Destroy;
end;
procedure TMyClass.DoSometing;
begin
end;
end.