在 Delphi 中获取接口引用的 GUID
Get the GUID of an interface reference in Delphi
我想获取接口参考信息。
当我在调试时将鼠标移到接口引用上时，IDE 可以显示例如 'TMyObject(64933A) as IMyInterface'，我想打印出与我的引用类似的内容（这似乎乱七八糟） .
所以，基本上，我想打电话给
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);
...
并使用 TypeInfo 查找有关接口类型的更多信息。
在现实世界中，'I' 只是任何接口指针。由于 TypeInfo 需要类型而不是实例，因此这是不可能的。
因此，我尝试使用 Hallvard 的旧技巧，如 http://hallvards.blogspot.com/2006/09/hack11-get-guid-of-interface-reference.html
中所述
这会给我 IID，然后我可以用它来获取更多信息。然而，虽然 运行 Delphi 10.2 中的代码，它似乎不再起作用了。
我遇到的第一个问题是当我调用下面的方法时：
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;
无论我使用哪个变量调用方法，引用 'I' 总是 'IInterface'。
二、测试应用
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));
...
给我一个访问冲突。
显然，class 和界面内部结构的细节自 2006 年以来发生了变化。
那么谁能提供该代码的工作版本或其他方法来获取有关接口引用的信息？
E: 明确了目标和失败的地方
好的，我把它拼凑起来了，包括我正在寻找的方法：
function InterfaceTypeInfo(const Intf: IInterface): PTypeInfo;
以下是一个完整的测试程序，包括例程
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 = 244483; // opcode for ADD DWORD PTR [ESP+4], Shortint
AddLong = 244481; // 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.
打印出
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(067E8) as IInterfaceComponentReference
E: 引入 IntfTypeInfoCache 优化搜索。
E: NativeInt(MyInterface)，而不是测试代码中的 Integer(MyInterface)
我想获取接口参考信息。
当我在调试时将鼠标移到接口引用上时，IDE 可以显示例如 'TMyObject(64933A) as IMyInterface'，我想打印出与我的引用类似的内容（这似乎乱七八糟） .
所以，基本上，我想打电话给
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);
...
并使用 TypeInfo 查找有关接口类型的更多信息。
在现实世界中，'I' 只是任何接口指针。由于 TypeInfo 需要类型而不是实例，因此这是不可能的。
因此，我尝试使用 Hallvard 的旧技巧，如 http://hallvards.blogspot.com/2006/09/hack11-get-guid-of-interface-reference.html
中所述这会给我 IID，然后我可以用它来获取更多信息。然而，虽然 运行 Delphi 10.2 中的代码，它似乎不再起作用了。
我遇到的第一个问题是当我调用下面的方法时：
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;
无论我使用哪个变量调用方法，引用 'I' 总是 'IInterface'。
二、测试应用
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));
...
给我一个访问冲突。
显然，class 和界面内部结构的细节自 2006 年以来发生了变化。
那么谁能提供该代码的工作版本或其他方法来获取有关接口引用的信息？
E: 明确了目标和失败的地方
好的，我把它拼凑起来了，包括我正在寻找的方法：
function InterfaceTypeInfo(const Intf: IInterface): PTypeInfo;
以下是一个完整的测试程序，包括例程
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 = 244483; // opcode for ADD DWORD PTR [ESP+4], Shortint
AddLong = 244481; // 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.
打印出
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(067E8) as IInterfaceComponentReference
E: 引入 IntfTypeInfoCache 优化搜索。
E: NativeInt(MyInterface)，而不是测试代码中的 Integer(MyInterface)