如何从Delphi中的接口引用获取RTTI？

时间：2016-09-20 01:05:49

标签： delphi interface

是否可以实现这样的功能？

function GetRttiFromInterface(AIntf: IInterface; out RttiType: TRttiType): Boolean;

我有以下代码（在Firemonkey Android上）：

// Get the FWeb field of AWebBrowser, then get FJWebBrowser field of FWeb.
function GetNativeBrowserIntf(AWebBrowser: TWebBrowser): IInterface;
var
  LCtx: TRttiContext;
  LWeb: TObject;
begin
  LWeb := (LCtx.GetType(TWebBrowser).GetField('FWeb').GetValue(AWebBrowser).AsInterface as TObject);
  result := LCtx.GetType(LWeb.ClassInfo).GetField('FJWebBrowser').GetValue(LWeb).AsInterface;
end;

{ TODO : How to get rtti from an interface reference??? }
function GetRttiFromInterface(AIntf: IInterface; out RttiType: TRttiType): Boolean;
begin
  //RttiType := TRttiContext.Create.FindType('Androidapi.JNI.Embarcadero.JWebBrowser');
  //I want to get rtti from AIntf without knowing the qulified type name
  result := True;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  NativeBrowser: IInterface;
  LIntfType: TRttiType;
  LScale: Single;
begin
  // obtain native browser Interface (JWebBrowser)
  NativeBrowser := GetNativeBrowserIntf(WebBrowser1);
  // Get Rtti from this interface
  if GetRttiFromInterface(NativeBrowser, LIntfType) then
  begin
   // Invoke the getScale method of Native Browser
    LScale := LIntfType.GetMethod('getScale').Invoke(TValue.From<IInterface>(NativeBrowser), []).AsType < Single > ;
    ShowMessage('Current scale is:' + LScale.ToString);
  end;
end;

如何从没有合格类型名称的接口引用获取RTTI？

例如，我有一个名为IInterface的{​​{1}}实例。假设它的实际类型是AInterface， 我可以通过以下方式获得RTTI：

Androidapi.JNI.Embarcadero.JWebBrowser

我想要做的是在不知道其合格类型名称的情况下获取其RTTI。

对于TRttiContext.Create.FindType('Androidapi.JNI.Embarcadero.JWebBrowser'); 的实例，我可以使用：

TObject

但是对于接口的实例：

RttiType := TRttiContext.Create.GetType(AObject.ClassType);

不起作用。

2 个答案:

答案 0 :(得分：3)

在查看System.Rtti的源代码和一些测试后，我终于明白了。

据我所知，有四种可能性。

1.接口是从OLE对象中获得的。在这种情况下，强制转换AIntf as Object将抛出异常。类型为IDispatch，我可以通过

获取 
TRttiContext.Create.GetType(TypeInfo(System.IDispatch))

2.接口是从TRawVirtualClass获得的，这是一个动态创建的类。 （例如，所有原生的Android IOS和Mac界面）。 使用AIntf as TObject将接口转换为TRawVirtualClass对象，然后使用rtti获取此对象的FIIDs字段，它的类型为TArray<TGUID>，第一个元素是这个接口的GUID。（那就是它的祖先接口）。我们可以通过GUID获得它的RTTI。

3.界面来自TVirtualInterface。使用AIntf as TObject将其投放到TVirtualInterface个实例，然后获取FIID字段（TGUID类型）。

4.界面从Delphi对象获得。使用@Remy Lebeau的答案。

我写了一个TInterfaceHelper：

unit InterfaceHelper;

interface

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

type
  TInterfaceHelper = record
  strict private
  type
    TInterfaceTypes = TDictionary<TGUID, TRttiInterfaceType>;

    class var FInterfaceTypes: TInterfaceTypes;
    class var Cached: Boolean;
    class var Caching: Boolean;
    class procedure WaitIfCaching; static;
    class procedure CacheIfNotCachedAndWaitFinish; static;
    class constructor Create;
    class destructor Destroy;
  public
    // refresh cached RTTI in a background thread  (eg. when new package is loaded)
    class procedure RefreshCache; static;

    // get RTTI from interface
    class function GetType(AIntf: IInterface): TRttiInterfaceType;
      overload; static;
    class function GetType(AGUID: TGUID): TRttiInterfaceType; overload; static;
    class function GetType(AIntfInTValue: TValue): TRttiInterfaceType;
      overload; static;

    // get type name from interface
    class function GetTypeName(AIntf: IInterface): String; overload; static;
    class function GetTypeName(AGUID: TGUID): String; overload; static;
    class function GetQualifiedName(AIntf: IInterface): String;
      overload; static;
    class function GetQualifiedName(AGUID: TGUID): String; overload; static;

    // get methods
    class function GetMethods(AIntf: IInterface): TArray<TRttiMethod>; static;
    class function GetMethod(AIntf: IInterface; const MethodName: String)
      : TRttiMethod; static;

    // Invoke method
    class function InvokeMethod(AIntf: IInterface; const MethodName: String;
      const Args: array of TValue): TValue; overload; static;
    class function InvokeMethod(AIntfInTValue: TValue; const MethodName: String;
      const Args: array of TValue): TValue; overload; static;
  end;

