Get the GUID of an interface reference in Delphi

I would like to get information of an interface reference.

The IDE can display for example 'TMyObject($5864933A) as IMyInterface' when I move the mouse over an interface reference while debugging and I would like to print out something similar of my references (which seem to go haywire).

So, basically, I would like to call

type
  IMyInterface = interface
    ['{ABDA7685-DB67-43C1-947F-4B9535142355}']
  end;
  TMyObject = class(TInterfacedObject, IMyInterface)
  end;  
var
  T: PTypeInfo;
  I: IMyInterface;
begin
  I := TMyObject.Create;
  T := TypeInfo(I);
  ...

and use the TypeInfo to find out more about the interface type.

In real world, 'I' would be just any interface pointer. Since TypeInfo requires a type and not an instance, this is not possible.

So, I tried to use the old hack by Hallvard as described at http://hallvards.blogspot.com/2006/09/hack11-get-guid-of-interface-reference.html

That would give me the IID, which I could then use to fetch more information. However, while running the code in Delphi 10.2, it doesn't seem to work any more.

First problem I encountered is that when I call the following method:

function GetInterfaceIID(const I: IInterface; var IID: TGUID): boolean;
var
  InterfaceEntry: PInterfaceEntry;
begin
  InterfaceEntry := GetInterfaceEntry(I);
  Result := Assigned(InterfaceEntry);
  if Result then
    IID := InterfaceEntry.IID;
end;

the reference 'I' is always 'IInterface' no matter with which variable I call the method.

Second, the test application

var
  MyInterface: IMyInterface;
  Unknown: IUnknown;
  Instance: TObject;
  IID: TGUID;
begin
  MyInterface := TMyObject.Create;
  // Instance := GetImplementingObject(MyInterface); // not necessary since D2010
  // Writeln(Instance.ClassName);
  if GetInterfaceIID(MyInterface, IID) then // Results in Access Violation
    writeln('MyInterface IID = ', GUIDToString(IID));

  ...

gives me an access violations.

Apparently, the details of the class and interface internals have changed since 2006.

So could anyone provide a working version of that code or some other means to get out information about the interface reference?

E: Clarified the target and what fails

Solution

OK, I managed to put it together, including the method I was searching for:

function InterfaceTypeInfo(const Intf: IInterface): PTypeInfo;

The following is a complete test program, including the routines

program TestInterfaceTypeInfo;

{$APPTYPE CONSOLE}

{$IF CompilerVersion >= 20.0}
// Requires TDictionary, which was introduced in Delphi 2009
{$DEFINE INTF_TYPEINFO_CACHE}
{$IFEND}

uses
  SysUtils,
  TypInfo,
  Rtti,
{$IFDEF INTF_TYPEINFO_CACHE}
  System.Generics.Collections,
{$ENDIF}
  Classes;

// *** A set of routines to help finding the TypeInfo for an interface reference

// The following functionality is slightly modified version of
// http://hallvards.blogspot.com/2006/09/hack11-get-guid-of-interface-reference.html

{$IFDEF INTF_TYPEINFO_CACHE}
var
  // Optimized mapping of TGUID to TypeInfo
  IntfTypeInfoCache: TDictionary<TGUID, PTypeInfo> = nil;
{$ENDIF}

function GetPIMTOffset(const I: IInterface): integer;
// PIMT = Pointer to Interface Method Table
const
  AddByte = $04244483; // opcode for ADD DWORD PTR [ESP+4], Shortint
  AddLong = $04244481; // opcode for ADD DWORD PTR [ESP+4], Longint
type
  PAdjustSelfThunk = ^TAdjustSelfThunk;
  TAdjustSelfThunk = packed record
    case AddInstruction: longint of
      AddByte : (AdjustmentByte: shortint);
      AddLong : (AdjustmentLong: longint);
  end;
  PInterfaceMT = ^TInterfaceMT;
  TInterfaceMT = packed record
    QueryInterfaceThunk: PAdjustSelfThunk;
  end;
  TInterfaceRef = ^PInterfaceMT;
var
  QueryInterfaceThunk: PAdjustSelfThunk;
begin
  Result := -1;
  if Assigned(Pointer(I)) then
    try
      QueryInterfaceThunk := TInterfaceRef(I)^.QueryInterfaceThunk;
      case QueryInterfaceThunk.AddInstruction of
        AddByte: Result := -QueryInterfaceThunk.AdjustmentByte;
        AddLong: Result := -QueryInterfaceThunk.AdjustmentLong;
      end;
    except
      // Protect against non-Delphi or invalid interface references
    end;
end;

{$IF CompilerVersion < 21.0}
function GetImplementingObject(const I: IInterface): TObject;
var
  Offset: integer;
begin
  Offset := GetPIMTOffset(I);
  if Offset > 0
  then Result := TObject(PChar(I) - Offset)
  else Result := nil;
