Otrzymuję RTTIMethod.Visibility = mvPublic dla metody rekordu prywatnego. - Bug?

Question

Otrzymuję RTTIMethod.Visibility = mvPublic dla (surowego) prywatnego rekordu, używając Delphi 10.2. Czy to błąd?

---

Aktualizacja 2017-07-12: Utworzono problem: RSP-18587.

---

Wyniki programu pokazujące wszystkie typy członków instancji i wizjery dla rekordu i klasy; widoczność zwrócona z RTTI; spojrzeć na PrivateProcedure w TSomeRec:

Types: 
    Unit1.TSomeRec 
    Fields: 
     PrivateField 
     Visibility: mvPrivate 
     PublicField 
     Visibility: mvPublic 
    Properties: 
    Methods: 
     PrivateProcedure 
     Visibility: mvPublic 
     PrivateFunction 
     Visibility: mvPublic 
     PublicProcedure 
     Visibility: mvPublic 
     PublicFunction 
     Visibility: mvPublic 
    Unit1.TSomeClass 
    Fields: 
     PrivateField 
     Visibility: mvPrivate 
     ProtectedField 
     Visibility: mvProtected 
     PublicField 
     Visibility: mvPublic 
    Properties: 
     PrivateProperty 
     Visibility: mvPrivate 
     ProtectedProperty 
     Visibility: mvProtected 
     PublicProperty 
     Visibility: mvPublic 
     PublishedProperty 
     Visibility: mvPublished 
    Methods: 
     PrivateProcedure 
     Visibility: mvPrivate 
     PrivateFunction 
     Visibility: mvPrivate 
     ProtectedProcedure 
     Visibility: mvProtected 
     ProtectedFunction 
     Visibility: mvProtected 
     PublicProcedure 
     Visibility: mvPublic 
     PublicFunction 
     Visibility: mvPublic 
     PublishedProcedure 
     Visibility: mvPublished 
     PublishedFunction 
     Visibility: mvPublished 

---

Unit1.pas:

unit Unit1; 

interface 

{$RTTI explicit 
    Methods ([vcPrivate, vcProtected, vcPublic, vcPublished]) 
    Properties ([vcPrivate, vcProtected, vcPublic, vcPublished]) 
    Fields ([vcPrivate, vcProtected, vcPublic, vcPublished]) 
} 

{$Region 'TSomeRec'} 

type 
    TSomeRec = record 
    strict private 
    PrivateField: Boolean; 
    property PrivateProperty: Boolean read PrivateField; 
    procedure PrivateProcedure; 
    function PrivateFunction: Boolean; 

    public 
    PublicField: Boolean; 
    property PublicProperty: Boolean read PublicField; 
    procedure PublicProcedure; 
    function PublicFunction: Boolean; 
    end; 

{$EndRegion} 
{$Region 'TSomeClass'} 

type 
    TSomeClass = class 
    strict private 
    PrivateField: Boolean; 
    property PrivateProperty: Boolean read PrivateField; 
    procedure PrivateProcedure; 
    function PrivateFunction: Boolean; 

    strict protected 
    ProtectedField: Boolean; 
    property ProtectedProperty: Boolean read ProtectedField; 
    procedure ProtectedProcedure; 
    function ProtectedFunction: Boolean; 

    public 
    PublicField: Boolean; 
    property PublicProperty: Boolean read PublicField; 
    procedure PublicProcedure; 
    function PublicFunction: Boolean; 

    published 
    property PublishedProperty: Boolean read PublicField; 
    procedure PublishedProcedure; 
    function PublishedFunction: Boolean; 
    end; 

{$EndRegion} 

implementation 

{$Region 'TSomeRec'} 

{ TSomeRec } 

function TSomeRec.PrivateFunction: Boolean; 
begin 
    Result := False; 
end; 

procedure TSomeRec.PrivateProcedure; 
begin 
end; 

function TSomeRec.PublicFunction: Boolean; 
begin 
    Result := False; 
end; 

procedure TSomeRec.PublicProcedure; 
begin 
end; 

{$EndRegion} 
{$Region 'TSomeClass'} 

{ TSomeClass } 

function TSomeClass.PrivateFunction: Boolean; 
begin 
    Result := False; 
end; 

procedure TSomeClass.PrivateProcedure; 
begin 
end; 

function TSomeClass.ProtectedFunction: Boolean; 
begin 
    Result := False; 
end; 

procedure TSomeClass.ProtectedProcedure; 
begin 
end; 

function TSomeClass.PublicFunction: Boolean; 
begin 
    Result := False; 
end; 

procedure TSomeClass.PublicProcedure; 
begin 
end; 

function TSomeClass.PublishedFunction: Boolean; 
begin 
    Result := False; 
end; 

procedure TSomeClass.PublishedProcedure; 
begin 
end; 

{$EndRegion} 

end. 

Project1.dpr:

program Project1; 

{$AppType Console} 

{$R *.res} 

uses 
    System.RTTI, 
    System.StrUtils, 
    System.SysUtils, 
    System.TypInfo, 
    Unit1 in 'Unit1.pas'; 

{$Region 'IWriter, TWriter'} 

type 
    IWriter = interface 
    procedure BeginSection(const Value: String = ''); 
    procedure EndSection; 
    procedure WriteMemberSection(const Value: TRTTIMember); 
    end; 

    TWriter = class (TInterfacedObject, IWriter) 
    strict private 
    FIndentCount: NativeInt; 

    strict protected 
    procedure BeginSection(const Value: String); 
    procedure EndSection; 
    procedure WriteLn(const Value: String); 
    procedure WriteMemberSection(const Value: TRTTIMember); 

    public 
    const 
    IndentStr = ' '; 
    end; 