implementation

uses System.Classes,
  System.SyncObjs, DUnitX.Utils;

{ TInterfaceHelper }

class function TInterfaceHelper.GetType(AIntf: IInterface): TRttiInterfaceType;
var
  ImplObj: TObject;
  LGUID: TGUID;
  LIntfType: TRttiInterfaceType;
  TempIntf: IInterface;
begin
  Result := nil;

  try
    // As far as I know, the cast will fail only when AIntf is obatined from OLE Object
    // Is there any other cases?
    ImplObj := AIntf as TObject;
  except
    // for interfaces obtained from OLE Object
    Result := TRttiContext.Create.GetType(TypeInfo(System.IDispatch))
      as TRttiInterfaceType;
    Exit;
  end;

  // for interfaces obtained from TRawVirtualClass (for exmaple IOS & Android & Mac interfaces)
  if ImplObj.ClassType.InheritsFrom(TRawVirtualClass) then
  begin
    LGUID := ImplObj.GetField('FIIDs').GetValue(ImplObj).AsType < TArray <
      TGUID >> [0];
    Result := GetType(LGUID);
  end
  // for interfaces obtained from TVirtualInterface
  else if ImplObj.ClassType.InheritsFrom(TVirtualInterface) then
  begin
    LGUID := ImplObj.GetField('FIID').GetValue(ImplObj).AsType<TGUID>;
    Result := GetType(LGUID);
  end
  else
  // for interfaces obtained from Delphi object
  // The code is taken from Remy Lebeau's answer at http://stackoverflow.com/questions/39584234/how-to-obtain-rtti-from-an-interface-reference-in-delphi/
  begin
    for LIntfType in (TRttiContext.Create.GetType(ImplObj.ClassType)
      as TRttiInstanceType).GetImplementedInterfaces do
    begin
      if ImplObj.GetInterface(LIntfType.GUID, TempIntf) then
      begin
        if AIntf = TempIntf then
        begin
          Result := LIntfType;
          Exit;
        end;
      end;
    end;
  end;
end;

class constructor TInterfaceHelper.Create;
begin
  FInterfaceTypes := TInterfaceTypes.Create;
  Cached := False;
  Caching := False;
  RefreshCache;
end;

class destructor TInterfaceHelper.Destroy;
begin
  FInterfaceTypes.DisposeOf;
end;

class function TInterfaceHelper.GetQualifiedName(AIntf: IInterface): String;
var
  LType: TRttiInterfaceType;
begin
  Result := string.Empty;
  LType := GetType(AIntf);
  if Assigned(LType) then
    Result := LType.QualifiedName;
end;

class function TInterfaceHelper.GetMethod(AIntf: IInterface;
  const MethodName: String): TRttiMethod;
var
  LType: TRttiInterfaceType;
begin
  Result := nil;
  LType := GetType(AIntf);
  if Assigned(LType) then
    Result := LType.GetMethod(MethodName);
end;

class function TInterfaceHelper.GetMethods(AIntf: IInterface)
  : TArray<TRttiMethod>;
var
  LType: TRttiInterfaceType;
begin
  Result := [];
  LType := GetType(AIntf);
  if Assigned(LType) then
    Result := LType.GetMethods;
end;

class function TInterfaceHelper.GetQualifiedName(AGUID: TGUID): String;
var
  LType: TRttiInterfaceType;
begin
  Result := string.Empty;
  LType := GetType(AGUID);
  if Assigned(LType) then
    Result := LType.QualifiedName;
end;

class function TInterfaceHelper.GetType(AGUID: TGUID): TRttiInterfaceType;
begin
  CacheIfNotCachedAndWaitFinish;
  Result := FInterfaceTypes.Items[AGUID];
end;

class function TInterfaceHelper.GetTypeName(AGUID: TGUID): String;
var
  LType: TRttiInterfaceType;
begin
  Result := string.Empty;
  LType := GetType(AGUID);
  if Assigned(LType) then
    Result := LType.Name;
end;

class function TInterfaceHelper.InvokeMethod(AIntfInTValue: TValue;
  const MethodName: String; const Args: array of TValue): TValue;
var
  LMethod: TRttiMethod;
  LType: TRttiInterfaceType;
begin
  LType := GetType(AIntfInTValue);
  if Assigned(LType) then
    LMethod := LType.GetMethod(MethodName);
  if not Assigned(LMethod) then
    raise Exception.Create('Method not found');
  Result := LMethod.Invoke(AIntfInTValue, Args);
end;

class function TInterfaceHelper.InvokeMethod(AIntf: IInterface;
  const MethodName: String; const Args: array of TValue): TValue;
