In Delphi is it possible to bind an interface to an object that doesn't implement it

Question

I know Delphi XE2 has the new TVirtualInterface for creating implementations of an interface at runtime. Unfortunately I am not using XE2 and I\'m wondering what kind of hackery

Answer 1

Adding support for an interface to an existing class at runtime can theoretically be done, but it would be really tricky, and it would require D2010 or later for RTTI support.

Each class has a VMT, and the VMT has an interface table pointer. (See the implementation of TObject.GetInterfaceTable.) The interface table contains interface entries, which contain some metadata, including the GUID, and a pointer to the interface vtable itself. If you really wanted to, you could create a copy of the interface table, (DO NOT do this the original one; you're likely to end up corrupting memory!) add a new entry to it containing a new interface vtable with the pointers pointing to the correct methods, (which you could match by looking them up with RTTI,) and then change the class's interface table pointer to point to the new table.

Be very careful. This sort of work is really not for the faint of heart, and it seems to me it's of kind of limited utility. But yes, it's possible.

Answer 2

I'm not sure, what you want to accomplish and why you want to dynamically bind that interface, but here is a way to do it (don't know if it fits your need):

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;

And this is the corresponding test code:

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;