Debugger: Configuration for value converter

This commit is contained in:
Martin 2022-08-04 22:49:21 +02:00
parent 2d0c2ea8ba
commit 6f99f0fe16
14 changed files with 699 additions and 264 deletions

View File

@ -0,0 +1,62 @@
object JsonForDebugSettingsFrame: TJsonForDebugSettingsFrame
Left = 0
Height = 156
Top = 0
Width = 226
AutoSize = True
ChildSizing.TopBottomSpacing = 1
ChildSizing.VerticalSpacing = 1
ChildSizing.EnlargeHorizontal = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2
ClientHeight = 156
ClientWidth = 226
TabOrder = 0
DesignLeft = 394
DesignTop = 60
object lblFuncName: TLabel
Left = 0
Height = 23
Top = 1
Width = 45
Caption = '----'
end
object edFuncName: TEdit
Left = 45
Height = 23
Top = 1
Width = 181
AutoSize = False
TabOrder = 0
end
object lblJsonAddress: TLabel
Left = 0
Height = 23
Top = 25
Width = 45
Caption = '----'
end
object edJsonAddress: TEdit
Left = 45
Height = 23
Top = 25
Width = 181
AutoSize = False
TabOrder = 1
end
object lblJsonTypename: TLabel
Left = 0
Height = 23
Top = 49
Width = 45
Caption = '----'
end
object edJsonTypename: TEdit
Left = 45
Height = 23
Top = 49
Width = 181
AutoSize = False
TabOrder = 2
end
end

View File

