delphi - 如何从Delphi中的接口(interface)引用获取RTTI？

Question

这样的功能可以实现吗？

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;    

如何在没有限定类型名称的情况下从接口(interface)引用获取 RTTI？

例如，我有一个名为 AInterface 的 IInterface 实例。假设其实际类型为Androidapi.JNI.Embarcadero.JWebBrowser，我可以通过以下方式获取其 RTTI:

TRttiContext.Create.FindType('Androidapi.JNI.Embarcadero.JWebBrowser');

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

对于 TObject 的实例，我可以使用:

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

但是对于接口(interface)实例:

RttiType := TRttiContext.Create.GetType(AInterface);   

不起作用。

Answer 1

查看System.Rtti的源代码后和一些测试，我终于让它工作了。

据我所知，有四种可能。

1.接口(interface)是从OLE对象中获取的。在这种情况下， Actor AIntf as Object会抛出异常。类型为IDispatch ，我可以通过

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

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

3.接口(interface)获取自TVirtualInterface 。使用AIntf as TObject将其转换到 TVirtualInterface实例，然后获取其 FIID字段(TGUID 类型)。

4.从Delphi对象中获取接口(interface)。使用@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;