paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-11-02 05:00:01 +01:00
Code Issues Packages Projects Releases Wiki Activity

LazDebuggerFPDServer: Callstack-support added

Browse Source 
git-svn-id: trunk@49220 -
This commit is contained in:
joost 2015-05-30 09:50:18 +00:00
parent 1aaab1734c
commit ecfcd3a2a5
2 changed files with 158 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
components/lazdebuggers/lazdebuggerfpdserver/fpdserverdebugger.pas
View File

@ -11,6 +11,7 @@ uses
forms,
DbgIntfDebuggerBase,
DbgIntfBaseTypes,
maps,
fpjson,
jsonparser,
BaseUnix,
@ -198,6 +199,21 @@ type
procedure DoOnCommandFailed(ACommandResponse: TJSonObject); override;
end;
{ TFPDSendCallStackCommand }
TFPDSendCallStackCommand = class(TFPDSendCommand)
private
FCallStack: TCallStackBase;
FCallStackSupplier: TCallStackSupplier;
procedure DoCallStackFreed(Sender: TObject);
protected
procedure ComposeJSon(AJsonObject: TJSONObject); override;
public
constructor create(ACallStack: TCallStackBase; ACallStackSupplier: TCallStackSupplier);
destructor Destroy; override;
procedure DoOnCommandSuccesfull(ACommandResponse: TJSonObject); override;
procedure DoOnCommandFailed(ACommandResponse: TJSonObject); override;
end;
{ TFPDSocketThread }
@ -258,6 +274,7 @@ type
class function Caption: String; override;
function CreateBreakPoints: TDBGBreakPoints; override;
function CreateWatches: TWatchesSupplier; override;
function CreateCallStack: TCallStackSupplier; override;
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; override;
// These methods are called by several TFPDSendCommands after success or failure of a command. (Most common
// because the TFPDSendCommands do not have access to TFPDServerDebugger's protected methods theirself)
@ -310,6 +327,19 @@ type
procedure InternalRequestData(AWatchValue: TWatchValue); override;
end;
{ TFPCallStackSupplier }
TFPCallStackSupplier = class(TCallStackSupplier)
public
procedure RequestCount(ACallstack: TCallStackBase); override;
procedure RequestEntries(ACallstack: TCallStackBase); override;
procedure RequestCurrent(ACallstack: TCallStackBase); override;
// Used in the succes callback of the TFPDSendCallStackCommand command to trigger
// an update og the GUI after the callstack has been read.
procedure DoUpdate;
end;
procedure Register;
begin
RegisterDebugger(TFPDServerDebugger);
@ -319,6 +349,40 @@ end;
var GCommandUID: integer = 0;
{ TFPCallStackSupplier }
procedure TFPCallStackSupplier.RequestCount(ACallstack: TCallStackBase);
begin
if (Debugger = nil) or not(Debugger.State = dsPause)
then begin
ACallstack.SetCountValidity(ddsInvalid);
exit;
end;
TFPDServerDebugger(Debugger).QueueCommand(TFPDSendCallStackCommand.create(ACallstack, Self));
ACallstack.SetCountValidity(ddsRequested);
end;
procedure TFPCallStackSupplier.RequestEntries(ACallstack: TCallStackBase);
begin
if (Debugger = nil) or not(Debugger.State = dsPause)
then begin
ACallstack.SetCountValidity(ddsInvalid);
exit;
end;
end;
procedure TFPCallStackSupplier.RequestCurrent(ACallstack: TCallStackBase);
begin
ACallstack.CurrentIndex := 0;
ACallstack.SetCurrentValidity(ddsValid);
end;
procedure TFPCallStackSupplier.DoUpdate;
begin
Changed;
end;
{ TFPDSendWatchEvaluateCommand }
procedure TFPDSendWatchEvaluateCommand.DoWatchFreed(Sender: TObject);
@ -342,7 +406,7 @@ end;
destructor TFPDSendWatchEvaluateCommand.Destroy;
begin
FWatchValue.RemoveFreeeNotification(@DoWatchFreed);
FWatchValue.RemoveFreeNotification(@DoWatchFreed);
inherited Destroy;
end;
@ -1101,6 +1165,11 @@ begin
Result := TFPWatches.Create(Self);
end;
function TFPDServerDebugger.CreateCallStack: TCallStackSupplier;
begin
Result:=TFPCallStackSupplier.Create(Self);
end;
function TFPDServerDebugger.RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean;
var
ASendCommand: TFPDSendEvaluateCommand;