@ -0,0 +1,328 @@
unit FpDebugConvDebugForJson;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, ExtCtrls, StdCtrls,
FpDebugStringConstants, FpDebugValueConvertors, FpDebugDebuggerBase,
LazDebuggerValueConverter, LazDebuggerIntfBaseTypes, FpDbgInfo, FpDbgClasses,
FpdMemoryTools, FpDbgCallContextInfo, FpErrorMessages, DbgIntfBaseTypes;
type
{ TJsonForDebugSettingsFrame }
TJsonForDebugSettingsFrame = class(TFrame, TLazDbgValueConverterSettingsFrameIntf)
edFuncName: TEdit;
edJsonAddress: TEdit;
edJsonTypename: TEdit;
lblFuncName: TLabel;
lblJsonAddress: TLabel;
lblJsonTypename: TLabel;
private
protected
procedure ReadFrom(AConvertor: TLazDbgValueConverterIntf);
function WriteTo(AConvertor: TLazDbgValueConverterIntf): Boolean;
function GetFrame: TObject;
public
constructor Create(TheOwner: TComponent); override;
end;
{ TFpDbgValueConverterJsonForDebug }
TFpDbgValueConverterJsonForDebug = class(TFpDbgValueConverter)
private
FFunctionName: String;
FJsonAddressKey: String;
FJsonTypenameKey: String;
function FunctionNameIsStored: Boolean;
function GetProcAddr(AnFpDebugger: TFpDebugDebuggerBase; AnExpressionScope: TFpDbgSymbolScope): TDBGPtr;
function JsonAddressKeyIsStored: Boolean;
protected
function GetSettingsFrame: TLazDbgValueConverterSettingsFrameIntf; override;
procedure Init; override;
public
class function GetName: String; override;
class function GetSupportedKinds: TDbgSymbolKinds; override;
procedure Assign(ASource: TFpDbgValueConverter); override;
function ConvertValue(ASourceValue: TFpValue;
AnFpDebugger: TFpDebugDebuggerBase;
AnExpressionScope: TFpDbgSymbolScope
): TFpValue; override;
published
property FunctionName: String read FFunctionName write FFunctionName stored FunctionNameIsStored;
property JsonAddressKey: String read FJsonAddressKey write FJsonAddressKey stored JsonAddressKeyIsStored;
property JsonTypenameKey: String read FJsonTypenameKey write FJsonTypenameKey;
end;
implementation
{$R *.lfm}
{ TJsonForDebugSettingsFrame }
procedure TJsonForDebugSettingsFrame.ReadFrom(
AConvertor: TLazDbgValueConverterIntf);
var
c: TFpDbgValueConverterJsonForDebug;
begin
if not (AConvertor.GetObject is TFpDbgValueConverterJsonForDebug) then
exit;
c := TFpDbgValueConverterJsonForDebug(AConvertor.GetObject);
edFuncName.Text := c.FFunctionName;
edJsonAddress.Text := c.FJsonAddressKey;
edJsonTypename.Text := c.FJsonTypenameKey;
end;
function TJsonForDebugSettingsFrame.WriteTo(
AConvertor: TLazDbgValueConverterIntf): Boolean;
var
c: TFpDbgValueConverterJsonForDebug;
begin
Result := False;
if not (AConvertor.GetObject is TFpDbgValueConverterJsonForDebug) then
exit;
c := TFpDbgValueConverterJsonForDebug(AConvertor.GetObject);
Result :=
(c.FFunctionName <> trim(edFuncName.Text)) or
(c.FJsonAddressKey <> trim(edJsonAddress.Text)) or
(c.FJsonTypenameKey <> trim(edJsonTypename.Text));
c.FFunctionName := trim(edFuncName.Text);
c.FJsonAddressKey := trim(edJsonAddress.Text);
c.FJsonTypenameKey := trim(edJsonTypename.Text);
end;
function TJsonForDebugSettingsFrame.GetFrame: TObject;
begin
Result := Self;
end;
constructor TJsonForDebugSettingsFrame.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
lblFuncName.Caption := drsFunctionName;
lblJsonAddress.Caption := drsKeyForAddress;
lblJsonTypename.Caption := drsKeyForTypename;
end;
{ TFpDbgValueConverterJsonForDebug }
function TFpDbgValueConverterJsonForDebug.GetProcAddr(
AnFpDebugger: TFpDebugDebuggerBase; AnExpressionScope: TFpDbgSymbolScope
): TDBGPtr;
var
CurProc: TDbgProcess;
ProcSymVal: TFpValue;
ProcSym: TFpSymbol;
begin
Result := AnFpDebugger.GetCachedData(pointer(Self));
if Result <> 0 then
exit;
CurProc := AnFpDebugger.DbgController.CurrentProcess;
if CurProc = nil then
exit;
ProcSymVal := AnExpressionScope.FindSymbol(FFunctionName);
if ProcSymVal <> nil then begin
if (ProcSymVal.Kind = skProcedure) and IsTargetAddr(ProcSymVal.DataAddress)
//and
// (ProcSymVal.NestedSymbolCount = 3)
then begin
Result := ProcSymVal.DataAddress.Address;
AnFpDebugger.SetCachedData(pointer(TFpDbgValueConverterJsonForDebug), Result);
ProcSymVal.ReleaseReference;
exit;
end;
Result := 0;
Result := ProcSymVal.DataAddress.Address;
end;
ProcSym := CurProc.FindProcSymbol(FFunctionName);
if (ProcSym <> nil) and (ProcSym.Kind = skProcedure) and
(IsTargetAddr(ProcSym.Address))
then begin
Result := ProcSym.Address.Address;
AnFpDebugger.SetCachedData(pointer(TFpDbgValueConverterJsonForDebug), Result);
end;
ProcSym.ReleaseReference;
end;
function TFpDbgValueConverterJsonForDebug.JsonAddressKeyIsStored: Boolean;
begin
Result := FJsonAddressKey <> 'Address';
end;
function TFpDbgValueConverterJsonForDebug.FunctionNameIsStored: Boolean;
begin
Result := FFunctionName <> 'JsonForDebug';
end;
function TFpDbgValueConverterJsonForDebug.GetSettingsFrame: TLazDbgValueConverterSettingsFrameIntf;
begin
Result := TJsonForDebugSettingsFrame.Create(nil);
end;
procedure TFpDbgValueConverterJsonForDebug.Init;
begin
inherited Init;
FFunctionName := 'JsonForDebug';
FJsonAddressKey := 'Address'
end;
class function TFpDbgValueConverterJsonForDebug.GetName: String;
begin
Result := drsCallJsonForDebug;
end;
class function TFpDbgValueConverterJsonForDebug.GetSupportedKinds: TDbgSymbolKinds;
begin
Result := [low(Result)..high(Result)];
end;
procedure TFpDbgValueConverterJsonForDebug.Assign(ASource: TFpDbgValueConverter);
begin
inherited Assign(ASource);
if ASource is TFpDbgValueConverterJsonForDebug then begin
FFunctionName := TFpDbgValueConverterJsonForDebug(ASource).FFunctionName;
FJsonAddressKey := TFpDbgValueConverterJsonForDebug(ASource).FJsonAddressKey;
FJsonTypenameKey := TFpDbgValueConverterJsonForDebug(ASource).FJsonTypenameKey;
end;
end;
function TFpDbgValueConverterJsonForDebug.ConvertValue(ASourceValue: TFpValue;
AnFpDebugger: TFpDebugDebuggerBase; AnExpressionScope: TFpDbgSymbolScope
): TFpValue;
var
CurProccess: TDbgProcess;
TpName, JsonText: String;
ProcAddr, SetLenProc, DecRefProc,
TpNameAddr, TpNewNameAddr, TpNameRefAddr, TextAddr, TextRefAddr: TDbgPtr;
CallContext: TFpDbgInfoCallContext;
r: Boolean;
begin
Result := nil;
if (not (svfAddress in ASourceValue.FieldFlags)) or
(not IsTargetAddr(ASourceValue.Address))
then begin
SetError(CreateError(fpErrAnyError, ['Value not in memory']));
exit;
end;
TpName := '';
if ASourceValue.TypeInfo <> nil then
TpName := ASourceValue.TypeInfo.Name;
if TpName = '' then begin
SetError(CreateError(fpErrAnyError, ['no typename']));
exit;
end;
ProcAddr := GetProcAddr(AnFpDebugger, AnExpressionScope);
if ProcAddr = 0 then begin
SetError(CreateError(fpErrAnyError, ['JsonForDebug not found']));
exit;
end;
CurProccess := AnFpDebugger.DbgController.CurrentProcess;
SetLenProc := AnFpDebugger.GetCached_FPC_ANSISTR_SETLENGTH;
DecRefProc := AnFpDebugger.GetCached_FPC_ANSISTR_DECR_REF;
if (SetLenProc = 0) or (DecRefProc = 0) or (CurProccess = nil)
then begin
SetError(CreateError(fpErrAnyError, ['internal error']));
exit;
end;
TpNameAddr := 0;
TpNewNameAddr := 0;
TpNameRefAddr := 0;
TextAddr := 0;
TextRefAddr := 0;
try
if (not AnFpDebugger.CreateAnsiStringInTarget(SetLenProc, TpNameAddr, TpName, AnExpressionScope.LocationContext)) or
(TpNameAddr = 0)
then begin
TpNameAddr := 0;
SetError(CreateError(fpErrAnyError, ['failed to set param']));
exit;
end;
CallContext := AnFpDebugger.DbgController.Call(TargetLoc(ProcAddr), AnExpressionScope.LocationContext,
AnFpDebugger.MemReader, AnFpDebugger.MemConverter);
if (not CallContext.AddOrdinalParam(ASourceValue.Address.Address)) or
(not CallContext.AddOrdinalViaRefAsParam(TpNameAddr, TpNameRefAddr)) or
(not CallContext.AddOrdinalViaRefAsParam(0, TextRefAddr))
then begin
SetError(CreateError(fpErrAnyError, ['failed to set param']));
exit;
end;
CallContext.FinalizeParams; // force the string as first param (32bit) // TODO
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;
r := True;
if not CurProccess.ReadAddress(TpNameRefAddr, TpNewNameAddr) then begin
r := False;
TpNewNameAddr := 0;
end;
if not CurProccess.ReadAddress(TextRefAddr, TextAddr) then begin
r := False;
TextAddr:= 0;
end;
if not AnFpDebugger.ReadAnsiStringFromTarget(TpNewNameAddr, TpName) then
r := False;
if not AnFpDebugger.ReadAnsiStringFromTarget(TextAddr, JsonText) then
r := False;
if not r then begin
SetError(CreateError(fpErrAnyError, ['failed to get result']));
exit;
end;
AnFpDebugger.DbgController.AbortCurrentCommand;
CallContext.ReleaseReference;
Result := TFpValueConstString.Create(JsonText);
TFpValueConstString(Result).SetTypeName(TpName);
finally
if TpNewNameAddr <> 0 then
TpNameAddr := TpNewNameAddr;
if TpNameAddr <> 0 then
AnFpDebugger.CallTargetFuncStringDecRef(DecRefProc, TpNameAddr, AnExpressionScope.LocationContext);
if TextAddr <> 0 then
AnFpDebugger.CallTargetFuncStringDecRef(DecRefProc, TextAddr, AnExpressionScope.LocationContext);
end;
end;
initialization
ValueConverterClassList.Add(TFpDbgValueConverterJsonForDebug);
end.