var
  LMethod: TRttiMethod;
begin
  LMethod := GetMethod(AIntf, MethodName);
  if not Assigned(LMethod) then
    raise Exception.Create('Method not found');
  Result := LMethod.Invoke(TValue.From<IInterface>(AIntf), Args);
end;

class function TInterfaceHelper.GetTypeName(AIntf: IInterface): String;
var
  LType: TRttiInterfaceType;
begin
  Result := string.Empty;
  LType := GetType(AIntf);
  if Assigned(LType) then
    Result := LType.Name;
end;

class procedure TInterfaceHelper.RefreshCache;
var
  LTypes: TArray<TRttiType>;
begin
  WaitIfCaching;

  FInterfaceTypes.Clear;
  Cached := False;
  Caching := True;
  TThread.CreateAnonymousThread(
    procedure
    var
      LType: TRttiType;
      LIntfType: TRttiInterfaceType;
    begin
      LTypes := TRttiContext.Create.GetTypes;

      for LType in LTypes do
      begin
        if LType.TypeKind = TTypeKind.tkInterface then
        begin
          LIntfType := (LType as TRttiInterfaceType);
          if TIntfFlag.ifHasGuid in LIntfType.IntfFlags then
          begin
            FInterfaceTypes.AddOrSetValue(LIntfType.GUID, LIntfType);
          end;
        end;
      end;

      Caching := False;
      Cached := True;
    end).Start;
end;

class procedure TInterfaceHelper.WaitIfCaching;
begin
  if Caching then
    TSpinWait.SpinUntil(
      function: Boolean
      begin
        Result := Cached;
      end);
end;

class procedure TInterfaceHelper.CacheIfNotCachedAndWaitFinish;
begin
  if Cached then
    Exit
  else if not Caching then
  begin
    RefreshCache;
    WaitIfCaching;
  end
  else
    WaitIfCaching;
end;

class function TInterfaceHelper.GetType(AIntfInTValue: TValue)
  : TRttiInterfaceType;
var
  LType: TRttiType;
begin
  Result := nil;
  LType := AIntfInTValue.RttiType;
  if LType is TRttiInterfaceType then
    Result := LType as TRttiInterfaceType;
end;

end.

然后：

uses InterfaceHelper;

function GetRttiFromInterface(AIntf: IInterface; out RttiType: TRttiType): Boolean;
begin
  RttiType := TInterfaceHelper.GetType(AIntf);
  Result := Assigned(RttiType);
end;

答案 1 :(得分：1)

你所要求的并不是直截了当的，但它是可能的。

首先，将interface参数转换回其实现对象。在Delphi 2010及更高版本中，您可以使用as运算符（对于早期版本，this blog说明如何手动执行此操作。）

获得实现对象后，可以使用其RTTI找出参数指向的确切接口类型，然后从中找到该类型的RTTI。

但是，这仅在接口由TObject派生类实现并且为其分配了GUID时才有效。

例如：

uses
  System.Rtti;

function GetRttiFromInterface(AIntf: IInterface; out RttiType: TRttiType): Boolean;
var
  obj: TObject;
  IntfType: TRttiInterfaceType;
  ctx: TRttiContext;
  tmpIntf: IInterface;
begin
  Result := False;

  // get the implementing object...
  obj := AIntf as TObject;

  // enumerate the object's interfaces, looking for the
  // one that matches the input parameter...
  for IntfType in (ctx.GetType(obj.ClassType) as TRttiInstanceType).GetImplementedInterfaces do
  begin
    if obj.GetInterface(IntfType.GUID, tmpIntf) then
    begin
      if AIntf = tmpIntf then
      begin
        RttiType := IntfType;
        Result := True;
        Exit;
      end;
      tmpIntf := nil;
    end;
  end;
end;

验证：

uses
  System.Classes, Vcl.Dialogs;

type
  ITest1 = interface
    ['{5AB029F5-31B0-4054-A70D-75BF8278716E}']
    procedure Test1;
  end;

  ITest2 = interface
    ['{AAC18D39-465B-4706-9DC8-7B1FBCC05B2B}']
    procedure Test1;
  end;

  TTest = class(TInterfacedObject, ITest1, ITest2)
  public
    procedure Test1;
    procedure Test2;
  end;

procedure TTest.Test1;
begin
  //...
end;

procedure TTest.Test2;
begin
  //...
end;

var
  Intf1: ITest1;
  Intf2: ITest2;
  RttiType: TRttiType;
begin
  Intf1 := TTest.Create as ITest1;
  Intf2 := TTest.Create as ITest2;
  GetRttiFromInterface(Intf1, RttiType);
  ShowMessage(RttiType.Name); // shows 'ITest1'
  GetRttiFromInterface(Intf2, RttiType);
  ShowMessage(RttiType.Name); // shows 'ITest2'
end;
相关问题
最新问题