From 48043da966374fe5c1f7f8fec02d071f1dbcfdf8 Mon Sep 17 00:00:00 2001 From: Martin Date: Mon, 1 Aug 2022 18:39:58 +0200 Subject: [PATCH] Debugger: Converter, match "*" and inheritance via "is:" --- components/fpdebug/fpdbgdwarffreepascal.pas | 53 ++++++++- components/fpdebug/fpdbginfo.pas | 19 +-- .../lazdebuggerfp/fpdebugvalueconvertors.pas | 108 ++++++++++++++++-- 3 files changed, 158 insertions(+), 22 deletions(-) diff --git a/components/fpdebug/fpdbgdwarffreepascal.pas b/components/fpdebug/fpdbgdwarffreepascal.pas index 21bc9e29bf..954fe03bc5 100644 --- a/components/fpdebug/fpdbgdwarffreepascal.pas +++ b/components/fpdebug/fpdbgdwarffreepascal.pas @@ -157,10 +157,13 @@ type //function GetInstanceClass(AValueObj: TFpValueDwarf): TFpSymbolDwarf; override; class function GetInstanceClassNameFromPVmt(APVmt: TDbgPtr; AContext: TFpDbgLocationContext; ASizeOfAddr: Integer; - out AClassName: String; out AnError: TFpError): boolean; + out AClassName: String; out AnError: TFpError; + AParentClassIndex: integer = 0; + ACompilerVersion: Cardinal = 0): boolean; public function GetInstanceClassName(AValueObj: TFpValue; out - AClassName: String): boolean; override; + AClassName: String; + AParentClassIndex: integer = 0): boolean; override; end; (* *** Record vs ShortString *** *) @@ -965,7 +968,8 @@ begin end; function TFpSymbolDwarfFreePascalTypeStructure.GetInstanceClassName( - AValueObj: TFpValue; out AClassName: String): boolean; + AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer + ): boolean; var AnErr: TFpError; begin @@ -973,21 +977,27 @@ begin if not Result then exit; Result := GetInstanceClassNameFromPVmt(LocToAddrOrNil(AValueObj.DataAddress), - TFpValueDwarf(AValueObj).Context, TFpValueDwarf(AValueObj).Context.SizeOfAddress, AClassName, AnErr); + TFpValueDwarf(AValueObj).Context, TFpValueDwarf(AValueObj).Context.SizeOfAddress, + AClassName, AnErr, AParentClassIndex, + TFpDwarfFreePascalSymbolClassMap(CompilationUnit.DwarfSymbolClassMap).FCompilerVersion + ); + if not Result then SetLastError(AValueObj, AnErr); end; class function TFpSymbolDwarfFreePascalTypeStructure.GetInstanceClassNameFromPVmt (APVmt: TDbgPtr; AContext: TFpDbgLocationContext; ASizeOfAddr: Integer; out - AClassName: String; out AnError: TFpError): boolean; + AClassName: String; out AnError: TFpError; AParentClassIndex: integer; + ACompilerVersion: Cardinal): boolean; var - VmtAddr, ClassNameAddr: TFpDbgMemLocation; + VmtAddr, ClassNameAddr, A: TFpDbgMemLocation; NameLen: QWord; begin Result := False; AnError := NoError; AClassName := ''; + if not AContext.ReadAddress(TargetLoc(APVmt), SizeVal(ASizeOfAddr), VmtAddr) then begin AnError := AContext.LastMemError; exit; @@ -996,6 +1006,37 @@ begin AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]); exit; end; + + while AParentClassIndex > 0 do begin + {$PUSH}{$Q-} + VmtAddr.Address := VmtAddr.Address + TDBGPtr(2 * ASizeOfAddr); + {$POP} + A := VmtAddr; + if not AContext.ReadAddress(A, SizeVal(ASizeOfAddr), VmtAddr) then begin + AnError := AContext.LastMemError; + exit; + end; + if not IsReadableMem(VmtAddr) then begin + AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]); + exit; + end; + + if (ACompilerVersion >= $030200) + then begin + A := VmtAddr; + if not AContext.ReadAddress(A, SizeVal(ASizeOfAddr), VmtAddr) then begin + AnError := AContext.LastMemError; + exit; + end; + if not IsReadableMem(VmtAddr) then begin + AnError := CreateError(fpErrCanNotReadMemAtAddr, [VmtAddr.Address]); + exit; + end; + end; + + dec(AParentClassIndex); + end; + {$PUSH}{$Q-} VmtAddr.Address := VmtAddr.Address + TDBGPtr(3 * ASizeOfAddr); {$POP} diff --git a/components/fpdebug/fpdbginfo.pas b/components/fpdebug/fpdbginfo.pas index b1ca0cb992..cf54527159 100644 --- a/components/fpdebug/fpdbginfo.pas +++ b/components/fpdebug/fpdbginfo.pas @@ -187,7 +187,7 @@ type public function GetTypeCastedValue(ADataVal: TFpValue): TFpValue; virtual; // only if Symbol is a type - function GetInstanceClassName(out AClassName: String): boolean; virtual; + function GetInstanceClassName(out AClassName: String; AParentClassIndex: integer = 0): boolean; virtual; // base class? Or Member includes member from base (* Member: @@ -463,7 +463,7 @@ type // property Flags: TDbgSymbolFlags read GetFlags; property Parent: TFpSymbol read GetParent; deprecated; - function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String): boolean; virtual; + function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer = 0): boolean; virtual; // for Subranges // Type-Symbols only? // TODO: flag bounds as cardinal if needed @@ -508,7 +508,7 @@ type function GetNestedSymbolByName(const AIndex: String): TFpSymbol; override; function GetNestedSymbolCount: Integer; override; public - function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String): boolean; override; + function GetInstanceClassName(AValueObj: TFpValue; out AClassName: String; AParentClassIndex: integer = 0): boolean; override; function GetValueBounds(AValueObj: TFpValue; out ALowBound, AHighBound: Int64): Boolean; override; function GetValueLowBound(AValueObj: TFpValue; out ALowBound: Int64): Boolean; override; function GetValueHighBound(AValueObj: TFpValue; out AHighBound: Int64): Boolean; override; @@ -929,14 +929,15 @@ begin Result := nil; end; -function TFpValue.GetInstanceClassName(out AClassName: String): boolean; +function TFpValue.GetInstanceClassName(out AClassName: String; + AParentClassIndex: integer): boolean; var ti: TFpSymbol; begin ti := TypeInfo; Result := ti <> nil; if Result then - Result := ti.GetInstanceClassName(Self, AClassName); + Result := ti.GetInstanceClassName(Self, AClassName, AParentClassIndex); end; procedure TFpValue.ResetError; @@ -1396,7 +1397,7 @@ begin end; function TFpSymbol.GetInstanceClassName(AValueObj: TFpValue; out - AClassName: String): boolean; + AClassName: String; AParentClassIndex: integer): boolean; begin AClassName := ''; Result := False; @@ -1777,15 +1778,15 @@ begin end; function TFpSymbolForwarder.GetInstanceClassName(AValueObj: TFpValue; out - AClassName: String): boolean; + AClassName: String; AParentClassIndex: integer): boolean; var p: TFpSymbol; begin p := GetForwardToSymbol; if p <> nil then - Result := p.GetInstanceClassName(AValueObj, AClassName) + Result := p.GetInstanceClassName(AValueObj, AClassName, AParentClassIndex) else - Result := inherited GetInstanceClassName(AValueObj, AClassName); + Result := inherited GetInstanceClassName(AValueObj, AClassName, AParentClassIndex); end; function TFpSymbolForwarder.GetValueBounds(AValueObj: TFpValue; out diff --git a/components/lazdebuggers/lazdebuggerfp/fpdebugvalueconvertors.pas b/components/lazdebuggers/lazdebuggerfp/fpdebugvalueconvertors.pas index 3ce59630d8..311fab1134 100644 --- a/components/lazdebuggers/lazdebuggerfp/fpdebugvalueconvertors.pas +++ b/components/lazdebuggers/lazdebuggerfp/fpdebugvalueconvertors.pas @@ -6,9 +6,9 @@ interface uses Classes, SysUtils, fgl, FpDbgInfo, FpdMemoryTools, FpDbgCallContextInfo, - FpPascalBuilder, FpErrorMessages, FpDbgClasses, FpDbgUtil, DbgIntfBaseTypes, - lazCollections, LazClasses, LCLProc, FpDebugDebuggerBase, - LazDebuggerIntfBaseTypes; + FpPascalBuilder, FpErrorMessages, FpDbgClasses, FpDbgUtil, + DbgIntfBaseTypes, lazCollections, LazClasses, LCLProc, StrUtils, + FpDebugDebuggerBase, LazDebuggerIntfBaseTypes; type TDbgSymbolKinds = set of TDbgSymbolKind; @@ -59,6 +59,7 @@ type procedure Assign(ASource: TFpDbgConverterConfig); virtual; function CheckMatch(AValue: TFpValue): Boolean; + function CheckTypeMatch(AValue: TFpValue): Boolean; property Converter: TFpDbgValueConverter read FConverter write SetConverter; property MatchKinds: TDbgSymbolKinds read FMatchKinds write FMatchKinds; @@ -212,11 +213,104 @@ var t: TFpSymbol; TpName: String; begin - t := AValue.TypeInfo; Result := (AValue.Kind in (FMatchKinds * Converter.GetSupportedKinds)) and - (t <> nil) and - GetTypeName(TpName, t, [tnfNoSubstitute]) and - (FMatchTypeNames.IndexOf(TpName) >= 0); + CheckTypeMatch(AValue); +end; + +function TFpDbgConverterConfig.CheckTypeMatch(AValue: TFpValue): Boolean; + function MatchPattern(const AName, APattern: String): Boolean; + var + NamePos, PatternPos, p: Integer; + begin + Result := False; + if APattern = '' then + exit; + + NamePos := 1; + PatternPos := 1; + + while PatternPos <= Length(APattern) do begin + if APattern[PatternPos] = '*' then begin + inc(PatternPos); + end + else begin + p := PatternPos; + PatternPos := PosEx('*', APattern, p); + if PatternPos < 1 then + PatternPos := Length(APattern)+1; + if PatternPos-p > Length(AName)+1 - NamePos then + break; + + NamePos := PosEx(Copy(APattern, p, PatternPos-p), AName, NamePos); + if (NamePos < 1) or + ( (p = 1) and (NamePos <> 1) ) // APattern does not start with * + then + break; + + inc(NamePos, PatternPos-p); + end; + end; + + Result := (PatternPos = Length(APattern)+1) and + ( (NamePos = Length(AName)+1) or + ( (APattern[Length(APattern)] = '*') and + (NamePos <= Length(AName)+1) + ) + ); + end; +var + i, CnIdx: Integer; + TpName, Pattern, ValClassName: String; + t: TFpSymbol; +begin + t := AValue.TypeInfo; + Result := (t <> nil) and GetTypeName(TpName, t, [tnfNoSubstitute]); + if not Result then + exit; + + TpName := LowerCase(TpName); + i := FMatchTypeNames.Count; + while i > 0 do begin + dec(i); + Pattern := LowerCase(trim(FMatchTypeNames[i])); + + if AnsiStrLIComp('is:', @Pattern[1], 3) = 0 then begin + Delete(Pattern, 1, 3); + Pattern := trim(Pattern); + + if (AValue.Kind in [skRecord, skClass, skObject, skInterface]) then begin + ValClassName := TpName; + while t <> nil do begin + Result := MatchPattern(ValClassName, Pattern); + if Result then + exit; + t := t.TypeInfo; + if (t = nil) or not GetTypeName(ValClassName, t, [tnfNoSubstitute]) then + break; + ValClassName := LowerCase(ValClassName); + end; + + CnIdx := 0; + while AValue.GetInstanceClassName(ValClassName, CnIdx) and + (ValClassName <> '') + do begin + ValClassName := LowerCase(ValClassName); + if ValClassName = TpName then + Break; + Result := MatchPattern(ValClassName, Pattern); + if Result then + exit; + inc(CnIdx); + end; + + Continue; + end; + end; + + Result := MatchPattern(TpName, Pattern); + if Result then + exit; + end; end; { TFpDbgConverterConfigList }