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.

TVirtualInterface失败，其接口包含“object of object”属性

2 个答案: