2

私はインターフェースを持っています：

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 は「オブジェクトの関数」と「オブジェクトの手続き」型をサポートしていませんか? ありがとう！！

4

2 に答える 2

2

メソッドポインタでは問題なく動作するよう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 以外の誰かがそれを修正する準備ができているとは思えません。

メソッドポインタ型のプロパティの組み合わせが問題のようです。回避策は、そのようなプロパティを避けることです。QCレポートを提出することをお勧めします。この回答のコードは、必要なものだけです。

于 2013-03-13T17:49:38.853 に答える
1

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.
于 2013-03-27T15:43:18.457 に答える