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

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

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.

Answer 2

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.