end;
{$IFEND}

function GetInterfaceEntry(const I: IInterface): PInterfaceEntry;
var
  Offset: integer;
  Instance: TObject;
  InterfaceTable: PInterfaceTable;
  j: integer;
  CurrentClass: TClass;
begin
  Offset := GetPIMTOffset(I);
  Instance :=
{$IF CompilerVersion >= 21.0}
    I as TObject;
{$ELSE}
    GetImplementingObject(I);
{$IFEND}
  if (Offset >= 0) and Assigned(Instance) then
  begin
    CurrentClass := Instance.ClassType;
    while Assigned(CurrentClass) do
    begin
      InterfaceTable := CurrentClass.GetInterfaceTable;
      if Assigned(InterfaceTable) then
        for j := 0 to InterfaceTable.EntryCount-1 do
        begin
          Result := @InterfaceTable.Entries[j];
          if Result.IOffset = Offset then
            Exit;
        end;
      CurrentClass := CurrentClass.ClassParent
    end;
  end;
  Result := nil;
end;

// Finds the IID of an interface
function GetInterfaceIID(const I: IInterface; var IID: TGUID): Boolean;
var
  InterfaceEntry: PInterfaceEntry;
begin
  InterfaceEntry := GetInterfaceEntry(I);
  Result := Assigned(InterfaceEntry);
  if Result then
    IID := InterfaceEntry.IID;
end;

// Finds the TypeInfo corresponding to IID of an interface
function InterfaceTypeInfoOfGUID(const IID: TGUID): PTypeInfo;
var
  Context : TRttiContext;
  ItemType : TRttiType;
  T: TRttiInterfaceType;
begin
  Result := nil;
{$IFDEF INTF_TYPEINFO_CACHE}
  if not Assigned(IntfTypeInfoCache) then
  begin
    IntfTypeInfoCache := TDictionary<TGUID, PTypeInfo>.Create;
{$ENDIF}
    for ItemType in Context.GetTypes do
    begin
      if ItemType is TRttiInterfaceType then
      begin
       T := TRttiInterfaceType(ItemType);
       if T.GUID = IID then
{$IFDEF INTF_TYPEINFO_CACHE}
         Result := T.Handle;
       IntfTypeInfoCache.AddOrSetValue(T.GUID, T.Handle);
{$ELSE}
         Exit(T.Handle);
{$ENDIF}
      end
    end;
{$IFDEF INTF_TYPEINFO_CACHE}
  end;
  if not Assigned(Result) then
    IntfTypeInfoCache.TryGetValue(IID, Result);
{$ENDIF}
end;

// Finds the TypeInfo for an interface reference
function InterfaceTypeInfo(const Intf: IInterface): PTypeInfo;
var
  IID: TGUID;
begin
  if GetInterfaceIID(Intf, IID) then
    Result := InterfaceTypeInfoOfGUID(IID)
  else
    Result := nil;
end;

// Test with an interface that is globally defined, such as
// IInterfaceComponentReference

var
  MyInterface: IInterfaceComponentReference;
  Unknown: IUnknown;
  Instance: TObject;
  IID: TGUID;
  T: PTypeInfo;
begin
  MyInterface := TComponent.Create(nil);
  if GetInterfaceIID(MyInterface, IID) then
    writeln('MyInterface IID = ', GUIDToString(IID));
  Unknown := MyInterface;
  if GetInterfaceIID(Unknown, IID) then
    writeln('Derived IUnknown IID = ', GUIDToString(IID));
  Unknown := TComponent.Create(nil);
  if GetInterfaceIID(Unknown, IID) then
    writeln('Pure IUnknown IID = ', GUIDToString(IID));
  T := InterfaceTypeInfo(MyInterface);
  if Assigned(T) then
  begin
    writeln('TypeInfo = ', T.Name, GUIDToString(T.TypeData.GUID));
    writeln(Format('%s($%x) as %s',
      // will also need to use GetImplementingObject instead of 'as' prior to Delphi 2010
      [(MyInterface as TObject).ClassName, NativeInt(MyInterface), T.Name])); 
  end;
  readln;
{$IFDEF INTF_TYPEINFO_CACHE}
  IntfTypeInfoCache.Free;
{$ENDIF}
end.

which prints out

MyInterface IID = {E28B1858-EC86-4559-8FCD-6B4F824151ED}
Derived IUnknown IID = {E28B1858-EC86-4559-8FCD-6B4F824151ED}
Pure IUnknown IID = {00000000-0000-0000-C000-000000000046}
TypeInfo = IInterfaceComponentReference{E28B1858-EC86-4559-8FCD-6B4F824151ED}
TComponent($20067E8) as IInterfaceComponentReference

E: Introduced IntfTypeInfoCache to optimize the search.

E: NativeInt(MyInterface), instead of Integer(MyInterface) in test code