TVirtualInterface fails with an interface that contains "function of object" property

Question

I have the interface:

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;

and in my tests i have:

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

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

and get the error : "Range check error"

Any idea? or TVirtualInterface doesnt support "function of object" and "procedure of object" types? Thanks!!

Answer 1

As David already mentioned the problem is the compiler generating wrong RTTI for properties that return a method type.

So for the property

property OnIntegerValue: TOnIntegerValue;

the compiler generates RTTI for a method that would look like this:

function OnIntegerValue: Integer;

but it does not include the implicit Self parameter for this method. This is the reason why you get the range check error because while reading the RTTI to create a TRttiInterfaceType this line of code gets executed:

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

This should never happen as all valid methods have the implicit Self parameter.

There is another problem with that wrong RTTI as it messes up the virtual method indizes because of the invalid methods it generates. If the method type has a parameter you do not get the range check error but a wrong TRttiMethod instance which causes all following methods to have a wrong virtual index which will cause the virtual interface invokation to fail.

Here is a unit I wrote that you can use to fix wrong 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.

Answer 2

It seems that TVirtualInterface works fine with method pointers, but doesn't like properties. Here's a quick sample to demonstrate:

{$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.

This programs works as expected. However, uncommenting the property is enough to make it fail. It's clearly an RTTI bug. I see no ready way for anyone other than Embarcadero to fix it.

It seems that the combination of a property whose type is a method pointer is the problem. The workaround is to avoid such properties. I suggest that you submit a QC report. The code from this answer is just what you need.