In Delphi XE3, how can I cast a TVirtualInterface object to its interface, using TypeInfo or RTTI?

Question

I'm trying to use TVirtualInterface. I've mostly tried to follow the examples at the Embarcadero doc wiki and at Nick Hodges' blog.

However, What I'm trying to do is a little bit different from the standard examples.

I have simplified the following sample code as much as I can to illustrate what I am trying to do. I have left out obvious validation and error handling code.

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.

I have some arbitrary interfaces with read/write properties, ITestData and IMoreData, and a class that holds references to these interfaces, IDataHolder.

I have created a class, TVirtualData, that inherits from TVirtualInterface, following Nick Hodges' examples. And when I use this class the way I see it in all the examples, as in Test_UsingDirectInstantiation, it works swell.

What my code needs to do, however, is instantiate the interfaces in a more indirect manner, as in Test_UsingIndirectInstantiation.

The InstantiateData method uses RTTI, and works well up until the SetValue call which throws an EInvalidCast exception ("Invalid class typecast").

I added in the commented line (which I saw in some sample code from "Delphi Sorcery") to try to cast the data object to the appropriate interface. This allowed the SetValue call to run cleanly, but when I tried to access the interface property (i.e. dataHolder.TestData.Comment) it threw a EAccessViolation exception ("Access violation at address 00000000. Read of address 00000000").

For fun I replace IInterface in the InstantiateData method with ITestData, and for the first property it worked fine, but naturally, it didn't work for the second property.

Question: Is there a way to dynamically cast this TVirtualInterface object to the appropriate interface using TypeInfo or RTTI (or something else) so that the InstantiateData method has the same effect as setting the properties directly?

Answer 1

First you have to cast the instance to the correct interface and not IInterface. You can still store it in an IInterface variable though but it really containes the reference to the correct interface type.

Then you have to put that into a TValue with the correct type and not IInterface (RTTI is very strict about types)

The commented line you added was just to work around the second but as it was really containing the IInterface reference (and not a ITestData or TMoreData references) it resulted on the 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;