88
components/lazdebuggers/lazdebuggerfpdserver/fpdserverdebuggercommands.inc
View File

@ -163,3 +163,91 @@ begin
AJsonObject.Add('command','continue');
end;
{ TFPDSendCallStackCommand }
procedure TFPDSendCallStackCommand.DoCallStackFreed(Sender: TObject);
begin
FCallStack:=nil;
end;
procedure TFPDSendCallStackCommand.ComposeJSon(AJsonObject: TJSONObject);
begin
inherited ComposeJSon(AJsonObject);
AJsonObject.Add('command','stacktrace');
end;
constructor TFPDSendCallStackCommand.create(ACallStack: TCallStackBase; ACallStackSupplier: TCallStackSupplier);
begin
inherited create(True);
ACallStack.AddFreeNotification(@DoCallStackFreed);
FCallStack := ACallStack;
FCallStackSupplier := ACallStackSupplier;
end;
destructor TFPDSendCallStackCommand.Destroy;
begin
FCallStack.RemoveFreeNotification(@DoCallStackFreed);
inherited Destroy;
end;
procedure TFPDSendCallStackCommand.DoOnCommandSuccesfull(ACommandResponse: TJSonObject);
var
JSonCallStackArr: TJSONArray;
JSonCallStackEntryObj: TJSONObject;
e: TCallStackEntry;
It: TMapIterator;
AnAddress: TDBGPtr;
FunctionName: string;
SourceFile: string;
Line: integer;
begin
inherited DoOnCommandSuccesfull(ACommandResponse);
if assigned(FCallStack) then
begin
JSonCallStackArr := ACommandResponse.Get('callstack', TJSONArray(nil));
if assigned(JSonCallStackArr) and (JSonCallStackArr.Count>0) then
begin
FCallStack.Count:=JSonCallStackArr.Count;
FCallStack.SetCountValidity(ddsValid);
It := TMapIterator.Create(FCallstack.RawEntries);
if not It.Locate(FCallstack.LowestUnknown )
then if not It.EOM
then It.Next;
while (not IT.EOM) and (TCallStackEntry(It.DataPtr^).Index < FCallstack.HighestUnknown) do
begin
e := TCallStackEntry(It.DataPtr^);
if e.Validity = ddsRequested then
begin
JSonCallStackEntryObj := JSonCallStackArr.Items[e.Index] as TJSONObject;
AnAddress:=Hex2Dec(JSonCallStackEntryObj.Get('address','0'));
FunctionName:=JSonCallStackEntryObj.Get('functionname','');
SourceFile:=JSonCallStackEntryObj.Get('sourcefile','');
Line:=JSonCallStackEntryObj.get('line',-1);
e.Init(AnAddress, nil, FunctionName, SourceFile, '', Line, ddsValid);
end;
It.Next;
end;
It.Free;
FCallStack.SetCountValidity(ddsValid);
TFPCallStackSupplier(FCallStackSupplier).DoUpdate;
end
else
begin
FCallStack.SetCountValidity(ddsInvalid);
FCallStack.SetHasAtLeastCountInfo(ddsInvalid);
end;
end;
end;
procedure TFPDSendCallStackCommand.DoOnCommandFailed(ACommandResponse: TJSonObject);
begin
FCallStack.SetCountValidity(ddsInvalid);
end;