В Delphi можно связать интерфейс с объектом, который его не реализует

Я знаю, что у Delphi XE2 есть новый TVirtualInterface для создания реализаций интерфейса во время выполнения. К сожалению, я не использую XE2, и мне интересно, какой хакеры участвуют в подобных вещах в более старых версиях Delphi.

Допустим, у меня есть следующий интерфейс:

  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. (к счастью, Эмбакадеро решил оставить источник паскаля вместе с оптимизированной сборкой). Я, возможно, не читаю его правильно, но кажется, что могут быть записи интерфейса со смещением нуля, и в этом случае есть альтернативный способ назначения интерфейса с помощью InvokeImplGetter.

Моя конечная цель - имитировать некоторые возможности динамических прокси и макетов, которые доступны на языках с поддержкой рефлексии. Если я могу успешно привязать объект, который имеет те же имена методов и подписи, что и интерфейс, это будет большой первый шаг. Возможно ли это, или я лаяю неправильное дерево?

Ответ 1

Добавление поддержки интерфейса к существующему классу во время выполнения теоретически может быть выполнено, но это будет очень сложно, и для поддержки RTTI потребуется D2010 или более поздняя версия.

Каждый класс имеет VMT, а VMT имеет указатель таблицы интерфейса. (См. Реализацию TObject.GetInterfaceTable.) Таблица интерфейсов содержит записи интерфейса, которые содержат некоторые метаданные, включая GUID, и указатель на интерфейс vtable непосредственно. Если бы вы действительно захотели, вы могли бы создать копию таблицы интерфейсов (НЕ делайте это оригинал, вы, скорее всего, закончите повреждение памяти!) Добавьте новую запись в нее, содержащую новый интерфейс vtable с указателями указывая на правильные методы (которые вы могли бы сопоставить, просмотрев их с помощью RTTI), а затем измените указатель таблицы интерфейса класса, чтобы указать на новую таблицу.

Будьте очень осторожны. Эта работа действительно не для слабонервных, и мне кажется, что это какая-то ограниченная полезность. Но да, это возможно.

Ответ 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;