View File

@ -41,7 +41,9 @@ uses
{$IFDEF FPDEBUG_THREAD_CHECK} FpDbgCommon, {$ENDIF}
FpDbgClasses, FpDbgInfo, FpErrorMessages, FpPascalBuilder, FpdMemoryTools,
FpPascalParser, FPDbgController, FpDbgDwarfDataClasses, FpDbgDwarfFreePascal,
FpDbgDwarf, FpDbgUtil;
FpDbgDwarf, FpDbgUtil,
// use converters
FpDebugValueConvertors, FpDebugConvDebugForJson;
type

View File

@ -0,0 +1,21 @@
unit FpDebugStringConstants;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
resourcestring
drsKeyForAddress = 'Key for Address';
drsKeyForTypename = 'Key for Typename';
drsFunctionName = 'Function name';
drsCallSysVarToLStr = 'Call SysVarToLStr';
drsCallJsonForDebug = 'Call JsonForDebug';
implementation
end.

View File

@ -6,9 +6,9 @@ interface
uses
Classes, SysUtils, fgl, FpDbgInfo, FpdMemoryTools, FpDbgCallContextInfo,
FpPascalBuilder, FpErrorMessages, FpDbgClasses, FpDbgUtil,
DbgIntfBaseTypes, lazCollections, LazClasses, LCLProc, StrUtils,
FpDebugDebuggerBase, LazDebuggerValueConverter, LazDebuggerIntfBaseTypes;
FpPascalBuilder, FpErrorMessages, FpDbgClasses, FpDbgUtil, DbgIntfBaseTypes,
lazCollections, LazClasses, LCLProc, StrUtils, FpDebugDebuggerBase, FpDebugStringConstants,
LazDebuggerValueConverter, LazDebuggerIntfBaseTypes;
type
TDbgSymbolKinds = set of TDbgSymbolKind;
@ -25,10 +25,13 @@ type
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;
procedure Assign(ASource: TFpDbgValueConverter);
constructor Create; virtual;
procedure Assign(ASource: TFpDbgValueConverter); virtual;
function CreateCopy: TFpDbgValueConverter; virtual;
function ConvertValue(ASourceValue: TFpValue;
AnFpDebugger: TFpDebugDebuggerBase;
@ -55,7 +58,8 @@ type
FMatchTypeNames: TStrings;
procedure SetConverter(AValue: TFpDbgValueConverter);
protected
function GetBackendSpecificObject: TObject;
function GetBackendSpecificObject: TObject; deprecated;
function GetConverter: TLazDbgValueConverterIntf;
public
constructor Create(AConverter: TFpDbgValueConverter);
destructor Destroy; override;
@ -98,21 +102,6 @@ type
): TFpValue; override;
end;
{ TFpDbgValueConverterJsonForDebug }
TFpDbgValueConverterJsonForDebug = class(TFpDbgValueConverter)
private
function GetProcAddr(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;
@ -167,11 +156,27 @@ 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
//
@ -193,6 +198,11 @@ begin
Result := Self;
end;
function TFpDbgConverterConfig.GetConverter: TLazDbgValueConverterIntf;
begin
Result := FConverter;
end;
function TFpDbgConverterConfig.CreateCopy: TFpDbgConverterConfig;
begin
Result := TFpDbgConverterConfigClass(ClassType).Create(nil);
@ -223,9 +233,6 @@ begin
end;
function TFpDbgConverterConfig.CheckMatch(AValue: TFpValue): Boolean;
var
t: TFpSymbol;
TpName: String;
begin
Result := (AValue.Kind in (FMatchKinds * Converter.GetSupportedKinds)) and
CheckTypeMatch(AValue);
@ -412,7 +419,7 @@ end;
class function TFpDbgValueConverterVariantToLStr.GetName: String;
begin
Result := 'Call SysVarToLStr';
Result := drsCallSysVarToLStr;
end;
class function TFpDbgValueConverterVariantToLStr.GetSupportedKinds: TDbgSymbolKinds;
@ -540,181 +547,8 @@ begin
end;
end;
{ TFpDbgValueConverterJsonForDebug }
function TFpDbgValueConverterJsonForDebug.GetProcAddr(
AnFpDebugger: TFpDebugDebuggerBase; AnExpressionScope: TFpDbgSymbolScope
): TDBGPtr;
var
CurProc: TDbgProcess;
ProcSymVal: TFpValue;
ProcSym: TFpSymbol;
begin
Result := AnFpDebugger.GetCachedData(pointer(TFpDbgValueConverterJsonForDebug));
if Result <> 0 then
exit;
CurProc := AnFpDebugger.DbgController.CurrentProcess;
if CurProc = nil then
exit;
ProcSymVal := AnExpressionScope.FindSymbol('JsonForDebug');
if ProcSymVal <> nil then begin
if (ProcSymVal.Kind = skProcedure) and IsTargetAddr(ProcSymVal.DataAddress) then begin
Result := ProcSymVal.DataAddress.Address;
AnFpDebugger.SetCachedData(pointer(TFpDbgValueConverterJsonForDebug), Result);
ProcSymVal.ReleaseReference;
exit;
end;
Result := 0;
Result := ProcSymVal.DataAddress.Address;
end;
ProcSym := CurProc.FindProcSymbol('JsonForDebug');
if (ProcSym <> nil) and (ProcSym.Kind = skProcedure) and
(IsTargetAddr(ProcSym.Address))
then begin
Result := ProcSym.Address.Address;
AnFpDebugger.SetCachedData(pointer(TFpDbgValueConverterJsonForDebug), Result);
end;
ProcSym.ReleaseReference;
end;
class function TFpDbgValueConverterJsonForDebug.GetName: String;
begin
Result := 'Call JsonForDebug';
end;
class function TFpDbgValueConverterJsonForDebug.GetSupportedKinds: TDbgSymbolKinds;
begin
Result := [low(Result)..high(Result)];
end;
function TFpDbgValueConverterJsonForDebug.ConvertValue(ASourceValue: TFpValue;
AnFpDebugger: TFpDebugDebuggerBase; AnExpressionScope: TFpDbgSymbolScope
): TFpValue;
var
CurProccess: TDbgProcess;
TpName, JsonText: String;
ProcAddr, SetLenProc, DecRefProc,
TpNameAddr, TpNewNameAddr, TpNameRefAddr, TextAddr, TextRefAddr: TDbgPtr;
CallContext: TFpDbgInfoCallContext;
r: Boolean;
AddrSize: Integer;
begin
Result := nil;
if (not (svfAddress in ASourceValue.FieldFlags)) or
(not IsTargetAddr(ASourceValue.Address))
then begin
SetError(CreateError(fpErrAnyError, ['Value not in memory']));
exit;
end;
TpName := '';
if ASourceValue.TypeInfo <> nil then
TpName := ASourceValue.TypeInfo.Name;
if TpName = '' then begin
SetError(CreateError(fpErrAnyError, ['no typename']));
exit;
end;
ProcAddr := GetProcAddr(AnFpDebugger, AnExpressionScope);
if ProcAddr = 0 then begin
SetError(CreateError(fpErrAnyError, ['JsonForDebug not found']));
exit;
end;
CurProccess := AnFpDebugger.DbgController.CurrentProcess;
SetLenProc := AnFpDebugger.GetCached_FPC_ANSISTR_SETLENGTH;
DecRefProc := AnFpDebugger.GetCached_FPC_ANSISTR_DECR_REF;
if (SetLenProc = 0) or (DecRefProc = 0) or (CurProccess = nil)
then begin
SetError(CreateError(fpErrAnyError, ['internal error']));
exit;
end;
TpNameAddr := 0;
TpNewNameAddr := 0;
TpNameRefAddr := 0;
TextAddr := 0;
TextRefAddr := 0;
try
if (not AnFpDebugger.CreateAnsiStringInTarget(SetLenProc, TpNameAddr, TpName, AnExpressionScope.LocationContext)) or
(TpNameAddr = 0)
then begin
TpNameAddr := 0;
SetError(CreateError(fpErrAnyError, ['failed to set param']));
exit;
end;
CallContext := AnFpDebugger.DbgController.Call(TargetLoc(ProcAddr), AnExpressionScope.LocationContext,
AnFpDebugger.MemReader, AnFpDebugger.MemConverter);
if (not CallContext.AddOrdinalParam(ASourceValue.Address.Address)) or
(not CallContext.AddOrdinalViaRefAsParam(TpNameAddr, TpNameRefAddr)) or
(not CallContext.AddOrdinalViaRefAsParam(0, TextRefAddr))
then begin
SetError(CreateError(fpErrAnyError, ['failed to set param']));
exit;
end;
CallContext.FinalizeParams; // force the string as first param (32bit) // TODO
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;
r := True;
if not CurProccess.ReadAddress(TpNameRefAddr, TpNewNameAddr) then begin
r := False;
TpNewNameAddr := 0;
end;
if not CurProccess.ReadAddress(TextRefAddr, TextAddr) then begin
r := False;
TextAddr:= 0;
end;
if not AnFpDebugger.ReadAnsiStringFromTarget(TpNewNameAddr, TpName) then
r := False;
if not AnFpDebugger.ReadAnsiStringFromTarget(TextAddr, JsonText) then
r := False;
if not r then begin
SetError(CreateError(fpErrAnyError, ['failed to get result']));
exit;
end;
AnFpDebugger.DbgController.AbortCurrentCommand;
CallContext.ReleaseReference;
Result := TFpValueConstString.Create(JsonText);
TFpValueConstString(Result).SetTypeName(TpName);
finally
if TpNewNameAddr <> 0 then
TpNameAddr := TpNewNameAddr;
if TpNameAddr <> 0 then
AnFpDebugger.CallTargetFuncStringDecRef(DecRefProc, TpNameAddr, AnExpressionScope.LocationContext);
if TextAddr <> 0 then
AnFpDebugger.CallTargetFuncStringDecRef(DecRefProc, TextAddr, AnExpressionScope.LocationContext);
end;
end;
initialization
ValueConverterClassList.Add(TFpDbgValueConverterVariantToLStr);
ValueConverterClassList.Add(TFpDbgValueConverterJsonForDebug);
finalization;
FreeAndNil(TheValueConverterClassList);

View File

@ -48,6 +48,14 @@
<Filename Value="fpdebuggerresultdata.pas"/>
<UnitName Value="FpDebuggerResultData"/>
</Item>
<Item>
<Filename Value="fpdebugconvdebugforjson.pas"/>
<UnitName Value="FpDebugConvDebugForJson"/>
</Item>
<Item>
<Filename Value="fpdebugstringconstants.pas"/>
<UnitName Value="FpDebugStringConstants"/>
</Item>
</Files>
<RequiredPkgs>
<Item>

View File

@ -10,7 +10,7 @@ interface
uses
FpDebugDebugger, FpDebugDebuggerUtils, FpDebugDebuggerWorkThreads,
FpDebugValueConvertors, FpDebugDebuggerBase, FpDebuggerResultData,
LazarusPackageIntf;
FpDebugConvDebugForJson, FpDebugStringConstants, LazarusPackageIntf;
implementation

View File

@ -9,17 +9,28 @@ uses
Classes, SysUtils;
type
TLazDbgValueConverterIntf = interface;
TLazDbgValueConverterSettingsFrameIntf = interface
procedure ReadFrom(AConvertor: TLazDbgValueConverterIntf);
function WriteTo(AConvertor: TLazDbgValueConverterIntf): Boolean;
function GetFrame: TObject; // TFrame
procedure Free;
end;
TLazDbgValueConverterIntf = interface
procedure AddReference;
procedure ReleaseReference;
function GetObject: TObject;
function GetSettingsFrame: TLazDbgValueConverterSettingsFrameIntf;
end;
TLazDbgValueConvertSelectorIntf = interface
procedure AddFreeNotification(ANotification: TNotifyEvent);
procedure RemoveFreeNotification(ANotification: TNotifyEvent);
function GetBackendSpecificObject: TObject;
function GetConverter: TLazDbgValueConverterIntf;
function GetBackendSpecificObject: TObject; deprecated;
end;

View File

@ -6,7 +6,8 @@ interface
uses
Classes, SysUtils, DbgIntfDebuggerBase, IdeDebuggerBase, Debugger,
IdeDebuggerWatchResult, LazDebuggerIntf, LazDebuggerIntfBaseTypes;
IdeDebuggerWatchResult, LazDebuggerIntf, LazDebuggerIntfBaseTypes,
LazDebuggerValueConverter;
type
@ -90,7 +91,7 @@ type
procedure RemoveNotification(AnEventType: TWatcheEvaluateEvent;
AnEvent: TNotifyEvent);
function ResData: TLzDbgWatchDataIntf;
function GetFpDbgConverter: TObject;
function GetFpDbgConverter: TLazDbgValueConvertSelectorIntf;
protected
procedure RequestData;
function GetTypeInfo: TDBGType; override;
@ -428,7 +429,7 @@ begin
Result := FCurrentResData;
end;
function TTestWatchValue.GetFpDbgConverter: TObject;
function TTestWatchValue.GetFpDbgConverter: TLazDbgValueConvertSelectorIntf;
begin
Result := nil;
end;

View File

@ -8,7 +8,8 @@ uses
Classes, SysUtils, LazClasses, LazLoggerBase, IdeDebuggerWatchResult,
IdeDebuggerFpDbgValueConv, IdeDebuggerWatchResultJSon, DbgIntfDebuggerBase,
DbgIntfMiscClasses, LazDebuggerIntf, LazDebuggerTemplate,
LazDebuggerIntfBaseTypes, FpDebugValueConvertors;
LazDebuggerIntfBaseTypes, LazDebuggerValueConverter, FpDebugValueConvertors,
FpDebugConvDebugForJson;
type
@ -245,36 +246,55 @@ function TWatchValue.GetResultData: TWatchResultData;
Result := True;
end;
var
UsedConv: TLazDbgValueConverterIntf;
SrcData: TWatchResultData;
function CreateJson: TWatchResultDataJSon;
begin
Result := TWatchResultDataJSon.Create(SrcData.AsString);
Result.SetTypeName(SrcData.TypeName);
if SrcData.HasDataAddress then
Result.SetDataAddress(SrcData.DataAddress);
if (Result.Count > 0) or (Result.FieldCount > 0) then
FResultDataContent := rdcJSon;
if (UsedConv <> nil) and (UsedConv.GetObject is TFpDbgValueConverterJsonForDebug)
then begin
Result.JsonAddressKey := TFpDbgValueConverterJsonForDebug(UsedConv.GetObject).JsonAddressKey;
Result.JsonTypenameKey := TFpDbgValueConverterJsonForDebug(UsedConv.GetObject).JsonTypenameKey;
end;
end;
begin
Result := FResultData;
if (FResultDataContent = rdcNotSpecial) or (Result = nil) then
exit;
if FResultDataSpecialised <> nil then begin
Result := FResultDataSpecialised;
exit;
end;
if (Result.ValueKind = rdkConvertRes) and (Result.FieldCount > 0) and
(Result.Fields[0].Field.ValueKind <> rdkError)
then
Result := Result.Fields[0].Field;
Result := FResultData;
if (FResultDataContent = rdcNotSpecial) or (Result = nil) then
exit;
SrcData := FResultData;
UsedConv := nil;
if (SrcData.ValueKind = rdkConvertRes) and (SrcData.FieldCount > 0) and
(SrcData.Fields[0].Field <> nil) and
(SrcData.Fields[0].Field.ValueKind <> rdkError)
then begin
SrcData := SrcData.Fields[0].Field;
UsedConv := FResultData.BackendValueHandler;
end;
case FResultDataContent of
rdcJSon:
FResultDataSpecialised := TWatchResultDataJSon.Create(Result.AsString);
rdcJSon: begin
FResultDataSpecialised := CreateJson;
end;
else begin
FResultDataContent := rdcNotSpecial;
if (Result.ValueKind in [rdkString, rdkPrePrinted]) and (IsMaybeJson(Result.AsString)) then begin
FResultDataSpecialised := TWatchResultDataJSon.Create(Result.AsString);
TWatchResultDataJSon(FResultDataSpecialised).SetTypeName(FResultData.TypeName);
if FResultData.HasDataAddress then
TWatchResultDataJSon(FResultDataSpecialised).SetDataAddress(FResultData.DataAddress);
if (FResultDataSpecialised.Count > 0) or (FResultDataSpecialised.FieldCount > 0) then
FResultDataContent := rdcJSon;
if (SrcData.ValueKind in [rdkString, rdkPrePrinted]) and (IsMaybeJson(SrcData.AsString)) then begin
FResultDataSpecialised := CreateJson;
end;
if FResultDataContent = rdcNotSpecial then

View File

@ -698,7 +698,7 @@ type
// FDataFlags: TWatchResultDataFlags;
// Addr: TDbgPtr;
// MemDump
function GetBackendValueHandler: TLazDbgValueConverterIntf;
function GetBackendValueHandler: TLazDbgValueConverterIntf; virtual;
function GetClassID: TWatchResultDataClassID; virtual; //abstract;
protected
class function GetStorageClass: TWatchResultStorageClass; virtual; abstract;
@ -721,6 +721,7 @@ type
procedure ClearData; virtual; abstract;
protected
function GetValueKind: TWatchResultDataKind; virtual; //abstract;
function GetTypeName: String; virtual;
function GetAsString: String; virtual; abstract;
function GetAsDesc: String; virtual; abstract;
function GetAsWideString: WideString; virtual; abstract;
@ -776,7 +777,7 @@ type
function GetEnumerator: TWatchResultDataEnumerator; virtual;
public
property ValueKind: TWatchResultDataKind read GetValueKind;
property TypeName: String read FTypeName;
property TypeName: String read GetTypeName;
property AsString: String read GetAsString;
property AsDesc: String read GetAsDesc;
@ -1048,6 +1049,7 @@ type
protected
function GetHasDataAddress: Boolean; override;
function GetDataAddress: TDBGPtr; override;
procedure SetDataAddress(AnAddr: TDbgPtr); override;
public
constructor Create(AStringVal: String);
end;
@ -1444,7 +1446,7 @@ type
private
function GetClassID: TWatchResultDataClassID; override;
protected
function GetBackendValueHandler: TLazDbgValueConverterIntf;
function GetBackendValueHandler: TLazDbgValueConverterIntf; override;
public
constructor Create(AHandler: TLazDbgValueConverterIntf);
end;
@ -2582,6 +2584,11 @@ begin
Result := wdPrePrint;
end;
function TWatchResultData.GetTypeName: String;
begin
Result := FTypeName;
end;
function TWatchResultData.GetBackendValueHandler: TLazDbgValueConverterIntf;
begin
Result := nil;
@ -3462,6 +3469,11 @@ begin
Result := FData.GetDataAddress;
end;
procedure TWatchResultDataString.SetDataAddress(AnAddr: TDbgPtr);
begin
FData.FAddress := AnAddr;
end;
constructor TWatchResultDataString.Create(AStringVal: String);
begin
inherited Create;

View File

@ -17,12 +17,15 @@ type
FInternalJSon: TJSONData;
FIndex: Integer;
FCurData: TWatchResultDataJSonBase;
FJsonAddressKey: String;
FJsonTypenameKey: String;
function JSon: TJSONData; inline;
protected
function GetAsString: String; override;
function GetDataAddress: TDBGPtr; override;
function GetHasDataAddress: Boolean; override;
function GetTypeName: String; override;
// arary
function GetCount: Integer; override;
@ -39,6 +42,9 @@ type
procedure SetSelectedIndex(AnIndex: Integer); override;
function HandleExpressionSuffix(ASuffix: String): TWatchResultData; override;
property JsonAddressKey: String read FJsonAddressKey write FJsonAddressKey;
property JsonTypenameKey: String read FJsonTypenameKey write FJsonTypenameKey;
end;
{ TWatchResultDataJSon }
@ -92,18 +98,28 @@ function TWatchResultDataJSonBase.GetDataAddress: TDBGPtr;
var
j: TJSONData;
begin
Result := 0;
j := JSon;
if (j = nil) and not(j is TJSONObject) then
exit;
if (FJsonAddressKey = '') or (j = nil) or not(j is TJSONObject)
then
exit(inherited GetDataAddress);
if (TJSONObject(j).Elements['Address'] <> nil) then
j := TJSONObject(j).Elements['Address']
else
j := TJSONObject(j).Elements['DataAddress'];
try
j := TJSONObject(j).Elements[FJsonAddressKey];
except
j := nil;
end;
if j = nil then
exit(inherited GetDataAddress);
if j is TJSONString then begin
if not TryStrToQWord(j.AsString, Result) then
Result := inherited GetDataAddress;
exit;
end;
if ((j is TJSONFloatNumber)) or not(j is TJSONNumber) then
exit;
exit(inherited GetDataAddress);
if j is TJSONInt64Number then
Result := TDBGPtr(j.AsInt64)
@ -114,18 +130,48 @@ end;
function TWatchResultDataJSonBase.GetHasDataAddress: Boolean;
var
j: TJSONData;
d: QWord;
begin
Result := inherited GetHasDataAddress;
if Result then
exit;
j := JSon;
Result := (j <> nil) and (j is TJSONObject);
Result := (FJsonAddressKey <> '') and (j <> nil) and (j is TJSONObject);
if not Result then
exit;
if (TJSONObject(j).Elements['Address'] <> nil) then
j := TJSONObject(j).Elements['Address']
else
j := TJSONObject(j).Elements['DataAddress'];
try
j := TJSONObject(j).Elements[FJsonAddressKey];
except
j := nil;
end;
if j = nil then
exit(False);
Result := (j is TJSONNumber) and not (j is TJSONFloatNumber);
Result := ((j is TJSONNumber) and not (j is TJSONFloatNumber)) or
((j is TJSONString) and (TryStrToQWord(j.AsString, d)));
end;
function TWatchResultDataJSonBase.GetTypeName: String;
var
j: TJSONData;
begin
Result := '';
j := JSon;
if (FJsonTypenameKey = '') or (j = nil) or not(j is TJSONObject) then
exit(inherited GetTypeName);
try
j := TJSONObject(j).Elements[FJsonTypenameKey];
except
j := nil;
end;
if (j = nil) or not(j is TJSONString) then
exit(inherited GetTypeName);
Result := j.AsString;
end;
function TWatchResultDataJSonBase.GetCount: Integer;
@ -159,6 +205,10 @@ begin
FCurData := TWatchResultDataJSonBase.Create('');
if JSon <> nil then
FCurData.FInternalJSon := JSon.Items[FIndex];
TWatchResultDataJSon(FCurData).FJsonAddressKey := FJsonAddressKey;
TWatchResultDataJSon(FCurData).FJsonTypenameKey := FJsonTypenameKey;
Result := FCurData;
end;
@ -187,6 +237,10 @@ begin
FCurData.FInternalJSon := JSon.Items[AnIndex];
Result.FieldName := TJSONObject(JSon).Names[AnIndex];
end;
TWatchResultDataJSon(FCurData).FJsonAddressKey := FJsonAddressKey;
TWatchResultDataJSon(FCurData).FJsonTypenameKey := FJsonTypenameKey;
Result.Field := FCurData;
Result.Owner := Self;
end;
@ -316,6 +370,8 @@ begin
if (Idx > SfxLen) and (js <> nil) and (js <> JSon) then begin
Result := TWatchResultDataJSon.Create(js.AsJSON);
TWatchResultDataJSon(Result).FJsonAddressKey := FJsonAddressKey;
TWatchResultDataJSon(Result).FJsonTypenameKey := FJsonTypenameKey;
exit;
end;

View File

@ -17,6 +17,7 @@ object FpDbgValConvFrame: TFpDbgValConvFrame
BevelOuter = bvNone
ClientHeight = 150
ClientWidth = 512
Constraints.MinHeight = 80
TabOrder = 0
object lstConverters: TCheckListBox
Left = 5
@ -79,6 +80,7 @@ object FpDbgValConvFrame: TFpDbgValConvFrame
BevelOuter = bvNone
ClientHeight = 362
ClientWidth = 512
Constraints.MinHeight = 120
TabOrder = 2
object Panel4: TPanel
Left = 342
@ -111,6 +113,7 @@ object FpDbgValConvFrame: TFpDbgValConvFrame
Top = 25
Width = 160
ItemHeight = 15
OnChange = dropActionChange
Style = csDropDownList
TabOrder = 0
end
@ -181,6 +184,17 @@ object FpDbgValConvFrame: TFpDbgValConvFrame
Top = 150
Width = 512
Align = alTop
OnCanOffset = Splitter1CanOffset
ResizeAnchor = akTop
end
object pnlCurConvSetting: TPanel
Left = 0
Height = 0
Top = 519
Width = 512
Align = alBottom
AutoSize = True
Caption = 'PnlConvSetting'
TabOrder = 3
end
end

View File

@ -6,8 +6,8 @@ interface
uses
Classes, SysUtils, Forms, Controls, ExtCtrls, StdCtrls, CheckLst, LCLIntf,
Dialogs, StrUtils, FpDebugValueConvertors, IdeDebuggerStringConstants,
IdeDebuggerFpDbgValueConv;
Dialogs, StrUtils, FpDebugValueConvertors, LazDebuggerValueConverter,
IdeDebuggerStringConstants, IdeDebuggerFpDbgValueConv;
type
@ -26,23 +26,34 @@ type
memoTypeNames: TMemo;
Panel1: TPanel;
Panel2: TPanel;
pnlCurConvSetting: TPanel;
pnlCurrentConv: TPanel;
Panel4: TPanel;
Panel5: TPanel;
Splitter1: TSplitter;
procedure btnAddClick(Sender: TObject);
procedure btnRemoveClick(Sender: TObject);
procedure dropActionChange(Sender: TObject);
procedure lstConvertersClick(Sender: TObject);
procedure lstConvertersItemClick(Sender: TObject; Index: integer);
procedure Splitter1CanOffset(Sender: TObject; var NewOffset: Integer;
var Accept: Boolean);
private
FValConvList: TIdeFpDbgConverterConfigList;
FCurIdx: Integer;
FCurValConv: TIdeFpDbgConverterConfig;
FCurConvConf: TIdeFpDbgConverterConfig;
FCurConv: TLazDbgValueConverterIntf;
FCurConvSettings: TLazDbgValueConverterSettingsFrameIntf;
procedure SetCurConv(AValConv: TIdeFpDbgConverterConfig);
procedure UpdateConvForClass;
procedure UpdateConvPanel;
procedure FillList;
procedure UpdateButtons;
procedure SetValConvList(AValue: TIdeFpDbgConverterConfigList);
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
procedure SaveCurrent;
procedure Setup;
@ -67,7 +78,7 @@ begin
SaveCurrent;
FCurValConv := nil;
FCurConvConf := nil;
AvailClass := ValueConverterClassList;
obj := TIdeFpDbgConverterConfig.Create(AvailClass[0].Create);
obj.Enabled := True;
@ -86,7 +97,7 @@ var
i: Integer;
begin
SaveCurrent;
FCurValConv := nil;
FCurConvConf := nil;
i := lstConverters.ItemIndex;
FValConvList.Delete(i);
@ -97,6 +108,11 @@ begin
lstConvertersClick(nil);
end;
procedure TFpDbgValConvFrame.dropActionChange(Sender: TObject);
begin
UpdateConvForClass;
end;
procedure TFpDbgValConvFrame.lstConvertersClick(Sender: TObject);
var
AvailClass: TFpDbgValueConverterClassList;
@ -107,20 +123,20 @@ begin
FCurIdx := lstConverters.ItemIndex;
if FCurIdx >= FValConvList.Count then begin
FCurIdx := -1;
FCurValConv := nil;
FCurConvConf := nil;
lblDesc.Caption := '';
EdName.Text := '';
memoTypeNames.Text := '';
end
else
FCurValConv := FValConvList[FCurIdx];
SetCurConv(FValConvList[FCurIdx]);
lblDesc.Caption := FCurValConv.Converter.GetName;
EdName.Text := FCurValConv.Name;
memoTypeNames.Text := FCurValConv.MatchTypeNames.Text;
lblDesc.Caption := FCurConvConf.Converter.GetName;
EdName.Text := FCurConvConf.Name;
memoTypeNames.Text := FCurConvConf.MatchTypeNames.Text;
AvailClass := ValueConverterClassList;
dropAction.ItemIndex := AvailClass.IndexOf(TFpDbgValueConverterClass(FCurValConv.Converter.ClassType));
dropAction.ItemIndex := AvailClass.IndexOf(TFpDbgValueConverterClass(FCurConvConf.Converter.ClassType));
lstConvertersItemClick(nil, FCurIdx);
end;
@ -141,12 +157,55 @@ begin
UpdateButtons;
end;
procedure TFpDbgValConvFrame.Splitter1CanOffset(Sender: TObject;
var NewOffset: Integer; var Accept: Boolean);
begin
end;
procedure TFpDbgValConvFrame.SetCurConv(AValConv: TIdeFpDbgConverterConfig);
begin
FCurConvConf := AValConv;
FCurConv := TLazDbgValueConvertSelectorIntf(FCurConvConf).GetConverter;
UpdateConvPanel;
end;
procedure TFpDbgValConvFrame.UpdateConvForClass;
var
AvailClass: TFpDbgValueConverterClassList;
begin
if FCurConvConf = nil then
exit;
AvailClass := ValueConverterClassList;
if (dropAction.ItemIndex <> AvailClass.IndexOf(TFpDbgValueConverterClass(FCurConv.GetObject.ClassType))) then begin
FCurConv := AvailClass[dropAction.ItemIndex].Create;
UpdateConvPanel;
end;
end;
procedure TFpDbgValConvFrame.UpdateConvPanel;
var
F: TFrame;
begin
if FCurConvSettings <> nil then
FCurConvSettings.Free;
FCurConvSettings := FCurConv.GetSettingsFrame;
if FCurConvSettings <> nil then begin
F := TFrame(FCurConvSettings.GetFrame);
F.Parent := pnlCurConvSetting;
F.Align := alClient;
FCurConvSettings.ReadFrom(FCurConv);
end;
end;
procedure TFpDbgValConvFrame.FillList;
var
i: Integer;
obj: TIdeFpDbgConverterConfig;
begin
FCurValConv := nil;
FCurConvConf := nil;
lstConverters.Clear;
for i := 0 to FValConvList.Count - 1 do begin
@ -160,14 +219,14 @@ procedure TFpDbgValConvFrame.UpdateButtons;
begin
btnAdd.Enabled := ValueConverterClassList.Count > 0;
btnRemove.Enabled := (lstConverters.Count > 0) and (lstConverters.ItemIndex >= 0);
pnlCurrentConv.Enabled := FCurValConv <> nil;
pnlCurrentConv.Enabled := FCurConvConf <> nil;
end;
procedure TFpDbgValConvFrame.SetValConvList(AValue: TIdeFpDbgConverterConfigList);
begin
if FValConvList = AValue then Exit;
FValConvList := AValue;
FCurValConv := nil;
FCurConvConf := nil;
FillList;
@ -182,21 +241,20 @@ procedure TFpDbgValConvFrame.SaveCurrent;
var
AvailClass: TFpDbgValueConverterClassList;
begin
if FCurValConv = nil then
if FCurConvConf = nil then
exit;
AvailClass := ValueConverterClassList;
if (TrimSet(FCurValConv.MatchTypeNames.Text, [#1..#32]) <> TrimSet(memoTypeNames.Text, [#1..#32])) or
(dropAction.ItemIndex <> AvailClass.IndexOf(TFpDbgValueConverterClass(FCurValConv.Converter.ClassType))) or
(EdName.Text <> FCurValConv.Name)
if ( (FCurConv = nil) or (FCurConvSettings = nil) or FCurConvSettings.WriteTo(FCurConv) ) or
(TrimSet(FCurConvConf.MatchTypeNames.Text, [#1..#32]) <> TrimSet(memoTypeNames.Text, [#1..#32])) or
(FCurConvConf.Converter <> FCurConv) or
(EdName.Text <> FCurConvConf.Name)
then begin
FValConvList.Changed := True;
if (dropAction.ItemIndex <> AvailClass.IndexOf(TFpDbgValueConverterClass(FCurValConv.Converter.ClassType))) then begin
FCurValConv.Converter := AvailClass[dropAction.ItemIndex].Create;
FCurValConv.MatchKinds := FCurValConv.Converter.GetSupportedKinds;
end;
FCurValConv.MatchTypeNames.Text := memoTypeNames.Text;
FCurValConv.Name := EdName.Text
FCurConvConf.Converter := TFpDbgValueConverter(FCurConv.GetObject);
FCurConvConf.MatchKinds := FCurConvConf.Converter.GetSupportedKinds;
FCurConvConf.MatchTypeNames.Text := memoTypeNames.Text;
FCurConvConf.Name := EdName.Text
end;
end;
@ -211,7 +269,7 @@ begin
lblTypeNames.Caption := dlgFpConvOptMatchTypesByName;
lblAction.Caption := dlgFpConvOptAction;
FCurValConv := nil;
FCurConvConf := nil;
lblDesc.Caption := '-';
dropAction.Clear;
@ -228,5 +286,13 @@ begin
Setup;
end;
destructor TFpDbgValConvFrame.Destroy;
begin
if FCurConvSettings <> nil then
FCurConvSettings.Free;
inherited Destroy;
end;
end.