{ TWriter } 

procedure TWriter.BeginSection(const Value: String); 
begin 
    WriteLn(Value); 
    Inc(FIndentCount); 
end; 

procedure TWriter.EndSection; 
begin 
    Dec(FIndentCount); 
end; 

procedure TWriter.WriteLn(const Value: String); 
begin 
    System.WriteLn(DupeString(IndentStr, FIndentCount) + Value); 
end; 

procedure TWriter.WriteMemberSection(const Value: TRTTIMember); 
begin 
    BeginSection(Value.Name); 
    try 
    WriteLn('Visibility: ' + TValue.From<TMemberVisibility>(Value.Visibility).ToString); 
    finally 
    EndSection; 
    end; 
end; 

{$EndRegion} 

{$Region '...'} 

procedure Run; 
var 
    Writer: IWriter; 
    RTTIContext: TRTTIContext; 
    RTTIType: TRTTIType; 
    RTTIField: TRTTIField; 
    RTTIProp: TRTTIProperty; 
    RTTIMethod: TRTTIMethod; 
begin 
    Writer := TWriter.Create; 
    RTTIContext := TRTTIContext.Create; 
    try 
    RTTIContext.GetType(TypeInfo(TSomeRec)); 
    RTTIContext.GetType(TypeInfo(TSomeClass)); 
    Writer.BeginSection('Types:'); 
    for RTTIType in RTTIContext.GetTypes do 
    begin 
     if not RTTIType.Name.Contains('ISome') 
     and not RTTIType.Name.Contains('TSome') then 
     Continue; 
     Writer.BeginSection(RTTIType.QualifiedName); 
     Writer.BeginSection('Fields:'); 
     for RTTIField in RTTIType.GetFields do 
     begin 
     if not RTTIField.Name.EndsWith('Field') then 
      Continue; 
     Writer.WriteMemberSection(RTTIField); 
     end; 
     Writer.EndSection; 
     Writer.BeginSection('Properties:'); 
     for RTTIProp in RTTIType.GetProperties do 
     begin 
     if not RTTIProp.Name.EndsWith('Property') then 
      Continue; 
     Writer.WriteMemberSection(RTTIProp); 
     end; 
     Writer.EndSection; 
     Writer.BeginSection('Methods:'); 
     for RTTIMethod in RTTIType.GetMethods do 
     begin 
     if not RTTIMethod.Name.Contains('Procedure') 
      and not RTTIMethod.Name.Contains('Function') then 
      Continue; 
     Writer.WriteMemberSection(RTTIMethod); 
     end; 
     Writer.EndSection; 
     Writer.EndSection; 
    end; 
    Writer.EndSection; 
    finally 
    RTTIContext.Free; 
    end; 
end; 

{$EndRegion} 

begin 
    {$Region '...'} 
    try 
    Run; 
    except 
    on E: Exception do 
     WriteLn(E.ClassName, ': ', E.Message); 
    end; 
    ReadLn; 
    {$EndRegion} 
end. 

Answer 1

Błąd jest GetVisibilit y nie jest przesłonięte w TRttiRecordMethod. Zajrzałem trochę do kodu, a informacja o widoczności znajduje się w polu flagi.

Podobny do innych nadpisań GetVisibility, takich jak w TRttiRecordField, musi zostać zaimplementowany. Zanotowałem to jako RSP-18588.

Napisałem małą poprawkę, która powinna to naprawić, jeśli naprawdę trzeba to naprawić (tylko okna).

unit PatchRecordMethodGetVisibility; 

interface 

implementation 

uses 
    Rtti, SysUtils, TypInfo, Windows; 

type 
    TRec = record 
    procedure Method; 
    end; 

procedure TRec.Method; 
begin 
end; 

function GetVirtualMethod(AClass: TClass; const Index: Integer): Pointer; 
begin 
    Result := PPointer(UINT_PTR(AClass) + UINT_PTR(Index * SizeOf(Pointer)))^; 
end; 

procedure RedirectFunction(OrgProc, NewProc: Pointer); 
type 
    TJmpBuffer = packed record 
    Jmp: Byte; 
    Offset: Integer; 
    end; 
var 
    n: UINT_PTR; 
    JmpBuffer: TJmpBuffer; 
begin 
    JmpBuffer.Jmp := $E9; 
    JmpBuffer.Offset := PByte(NewProc) - (PByte(OrgProc) + 5); 
    if not WriteProcessMemory(GetCurrentProcess, OrgProc, @JmpBuffer, SizeOf(JmpBuffer), n) then 
    RaiseLastOSError; 
end; 

type 
    TRttiRecordMethodFix = class(TRttiMethod) 
    function GetVisibility: TMemberVisibility; 
    end; 

procedure PatchIt; 
var 
    ctx: TRttiContext; 
    recMethodCls: TClass; 
begin 
    recMethodCls := ctx.GetType(TypeInfo(TRec)).GetMethod('Method').ClassType; 
    RedirectFunction(GetVirtualMethod(recMethodCls, 3), @TRttiRecordMethodFix.GetVisibility); 
end; 

{ TRttiRecordMethodFix } 

function TRttiRecordMethodFix.GetVisibility: TMemberVisibility; 

    function GetBitField(Value, Shift, Bits: Integer): Integer; 
    begin 
    Result := (Value shr Shift) and ((1 shl Bits) - 1); 
    end; 

const 
    rmfVisibilityShift = 2; 
    rmfVisibilityBits = 2; 
begin 
    Result := TMemberVisibility(GetBitField(PRecordTypeMethod(Handle)^.Flags, rmfVisibilityShift, rmfVisibilityBits)) 
end; 

initialization 
    PatchIt; 

end.