TVirtualInterface 失败，接口包含“对象功能”属性

Question

我有接口：

TOnIntegerValue: function: integer of object;

ITestInterface = interface(IInvokable)
  ['{54288E63-E6F8-4439-8466-D3D966455B8C}']
  function GetOnIntegerValue: TOnIntegerValue;
  procedure SetOnIntegerValue(const Value: TOnIntegerValue);
  property OnIntegerValue: TOnIntegerValue read GetOnIntegerValue 
    write SetOnIntegerValue;
end;

在我的测试中我有：

.....
FTestInterface: ITestInterface;
.....

procedure Test_TestInterface.SetUp;
begin
  FTestInterface := TVirtualInterface.Create(TypeInfo(ITestInterface)) as ITestInterface;
end;
.....

并得到错误：“范围检查错误”

有什么想法吗？还是 TVirtualInterface 不支持“对象的功能”和“对象的过程”类型？ 谢谢！！

Answer 1

似乎TVirtualInterface 可以很好地处理方法指针，但不喜欢属性。下面是一个快速示例来演示：

{$APPTYPE CONSOLE}

uses
  SysUtils, Rtti;

type
  TIntegerFunc = function: integer of object;

  IMyInterface = interface(IInvokable)
    ['{8ACA4ABC-90B1-44CA-B25B-34417859D911}']
    function GetValue: TIntegerFunc;
    // property Value: TIntegerFunc read GetValue; // fails with range error
  end;

  TMyClass = class
    class function GetValue: Integer;
  end;

class function TMyClass.GetValue: Integer;
begin
  Result := 666;
end;

procedure Invoke(Method: TRttiMethod; const Args: TArray<TValue>; out Result: TValue);
begin
  Writeln(Method.ToString);
  Result := TValue.From<TIntegerFunc>(TMyClass.GetValue);
end;

var
  Intf: IMyInterface;

begin
  Intf := TVirtualInterface.Create(TypeInfo(IMyInterface), Invoke) as IMyInterface;
  Writeln(Intf.GetValue()); // works fine
  // Writeln(Intf.Value()); // fails with range error
  Readln;
end.

此程序按预期工作。但是，取消注释该属性足以使其失败。这显然是一个 RTTI 错误。我认为除了 Embarcadero 以外的任何人都没有现成的方法来修复它。

似乎是类型为方法指针的属性的组合是问题所在。解决方法是避免此类属性。我建议你提交一份质量控制报告。此答案中的代码正是您所需要的。

Answer 2

正如 David 已经提到的，问题是编译器为返回方法类型的属性生成了错误的 RTTI。

所以对于财产

property OnIntegerValue: TOnIntegerValue;

编译器为如下所示的方法生成 RTTI：

function OnIntegerValue: Integer;

但它不包括此方法的隐式 Self 参数。这就是您收到范围检查错误的原因，因为在读取 RTTI 以创建 TRttiInterfaceType 时，这行代码会被执行：

SetLength(FParameters, FTail^.ParamCount - 1);

这绝不应该发生，因为所有有效的方法都具有隐式 Self 参数。

错误的 RTTI 还有另一个问题，因为它会因为它生成的无效方法而弄乱了虚拟方法的索引。如果方法类型有参数，则不会出现范围检查错误，而是出现错误的 TRttiMethod 实例，这会导致所有后续方法具有错误的虚拟索引，从而导致虚拟接口调用失败。

这是我写的一个单元，你可以用它来修复错误的 RTTI。

unit InterfaceRttiPatch;

interface

uses
  TypInfo;

procedure PatchInterfaceRtti(ATypeInfo: PTypeInfo);

implementation

uses
  Windows;

function SkipShortString(P: Pointer): Pointer;
begin
  Result := PByte(P) + PByte(P)^ + 1;
end;

function SkipAttributes(P: Pointer): Pointer;
begin
  Result := PByte(P) + PWord(P)^;
end;

procedure PatchInterfaceRtti(ATypeInfo: PTypeInfo);
var
  typeData: PTypeData;
  table: PIntfMethodTable;
  p: PByte;
  entry: PIntfMethodEntry;
  tail: PIntfMethodEntryTail;
  methodIndex: Integer;
  paramIndex: Integer;
  next: PByte;
  n: UINT_PTR;
  count: Integer;
  doPatch: Boolean;

  function IsBrokenMethodEntry(entry: Pointer): Boolean;
  var
    p: PByte;
    tail: PIntfMethodEntryTail;
  begin
    p := entry;
    p := SkipShortString(p);
    tail := PIntfMethodEntryTail(p);
    // if ParamCount is 0 the compiler has generated
    // wrong typeinfo for a property returning a method type
    if tail.ParamCount = 0 then
      Exit(True)
    else
    begin
      Inc(p, SizeOf(TIntfMethodEntryTail));
      Inc(p, SizeOf(TParamFlags));
      // if Params[0].ParamName is not 'Self'
      // and Params[0].Tail.ParamType is not the same typeinfo as the interface
      // it is very likely that the compiler has generated
      // wrong type info for a property returning a method type
      if PShortString(p)^ <> 'Self' then
      begin
        p := SkipShortString(p); // ParamName
        p := SkipShortString(p); // TypeName
        if PIntfMethodParamTail(p).ParamType^ <> ATypeInfo then
          Exit(True);
      end;
    end;
    Result := False;
  end;

begin
  if ATypeInfo.Kind <> tkInterface then Exit;

  typeData := GetTypeData(ATypeInfo);
  table := SkipShortString(@typeData.IntfUnit);
  if table.RttiCount = $FFFF then Exit;

  next := nil;
  for doPatch in [False, True] do
  begin
    p := PByte(table);
    Inc(p, SizeOf(TIntfMethodTable));
    for methodIndex := 0 to table.Count - 1 do
    begin
      entry := PIntfMethodEntry(p);
      p := SkipShortString(p);
      tail := PIntfMethodEntryTail(p);
      Inc(p, SizeOf(TIntfMethodEntryTail));
      for paramIndex := 0 to tail.ParamCount - 1 do
      begin
        Inc(p, SizeOf(TParamFlags));  // TIntfMethodParam.Flags
        p := SkipShortString(p);      // TIntfMethodParam.ParamName
        p := SkipShortString(p);      // TIntfMethodParam.TypeName
        Inc(p, SizeOf(PPTypeInfo));   // TIntfMethodParamTail.ParamType
        p := SkipAttributes(p);       // TIntfMethodParamTail.AttrData
      end;
      if tail.Kind = 1 then // function
      begin
        p := SkipShortString(p);      // TIntfMethodEntryTail.ResultTypeName
        Inc(p, SizeOf(PPTypeInfo));   // TIntfMethodEntryTail.ResultType
      end;
      p := SkipAttributes(p);         // TIntfMethodEntryTail.AttrData

      if doPatch and IsBrokenMethodEntry(entry) then
      begin
        WriteProcessMemory(GetCurrentProcess, entry, p, next - p, n);
        count := table.Count - 1;
        p := @table.Count;
        WriteProcessMemory(GetCurrentProcess, p, @count, SizeOf(Word), n);
        count := table.RttiCount;
        p := @table.RttiCount;
        WriteProcessMemory(GetCurrentProcess, p, @count, SizeOf(Word), n);
        p := PByte(entry);
      end;
    end;
    p := SkipAttributes(p);           // TIntfMethodTable.AttrData
    next := p;
  end;
end;

end.