W Delphi XE3, jak mogę rzucić obiekt TVirtualInterface do jego interfejsu, używając TypeInfo lub RTTI?

Question

Próbuję użyć TVirtualInterface. Najczęściej starałem się podążać za przykładami pod numerami Embarcadero doc wiki i Nick Hodges' blog.

Jednak to, co próbuję zrobić, różni się nieco od standardowych przykładów.

Uproszyłem poniższy kod przykładowy tak bardzo, jak to tylko możliwe, aby zilustrować to, co próbuję wykonać. Usunąłem oczywisty kod sprawdzania poprawności i obsługi błędów.

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. 

Mam kilka dowolnych interfejsów z właściwościami odczytu/zapisu, ITestData i IMoreData i klasy, która posiada odniesienia do tych interfejsów, IDataHolder.

Utworzyłem klasę, TVirtualData, która dziedziczy po TVirtualInterface, według przykładów Nicka Hodgesa. I kiedy używam tej klasy w sposób, jaki widzę we wszystkich przykładach, jak w Test_UsingDirectInstantiation, działa ona pęcznieje.

Tym, czego potrzebuje mój kod, jest jednak utworzenie interfejsu w bardziej pośredni sposób, jak w przypadku Test_UsingIndirectInstantiation.

Metoda InstantiateData używa RTTI i działa dobrze aż do wywołania SetValue, które zgłasza wyjątek EInvalidCast ("Nieprawidłowa typografia klasy").

Dodałem w skomentowanym wierszu (który widziałem w przykładowym kodzie z "Czarów Delphi"), aby spróbować rzucić obiekt danych do odpowiedniego interfejsu. Pozwoliło to na czyste wywołanie SetValue, ale gdy próbowałem uzyskać dostęp do właściwości interfejsu (tj. dataHolder.TestData.Comment), zgłoszono wyjątek wyjątku dotyczącego naruszenia praw dostępu ("Naruszenie dostępu pod adresem 00000000. Odczyt adresu 00000000").

Dla zabawy zastąpić IInterface w metodzie InstantiateData z ITestData, a dla pierwszego obiektu to działało dobrze, ale oczywiście to nie działa na drugim nieruchomości.

Pytanie: Czy istnieje sposób dynamicznie rzucić ten TVirtualInterface obiektu do odpowiedniego interfejsu lub przy użyciu TypeInfo RTTI (lub coś innego) tak, że metoda InstantiateData ma taki sam efekt jak ustawienie właściwości bezpośrednio?

Answer 1

Najpierw należy rzucić instancję do właściwego interfejsu, a nie do interfejsu. Nadal można go przechowywać w zmiennej IInterface, ale naprawdę zawiera odniesienie do właściwego typu interfejsu.

Następnie trzeba umieścić, że w TValue z odpowiedniego typu i nie IInterface (RTTI jest bardzo surowe o typach)

komentowanym linia została dodana po prostu obejść drugi, ale jak to było naprawdę zawierającego odwołanie do interfejsu IInterface (a nie odwołania do ITestData lub TMoreData) wynikało z 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;