В Delphi XE3, как я могу привести объект TVirtualInterface к его интерфейсу, используя TypeInfo или RTTI?

Question

Я пытаюсь использовать TVirtualInterface. В основном я пытался следовать примерам на вики- сайте Embarcadero и в блоге Ника Ходжеса.

Однако то, что я пытаюсь сделать, немного отличается от стандартных примеров.

Я максимально упростил следующий пример кода, чтобы проиллюстрировать, что я пытаюсь сделать. Я упустил очевидный код проверки и обработки ошибок.

program VirtualInterfaceTest;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.Generics.Collections,
  System.Rtti,
  System.SysUtils,
  System.TypInfo;

type
  ITestData = interface(IInvokable)
    ['{6042BB6F-F30C-4C07-8D3B-C123CF1FF60F}']
    function  GetComment: string;
    procedure SetComment(const Value: string);
    property  Comment: string read GetComment write SetComment;
  end;

  IMoreData = interface(IInvokable)
    ['{1D2262CE-09F4-45EC-ACD8-3EEE6B2F1548}']
    function  GetSuccess: Boolean;
    procedure SetSuccess(const Value: Boolean);
    property  Success: Boolean read GetSuccess write SetSuccess;
  end;

  TDataHolder = class
  private
    FTestData: ITestData;
    FMoreData: IMoreData;
  public
    property TestData: ITestData read FTestData write FTestData;
    property MoreData: IMoreData read FMoreData write FMoreData;
  end;

  TVirtualData = class(TVirtualInterface)
  private
    FData: TDictionary<string, TValue>;
    procedure DoInvoke(Method: TRttiMethod; 
                       const Args: TArray<TValue>; 
                       out Result: TValue);
  public
    constructor Create(PIID: PTypeInfo);
    destructor Destroy; override;
  end;

constructor TVirtualData.Create(PIID: PTypeInfo);
begin
  inherited Create(PIID, DoInvoke);
  FData := TDictionary<string, TValue>.Create;
end;

destructor TVirtualData.Destroy;
begin
  FData.Free;
  inherited Destroy;
end;

procedure TVirtualData.DoInvoke(Method: TRttiMethod; 
                                const Args: TArray<TValue>; 
                                out Result: TValue);
var
  key: string;
begin
  if (Pos('Get', Method.Name) = 1) then
  begin
    key := Copy(Method.Name, 4, MaxInt);
    FData.TryGetValue(key, Result);
  end;

  if (Pos('Set', Method.Name) = 1) then
  begin
    key := Copy(Method.Name, 4, MaxInt);
    FData.AddOrSetValue(key, Args[1]);
  end;
end;

procedure InstantiateData(obj: TObject);
var
  rttiContext:  TRttiContext;
  rttiType:     TRttiType;
  rttiProperty: TRttiProperty;
  propertyType: PTypeInfo;
  data:         IInterface;
  value:        TValue;
begin
  rttiContext := TRttiContext.Create;
  try
    rttiType := rttiContext.GetType(obj.ClassType);
    for rttiProperty in rttiType.GetProperties do
    begin
      propertyType := rttiProperty.PropertyType.Handle;
      data := TVirtualData.Create(propertyType) as IInterface;
      value := TValue.From<IInterface>(data);
      //  TValueData(value).FTypeInfo := propertyType;
      rttiProperty.SetValue(obj, value);  //  <<====  EInvalidCast
    end;
  finally
    rttiContext.Free;
  end;
end;

procedure Test_UsingDirectInstantiation;
var
  dataHolder: TDataHolder;
begin
  dataHolder := TDataHolder.Create;
  try
    dataHolder.TestData := TVirtualData.Create(TypeInfo(ITestData)) as ITestData;
    dataHolder.MoreData := TVirtualData.Create(TypeInfo(IMoreData)) as IMoreData;

    dataHolder.TestData.Comment := 'Hello World!';
    dataHolder.MoreData.Success := True;

    Writeln('Comment:  ', dataHolder.TestData.Comment);
    Writeln('Success:  ', dataHolder.MoreData.Success);
  finally
    dataHolder.Free;
  end;
end;

procedure Test_UsingIndirectInstantiation;
var
  dataHolder: TDataHolder;
begin
  dataHolder := TDataHolder.Create;
  try
    InstantiateData(dataHolder);  //  <<====

    dataHolder.TestData.Comment := 'Hello World!';
    dataHolder.MoreData.Success := False;

    Writeln('Comment:  ', dataHolder.TestData.Comment);
    Writeln('Success:  ', dataHolder.MoreData.Success);
  finally
    dataHolder.Free;
  end;
end;

begin
  try
    Test_UsingDirectInstantiation;
    Test_UsingIndirectInstantiation;
  except on E: Exception do
    Writeln(E.ClassName, ':  ', E.Message);
  end;
  Readln;
end.

У меня есть несколько произвольных интерфейсов со свойствами чтения / записи, ITestData а также IMoreData и класс, который содержит ссылки на эти интерфейсы, IDataHolder,

Я создал класс, TVirtualData что наследует от TVirtualInterface, следуя примеру Ника Ходжеса. И когда я использую этот класс, как я вижу его во всех примерах, как в Test_UsingDirectInstantiation Работает зыби.

Однако мой код должен создавать экземпляры интерфейсов более косвенным образом, как в Test_UsingIndirectInstantiation,

InstantiateData Метод использует RTTI и хорошо работает до SetValue вызов, который выбрасывает исключение EInvalidCast ("Недопустимый тип typecast").

Я добавил в закомментированную строку (которую я видел в некотором примере кода из "Delphi Sorcery"), чтобы попытаться привести объект данных к соответствующему интерфейсу. Это позволило SetValue вызов для запуска чисто, но когда я попытался получить доступ к свойству интерфейса (т.е. dataHolder.TestData.Comment) он выдал исключение EAccessViolation ("Нарушение доступа по адресу 00000000. Чтение адреса 00000000").

Ради удовольствия заменяю IInterface в InstantiateData метод с ITestData и для первого свойства он работал нормально, но, естественно, он не работал для второго свойства.

Вопрос: есть ли способ динамически разыграть это TVirtualInterface объект в соответствующий интерфейс, используя TypeInfo или RTTI (или что-то еще), так что InstantiateData метод имеет тот же эффект, что и установка свойств напрямую?

Answer 1

Сначала вы должны привести экземпляр к правильному интерфейсу, а не к IInterface. Вы все еще можете сохранить его в переменной IInterface, но он действительно содержит ссылку на правильный тип интерфейса.

Затем вы должны поместить это в TValue с правильным типом, а не с IInterface (RTTI очень строго относится к типам)

Комментируемая строка, которую вы добавили, предназначалась только для обхода второй, но поскольку она действительно содержала ссылку IInterface (а не ссылки ITestData или TMoreData), она приводила к AV.

procedure InstantiateData(obj: TObject);
var
  rttiContext:  TRttiContext;
  rttiType:     TRttiType;
  rttiProperty: TRttiProperty;
  propertyType: PTypeInfo;
  data:         IInterface;
  value:        TValue;
begin
  rttiType := rttiContext.GetType(obj.ClassType);
  for rttiProperty in rttiType.GetProperties do
  begin
    propertyType := rttiProperty.PropertyType.Handle;
    Supports(TVirtualData.Create(propertyType), TRttiInterfaceType(rttiProperty.PropertyType).GUID, data);
    TValue.Make(@data, rttiProperty.PropertyType.Handle, value);
    rttiProperty.SetValue(obj, value);
  end;
end;