mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-16 17:22:35 +02:00
582 lines
17 KiB
ObjectPascal
582 lines
17 KiB
ObjectPascal
unit FpDebugValueConvertors;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, fgl, FpDbgInfo, FpdMemoryTools, FpDbgCallContextInfo,
|
|
FpPascalBuilder, FpErrorMessages, FpDbgClasses, FpDbgUtil, DbgIntfBaseTypes,
|
|
lazCollections, LazClasses, LCLProc, StrUtils, FpDebugDebuggerBase, FpDebugStringConstants,
|
|
LazDebuggerValueConverter, LazDebuggerIntfBaseTypes;
|
|
|
|
type
|
|
TDbgSymbolKinds = set of TDbgSymbolKind;
|
|
|
|
(* TFpDbgValueConverter and descendants
|
|
- A TFpDbgValueConverter should be immutable, once in the list.
|
|
To change settings a new instance can be set to TFpDbgConverterConfig
|
|
This allows for TFpDbgValueConverter to be used outside the lock (reduces lock time)
|
|
- Any setting that the IDE may need to store, should be published
|
|
*)
|
|
|
|
TFpDbgValueConverter = class(TRefCountedObject, TLazDbgValueConverterIntf)
|
|
private
|
|
FLastErrror: TFpError;
|
|
protected
|
|
function GetObject: TObject;
|
|
function GetSettingsFrame: TLazDbgValueConverterSettingsFrameIntf; virtual;
|
|
procedure Init; virtual;
|
|
public
|
|
class function GetName: String; virtual; abstract;
|
|
class function GetSupportedKinds: TDbgSymbolKinds; virtual;
|
|
constructor Create; virtual;
|
|
procedure Assign(ASource: TFpDbgValueConverter); virtual;
|
|
function CreateCopy: TFpDbgValueConverter; virtual;
|
|
function ConvertValue(ASourceValue: TFpValue;
|
|
AnFpDebugger: TFpDebugDebuggerBase;
|
|
AnExpressionScope: TFpDbgSymbolScope
|
|
): TFpValue; virtual; abstract;
|
|
procedure SetError(AnError: TFpError);
|
|
property LastErrror: TFpError read FLastErrror;
|
|
end;
|
|
TFpDbgValueConverterClass = class of TFpDbgValueConverter;
|
|
|
|
{ TFpDbgValueConverterClassList }
|
|
|
|
TFpDbgValueConverterClassList = class(specialize TFPGList<TFpDbgValueConverterClass>)
|
|
function FindByClassName(AName: String): TFpDbgValueConverterClass;
|
|
end;
|
|
|
|
|
|
{ TFpDbgConverterConfig }
|
|
|
|
TFpDbgConverterConfig = class(TFreeNotifyingObject, TLazDbgValueConvertSelectorIntf)
|
|
private
|
|
FConverter: TFpDbgValueConverter;
|
|
FMatchKinds: TDbgSymbolKinds;
|
|
FMatchTypeNames: TStrings;
|
|
procedure SetConverter(AValue: TFpDbgValueConverter);
|
|
protected
|
|
function GetBackendSpecificObject: TObject; deprecated;
|
|
function GetConverter: TLazDbgValueConverterIntf;
|
|
public
|
|
constructor Create(AConverter: TFpDbgValueConverter);
|
|
destructor Destroy; override;
|
|
function CreateCopy: TFpDbgConverterConfig; virtual;
|
|
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;
|
|
property MatchTypeNames: TStrings read FMatchTypeNames;
|
|
end;
|
|
TFpDbgConverterConfigClass = class of TFpDbgConverterConfig;
|
|
|
|
{ TFpDbgConverterConfigList }
|
|
|
|
TFpDbgConverterConfigList = class(specialize TFPGObjectList<TFpDbgConverterConfig>)
|
|
private
|
|
FLock: TLazMonitor;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Assign(ASource: TFpDbgConverterConfigList);
|
|
procedure Lock;
|
|
procedure Unlock;
|
|
end;
|
|
|
|
{ TFpDbgValueConverterVariantToLStr }
|
|
|
|
TFpDbgValueConverterVariantToLStr = class(TFpDbgValueConverter)
|
|
private
|
|
function GetProcAddrFromMgr(AnFpDebugger: TFpDebugDebuggerBase; AnExpressionScope: TFpDbgSymbolScope): TDbgPtr;
|
|
public
|
|
class function GetName: String; override;
|
|
class function GetSupportedKinds: TDbgSymbolKinds; override;
|
|
function ConvertValue(ASourceValue: TFpValue;
|
|
AnFpDebugger: TFpDebugDebuggerBase;
|
|
AnExpressionScope: TFpDbgSymbolScope
|
|
): TFpValue; override;
|
|
end;
|
|
|
|
function ValueConverterClassList: TFpDbgValueConverterClassList;
|
|
function ValueConverterConfigList: TFpDbgConverterConfigList;
|
|
|
|
implementation
|
|
var
|
|
TheValueConverterClassList: TFpDbgValueConverterClassList = nil;
|
|
TheValueConverterList: TFpDbgConverterConfigList = nil;
|
|
|
|
|
|
function ValueConverterClassList: TFpDbgValueConverterClassList;
|
|
begin
|
|
if TheValueConverterClassList = nil then
|
|
TheValueConverterClassList := TFpDbgValueConverterClassList.Create;
|
|
Result := TheValueConverterClassList;
|
|
end;
|
|
|
|
function ValueConverterConfigList: TFpDbgConverterConfigList;
|
|
begin
|
|
if TheValueConverterList = nil then
|
|
TheValueConverterList := TFpDbgConverterConfigList.Create;
|
|
Result := TheValueConverterList;
|
|
end;
|
|
|
|
{ TFpDbgValueConverterClassList }
|
|
|
|
function TFpDbgValueConverterClassList.FindByClassName(AName: String
|
|
): TFpDbgValueConverterClass;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := nil;
|
|
for i := 0 to Count -1 do
|
|
if Items[i].ClassName = AName then
|
|
exit(Items[i]);
|
|
end;
|
|
|
|
{ TFpDbgValueConverter }
|
|
|
|
function TFpDbgValueConverter.CreateCopy: TFpDbgValueConverter;
|
|
begin
|
|
Result := TFpDbgValueConverterClass(ClassType).Create;
|
|
Result.Assign(Self);
|
|
end;
|
|
|
|
procedure TFpDbgValueConverter.SetError(AnError: TFpError);
|
|
begin
|
|
FLastErrror := AnError;
|
|
end;
|
|
|
|
function TFpDbgValueConverter.GetObject: TObject;
|
|
begin
|
|
Result := Self;
|
|
end;
|
|
|
|
function TFpDbgValueConverter.GetSettingsFrame: TLazDbgValueConverterSettingsFrameIntf;
|
|
begin
|
|
Result := nil;
|
|
end;
|
|
|
|
procedure TFpDbgValueConverter.Init;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
class function TFpDbgValueConverter.GetSupportedKinds: TDbgSymbolKinds;
|
|
begin
|
|
Result := [low(TDbgSymbolKinds)..high(TDbgSymbolKinds)];
|
|
end;
|
|
|
|
constructor TFpDbgValueConverter.Create;
|
|
begin
|
|
inherited Create;
|
|
Init;
|
|
end;
|
|
|
|
procedure TFpDbgValueConverter.Assign(ASource: TFpDbgValueConverter);
|
|
begin
|
|
//
|
|
end;
|
|
|
|
{ TFpDbgConverterConfig }
|
|
|
|
procedure TFpDbgConverterConfig.SetConverter(AValue: TFpDbgValueConverter);
|
|
begin
|
|
if FConverter = AValue then Exit;
|
|
FConverter.ReleaseReference;
|
|
FConverter := AValue;
|
|
if FConverter <> nil then
|
|
FConverter.AddReference;
|
|
end;
|
|
|
|
function TFpDbgConverterConfig.GetBackendSpecificObject: TObject;
|
|
begin
|
|
Result := Self;
|
|
end;
|
|
|
|
function TFpDbgConverterConfig.GetConverter: TLazDbgValueConverterIntf;
|
|
begin
|
|
Result := FConverter;
|
|
end;
|
|
|
|
function TFpDbgConverterConfig.CreateCopy: TFpDbgConverterConfig;
|
|
begin
|
|
Result := TFpDbgConverterConfigClass(ClassType).Create(nil);
|
|
Result.Assign(Self);
|
|
end;
|
|
|
|
constructor TFpDbgConverterConfig.Create(AConverter: TFpDbgValueConverter);
|
|
begin
|
|
inherited Create;
|
|
Converter := AConverter;
|
|
FMatchTypeNames := TStringList.Create;
|
|
TStringList(FMatchTypeNames).CaseSensitive := False;
|
|
TStringList(FMatchTypeNames).Sorted := True;
|
|
end;
|
|
|
|
destructor TFpDbgConverterConfig.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
FMatchTypeNames.Free;
|
|
FConverter.ReleaseReference;
|
|
end;
|
|
|
|
procedure TFpDbgConverterConfig.Assign(ASource: TFpDbgConverterConfig);
|
|
begin
|
|
FMatchKinds := ASource.FMatchKinds;
|
|
FMatchTypeNames.Assign(ASource.FMatchTypeNames);
|
|
Converter := ASource.FConverter.CreateCopy;
|
|
end;
|
|
|
|
function TFpDbgConverterConfig.CheckMatch(AValue: TFpValue): Boolean;
|
|
begin
|
|
Result := (AValue.Kind in (FMatchKinds * Converter.GetSupportedKinds)) and
|
|
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, ValUnitName: String;
|
|
t: TFpSymbol;
|
|
HasMaybeUnitDot: Boolean;
|
|
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]));
|
|
|
|
HasMaybeUnitDot := (pos('.', Pattern) > 1) and
|
|
(AValue.Kind in [skClass]); // only class supports unitnames (via rtti)
|
|
|
|
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, @ValUnitName, CnIdx) and
|
|
(ValClassName <> '')
|
|
do begin
|
|
ValClassName := LowerCase(ValClassName);
|
|
if (ValClassName = TpName) and (not HasMaybeUnitDot) then
|
|
Break;
|
|
Result := MatchPattern(ValClassName, Pattern);
|
|
if Result then
|
|
exit;
|
|
|
|
if HasMaybeUnitDot and (ValUnitName <> '') then begin
|
|
ValUnitName := LowerCase(ValUnitName);
|
|
Result := MatchPattern(ValUnitName+'.'+ValClassName, Pattern);
|
|
if Result then
|
|
exit;
|
|
end;
|
|
|
|
inc(CnIdx);
|
|
end;
|
|
AValue.ResetError;
|
|
|
|
Continue;
|
|
end;
|
|
end;
|
|
|
|
Result := MatchPattern(TpName, Pattern);
|
|
if Result then
|
|
exit;
|
|
if HasMaybeUnitDot then begin
|
|
if AValue.GetInstanceClassName(@ValClassName, @ValUnitName) and
|
|
(ValUnitName <> '') and (ValClassName <> '')
|
|
then begin
|
|
Result := MatchPattern(ValUnitName+'.'+ValClassName, Pattern);
|
|
if Result then
|
|
exit;
|
|
end;
|
|
AValue.ResetError;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ TFpDbgConverterConfigList }
|
|
|
|
constructor TFpDbgConverterConfigList.Create;
|
|
begin
|
|
inherited Create(True);
|
|
FLock := TLazMonitor.create;
|
|
end;
|
|
|
|
destructor TFpDbgConverterConfigList.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
FLock.Free;
|
|
end;
|
|
|
|
procedure TFpDbgConverterConfigList.Assign(ASource: TFpDbgConverterConfigList);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Clear;
|
|
Count := ASource.Count;
|
|
for i := 0 to Count - 1 do
|
|
Items[i] := ASource[i].CreateCopy;
|
|
end;
|
|
|
|
procedure TFpDbgConverterConfigList.Lock;
|
|
begin
|
|
FLock.Acquire;
|
|
end;
|
|
|
|
procedure TFpDbgConverterConfigList.Unlock;
|
|
begin
|
|
FLock.Leave;
|
|
end;
|
|
|
|
{ TFpDbgValueConverterVariantToLStr }
|
|
|
|
function TFpDbgValueConverterVariantToLStr.GetProcAddrFromMgr(
|
|
AnFpDebugger: TFpDebugDebuggerBase; AnExpressionScope: TFpDbgSymbolScope
|
|
): TDbgPtr;
|
|
var
|
|
ProcSym: TFpSymbol;
|
|
MgrAddr, Fnd: TDBGPtr;
|
|
CallContext: TFpDbgInfoCallContext;
|
|
CurProc: TDbgProcess;
|
|
begin
|
|
Result := 0;
|
|
CurProc := AnFpDebugger.DbgController.CurrentProcess;
|
|
if CurProc = nil then
|
|
exit;
|
|
|
|
ProcSym := nil;
|
|
ProcSym := CurProc.FindProcSymbol('SYSTEM_$$_GETVARIANTMANAGER$TVARIANTMANAGER');
|
|
try
|
|
if (ProcSym = nil) or (not (ProcSym.Kind = skProcedure)) or
|
|
(not IsTargetAddr(ProcSym.Address))
|
|
then
|
|
exit;
|
|
|
|
CallContext := nil;
|
|
MgrAddr := AnFpDebugger.DbgController.CurrentThread.AllocStackMem(1024); // enough space for the record
|
|
CallContext := AnFpDebugger.DbgController.Call(ProcSym.Address, AnExpressionScope.LocationContext,
|
|
AnFpDebugger.MemReader, AnFpDebugger.MemConverter);
|
|
try
|
|
CallContext.AddOrdinalParam(nil, MgrAddr);
|
|
CallContext.FinalizeParams;
|
|
AnFpDebugger.DbgController.ProcessLoop;
|
|
|
|
if not CallContext.IsValid then
|
|
exit;
|
|
|
|
if CurProc.ReadAddress(MgrAddr + 8 * CurProc.PointerSize, Fnd) then
|
|
Result := Fnd;
|
|
|
|
finally
|
|
AnFpDebugger.DbgController.AbortCurrentCommand;
|
|
CallContext.ReleaseReference;
|
|
AnFpDebugger.DbgController.CurrentThread.RestoreStackMem;
|
|
end;
|
|
finally
|
|
ProcSym.ReleaseReference;
|
|
end;
|
|
end;
|
|
|
|
class function TFpDbgValueConverterVariantToLStr.GetName: String;
|
|
begin
|
|
Result := drsCallSysVarToLStr;
|
|
end;
|
|
|
|
class function TFpDbgValueConverterVariantToLStr.GetSupportedKinds: TDbgSymbolKinds;
|
|
begin
|
|
Result := [skRecord];
|
|
end;
|
|
|
|
function TFpDbgValueConverterVariantToLStr.ConvertValue(ASourceValue: TFpValue;
|
|
AnFpDebugger: TFpDebugDebuggerBase; AnExpressionScope: TFpDbgSymbolScope
|
|
): TFpValue;
|
|
var
|
|
NewResult, ProcVal, m: TFpValue;
|
|
ProcSym: TFpSymbol;
|
|
CallContext: TFpDbgInfoCallContext;
|
|
StringAddr, ProcAddr, StringDecRefAddress: TDbgPtr;
|
|
ProcLoc: TFpDbgMemLocation;
|
|
r: Boolean;
|
|
begin
|
|
Result := nil;
|
|
if (ASourceValue.Kind <> skRecord) or
|
|
(AnFpDebugger.DbgController.CurrentProcess = nil) or
|
|
( (AnFpDebugger.DbgController.CurrentProcess.Mode = dm32) and
|
|
(ASourceValue.DataSize.Size <> 16)
|
|
) or
|
|
( (AnFpDebugger.DbgController.CurrentProcess.Mode = dm64) and
|
|
(ASourceValue.DataSize.Size <> 24)
|
|
)
|
|
then begin
|
|
SetError(CreateError(fpErrAnyError, ['Value not a variant']));
|
|
exit;
|
|
end;
|
|
m := ASourceValue.MemberByName['vtype'];
|
|
r := (m = nil) or (SizeToFullBytes(m.DataSize) <> 2);
|
|
m.ReleaseReference;
|
|
if r then begin
|
|
SetError(CreateError(fpErrAnyError, ['Value not a variant']));
|
|
exit;
|
|
end;
|
|
|
|
ProcVal := nil;
|
|
ProcSym := nil;
|
|
try
|
|
(*
|
|
//VARIANTS_$$_SYSVARTOLSTR$ANSISTRING$VARIANT
|
|
//U_$SYSTEM_$$_VARIANTMANAGER
|
|
//SYSTEM_$$_GETVARIANTMANAGER$TVARIANTMANAGER
|
|
|
|
ProcVal := AnExpressionScope.FindSymbol('sysvartolstr', 'variants');
|
|
if ProcVal <> nil then begin
|
|
ProcSym := ProcVal.DbgSymbol;
|
|
if ProcSym <> nil then
|
|
ProcSym.AddReference;
|
|
end;
|
|
if (ProcSym = nil) or (not (ProcSym.Kind = skProcedure)) or
|
|
(not IsTargetAddr(ProcSym.Address))
|
|
then
|
|
ProcSym := AnFpDebugger.DbgController.CurrentProcess.FindProcSymbol('sysvartolstr');
|
|
|
|
if (ProcSym = nil) or (not IsTargetAddr(ProcSym.Address)) then
|
|
exit;
|
|
|
|
ProcLoc := ProcSym.Address
|
|
*)
|
|
|
|
if not IsTargetAddr(ASourceValue.Address) then begin
|
|
SetError(CreateError(fpErrAnyError, ['Value not in memory']));
|
|
exit;
|
|
end;
|
|
|
|
ProcAddr := AnFpDebugger.GetCachedData(pointer(TFpDbgValueConverterVariantToLStr));
|
|
if ProcAddr = 0 then begin
|
|
ProcAddr := GetProcAddrFromMgr(AnFpDebugger, AnExpressionScope);
|
|
if ProcAddr = 0 then begin
|
|
SetError(CreateError(fpErrAnyError, ['SysVarToLStr not found']));
|
|
exit;
|
|
end;
|
|
AnFpDebugger.SetCachedData(pointer(TFpDbgValueConverterVariantToLStr), ProcAddr);
|
|
end;
|
|
ProcLoc := TargetLoc(ProcAddr);
|
|
|
|
StringDecRefAddress := AnFpDebugger.GetCached_FPC_ANSISTR_DECR_REF;
|
|
if (StringDecRefAddress = 0) then begin
|
|
SetError(CreateError(fpErrAnyError, ['STRING_DEC_REF not found']));
|
|
exit;
|
|
end;
|
|
|
|
StringAddr := 0;
|
|
CallContext := AnFpDebugger.DbgController.Call(ProcLoc, AnExpressionScope.LocationContext,
|
|
AnFpDebugger.MemReader, AnFpDebugger.MemConverter);
|
|
try
|
|
CallContext.AddStringResult;
|
|
CallContext.FinalizeParams; // force the string as first param (32bit) // TODO
|
|
CallContext.AddOrdinalParam(nil, ASourceValue.DataAddress.Address);
|
|
AnFpDebugger.DbgController.ProcessLoop;
|
|
|
|
if not CallContext.IsValid then begin
|
|
if (IsError(CallContext.LastError)) then
|
|
SetError(CallContext.LastError)
|
|
else
|
|
if (CallContext.Message <> '') then
|
|
SetError(CreateError(fpErrAnyError, [CallContext.Message]));
|
|
exit;
|
|
end;
|
|
|
|
if not CallContext.GetStringResultAsPointer(StringAddr) then begin
|
|
SetError(CallContext.LastError);
|
|
exit;
|
|
end;
|
|
|
|
if not CallContext.GetStringResult(NewResult) then begin
|
|
SetError(CallContext.LastError);
|
|
exit;
|
|
end;
|
|
|
|
Result := NewResult;
|
|
finally
|
|
AnFpDebugger.DbgController.AbortCurrentCommand;
|
|
CallContext.ReleaseReference;
|
|
|
|
AnFpDebugger.CallTargetFuncStringDecRef(StringDecRefAddress, StringAddr, AnExpressionScope.LocationContext);
|
|
end;
|
|
finally
|
|
ProcVal.ReleaseReference;
|
|
ProcSym.ReleaseReference;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
ValueConverterClassList.Add(TFpDbgValueConverterVariantToLStr);
|
|
|
|
finalization;
|
|
FreeAndNil(TheValueConverterClassList);
|
|
FreeAndNil(TheValueConverterList);
|
|
|
|
end.
|
|
|