在Delphi XE3中,如何使用TypeInfo或RTTI将TVirtualInterface对象转换为其接口？

我正在尝试使用TVirtualInterface.我大部分都试图在 Embarcadero doc wiki和 Nick Hodges’ blog跟随这些例子.

但是,我想要做的是与标准示例略有不同.

我尽可能简化了以下示例代码,以说明我想要做的事情.我遗漏了明显的验证和错误处理代码.

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',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.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.

我创建了一个继承自TVirtualInterface的类TVirtualData,遵循Nick Hodges的例子.当我在所有示例中看到它的方式使用这个类时,就像在Test_UsingDirectInstantiation中一样,它工作得很好.

但是,我的代码需要做的是以更间接的方式实例化接口,如Test_UsingIndirectInstantiation.

InstantiateData方法使用RTTI,并且在调用抛出EInvalidCast异常(“Invalid class typecast”)的SetValue调用之前一直运行良好.

我在注释行中添加了(我在“Delphi Sorcery”的一些示例代码中看到),试图将数据对象强制转换为适当的接口.这允许SetValue调用干净地运行,但是当我尝试访问接口属性(即dataHolder.TestData.Comment)时,它抛出了EAccessViolation异常(“地址00000000处的访问冲突.读取地址00000000”).

为了好玩,我将InstantiateData方法中的IInterface替换为ITestData,对于第一个属性,它工作得很好,但自然地,它不适用于第二个属性.

问题：有没有办法使用TypeInfo或RTTI(或其他东西)将此TVirtualInterface对象动态转换为适当的接口,以便InstantiateData方法与直接设置属性具有相同的效果？

解决方法

首先,您必须将实例强制转换为正确的接口,而不是IInterface.您仍然可以将它存储在IInterface变量中,但它确实包含对正确接口类型的引用.

然后你必须将它放入一个具有正确类型而不是IInterface的TValue(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;