在Delphi中,可以将接口绑定到不实现它的对象

Question

我知道Delphi XE2有新的TVirtualInterface用于在运行时创建接口的实现.不幸的是我没有使用XE2,我想知道在旧版本的Delphi中做这种事情会涉及到什么样的hackery.

可以说我有以下界面:

  IMyInterface = interface
  ['{8A827997-0058-4756-B02D-8DCDD32B7607}']
    procedure Go;
  end;

是否可以在运行时绑定到此接口而无需编译器的帮助？

TMyClass = class(TObject, IInterface)
public
  function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  function _AddRef: Integer; stdcall;
  function _Release: Integer; stdcall;
  procedure Go; //I want to dynamically bind IMyInterface.Go here
end;

我尝试过一个简单的强硬演员:

var MyInterface: IMyInterface;
begin
  MyInterface := IMyInterface(TMyClass.Create);
end;

但编译器会阻止这种情况.

然后我尝试了一个as演员,它至少编译:

MyInterface := TMyClass.Create as IMyInterface;

所以我想关键是QueryInterface返回一个有效的指针,指向正在查询的接口的实现.我如何在运行时构建一个？

我已经通过System.pas挖,所以我至少依稀熟悉如何GetInterface,GetInterfaceEntry和InvokeImplGetter工作.(幸好Embacadero选择将pascal源与优化的组件一起留下).我可能没有正确阅读它,但似乎可以有偏移量为零的接口条目,在这种情况下,有一种替代方法可以使用分配接口InvokeImplGetter.

我的最终目标是模拟具有反射支持的语言中可用的动态代理和模拟的一些功能.如果我可以成功绑定到具有与接口相同的方法名称和签名的对象,那么这将是一个很大的第一步.这甚至可能还是我在错误的树上吠叫？

Answer 1

理论上可以在运行时添加对现有类的接口的支持,但这将非常棘手,并且需要D2010或更高版本才能支持RTTI.

每个类都有一个VMT,VMT有一个接口表指针.(请参阅TObject.GetInterfaceTable的实现.)接口表包含接口条目,其中包含一些元数据,包括GUID和指向接口vtable本身的指针.如果你真的想要,你可以创建一个接口表的副本,(不要这样做原来的;你可能最终破坏内存!)添加一个新的条目包含一个新的接口vtable与指针指向正确的方法(通过RTTI查找它们可以匹配),然后将类的接口表指针更改为指向新表.

要非常小心.这种工作真的不适合胆小的人,而且在我看来它的实用性有限.但是,是的,这是可能的.

Answer 2

我不确定,你想要完成什么以及为什么要动态绑定该接口,但这是一种方法(不知道它是否符合你的需要):

type
  IMyInterface = interface
  ['{8A827997-0058-4756-B02D-8DCDD32B7607}']
    procedure Go;
  end;

  TMyClass = class(TInterfacedObject, IInterface)
  private
    FEnabled: Boolean;
  protected
    property Enabled: Boolean read FEnabled;
  public
    constructor Create(AEnabled: Boolean);
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    procedure Go; //I want to dynamically bind IMyInterface.Go here
  end;

  TMyInterfaceWrapper = class(TAggregatedObject, IMyInterface)
  private
    FMyClass: TMyClass;
  protected
    property MyClass: TMyClass read FMyClass implements IMyInterface;
  public
    constructor Create(AMyClass: TMyClass);
  end;

constructor TMyInterfaceWrapper.Create(AMyClass: TMyClass);
begin
  inherited Create(AMyClass);
  FMyClass := AMyClass;
end;

constructor TMyClass.Create(AEnabled: Boolean);
begin
  inherited Create;
  FEnabled := AEnabled;
end;

procedure TMyClass.Go;
begin
  ShowMessage('Go');
end;

function TMyClass.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if Enabled and (IID = IMyInterface) then begin
    IMyInterface(obj) := TMyInterfaceWrapper.Create(Self);
    result := 0;
  end
  else begin
    if GetInterface(IID, Obj) then
      Result := 0
    else
      Result := E_NOINTERFACE;
  end;
end;

这是相应的测试代码:

var
  intf: IInterface;
  my: IMyInterface;
begin
  intf := TMyClass.Create(false);
  if Supports(intf, IMyInterface, my) then
    ShowMessage('wrong');

  intf := TMyClass.Create(true);
  if Supports(intf, IMyInterface, my) then
    my.Go;
end;