All geek questions in one place

I get RTTIMethod.Visibility = mvPublic for a private posting method. - Error?

I get RTTIMethod.Visibility = mvPublic for a (strict) personal RTTIMethod.Visibility = mvPublic using Delphi 10.2. This is mistake?

Update 2017-07-12: Problem Created: RSP-18587 .

A program output showing all types of instance instances and visibility for a record and class; RTTI return visibility find PrivateProcedure in 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.
+5
source share
1 answer

The error is that GetVisibility is not overridden in TRttiRecordMethod. I looked at the code a bit, and visibility information is actually inside the Flag field.

Like other GetVisibility overrides, such as TRttiRecordField, it must be implemented. I reported this as RSP-18588 .

I wrote a small patch that should fix this if you really need it to be fixed (windows only).

 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.
+2
source

Source: https://habr.com/ru/post/1269723/

More articles:


All Articles