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

DebuggerIntf: Refactor, evaluate now takes a callback

Browse Source 
git-svn-id: trunk@58238 -
This commit is contained in:
martin 2018-06-12 22:58:35 +00:00
parent 7da1636ffa
commit cef14db081
11 changed files with 335 additions and 196 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
components/debuggerintf/dbgintfdebuggerbase.pp
View File

@ -1710,6 +1710,8 @@ type
AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults
): TDBGFeedbackResult of object;
TDBGEvaluateResultCallback = procedure(Sender: TObject; ASuccess: Boolean; ResultText: String;
ResultDBGType: TDBGType) of object;
TDebuggerNotifyReason = (dnrDestroy);
@ -1770,8 +1772,11 @@ type
//function GetUnitInfoProvider: TDebuggerUnitInfoProvider;
function GetState: TDBGState;
function ReqCmd(const ACommand: TDBGCommand;
const AParams: array of const): Boolean;
procedure SetDebuggerEnvironment (const AValue: TStrings );
const AParams: array of const): Boolean; overload;
function ReqCmd(const ACommand: TDBGCommand;
const AParams: array of const;
const ACallback: TMethod): Boolean;
procedure SetDebuggerEnvironment (const AValue: TStrings ); overload;
procedure SetEnvironment(const AValue: TStrings);
procedure SetFileName(const AValue: String);
protected
@ -1804,7 +1809,8 @@ type
function GetWaiting: Boolean; virtual;
function GetIsIdle: Boolean; virtual;
function RequestCommand(const ACommand: TDBGCommand;
const AParams: array of const): Boolean;
const AParams: array of const;
const ACallback: TMethod): Boolean;
virtual; abstract; // True if succesful
procedure SetExitCode(const AValue: Integer);
procedure SetState(const AValue: TDBGState);
@ -1853,8 +1859,7 @@ type
procedure Attach(AProcessID: String);
procedure Detach;
procedure SendConsoleInput(AText: String);
function Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType;
function Evaluate(const AExpression: String; ACallback: TDBGEvaluateResultCallback;
EvalFlags: TDBGEvaluateFlags = []): Boolean; // Evaluates the given expression, returns true if valid
function GetProcessList({%H-}AList: TRunningProcessInfoList): boolean; virtual;
function Modify(const AExpression, AValue: String): Boolean; // Modifies the given expression, returns true if valid
@ -5837,11 +5842,10 @@ begin
Result := False;
end;
function TDebuggerIntf.Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType; EvalFlags: TDBGEvaluateFlags = []): Boolean;
function TDebuggerIntf.Evaluate(const AExpression: String;
ACallback: TDBGEvaluateResultCallback; EvalFlags: TDBGEvaluateFlags): Boolean;
begin
FreeAndNIL(ATypeInfo);
Result := ReqCmd(dcEvaluate, [AExpression, @AResult, @ATypeInfo, Integer(EvalFlags)]);
Result := ReqCmd(dcEvaluate, [AExpression, Integer(EvalFlags)], TMethod(ACallback));
end;
function TDebuggerIntf.GetProcessList(AList: TRunningProcessInfoList): boolean;
@ -5896,6 +5900,16 @@ begin
Result := FState;
end;
function TDebuggerIntf.ReqCmd(const ACommand: TDBGCommand;
const AParams: array of const): Boolean;
var
dummy: TMethod;
begin
dummy.Code := nil;
dummy.Data := nil;
ReqCmd(ACommand, AParams, dummy);
end;
function TDebuggerIntf.GetSupportedCommands: TDBGCommands;
begin
Result := [];
@ -5951,12 +5965,12 @@ begin
end;
function TDebuggerIntf.ReqCmd(const ACommand: TDBGCommand;
const AParams: array of const): Boolean;
const AParams: array of const; const ACallback: TMethod): Boolean;
begin
if FState = dsNone then Init;
if ACommand in Commands
then begin
Result := RequestCommand(ACommand, AParams);
Result := RequestCommand(ACommand, AParams, ACallback);
if not Result then begin
DebugLn(DBG_WARNINGS, 'TDebuggerIntf.ReqCmd failed: ',dbgs(ACommand));
end;

66
components/lazdebuggergdbmi/gdbmidebugger.pp
View File

@ -805,8 +805,9 @@ type
procedure DoPseudoTerminalRead(Sender: TObject);
// Implementation of external functions
function GDBEnvironment(const AVariable: String; const ASet: Boolean): Boolean;
function GDBEvaluate(const AExpression: String; var AResult: String;
out ATypeInfo: TGDBType; EvalFlags: TDBGEvaluateFlags): Boolean;
function GDBEvaluate(const AExpression: String; EvalFlags: TDBGEvaluateFlags; ACallback: TDBGEvaluateResultCallback): Boolean;
procedure GDBEvaluateCommandCancelled(Sender: TObject);
procedure GDBEvaluateCommandExecuted(Sender: TObject);
function GDBModify(const AExpression, ANewValue: String): Boolean;
procedure GDBModifyDone(const {%H-}AResult: TGDBMIExecResult; const {%H-}ATag: PtrInt);
function GDBRun: Boolean;
@ -877,7 +878,7 @@ type
function ParseInitialization: Boolean; virtual;
function CreateCommandInit: TGDBMIDebuggerCommandInitDebugger; virtual;
function CreateCommandStartDebugging(AContinueCommand: TGDBMIDebuggerCommand): TGDBMIDebuggerCommandStartDebugging; virtual;
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; override;
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const; const ACallback: TMethod): Boolean; override;
property CurrentCmdIsAsync: Boolean read FCurrentCmdIsAsync;
property CurrentCommand: TGDBMIDebuggerCommand read FCurrentCommand;
@ -1204,6 +1205,8 @@ type
FParsedExpression: String;
FCurrentCmd: TGDBMIDebuggerCommandBreakPointBase;
FUpdateFlags: TGDBMIBreakPointUpdateFlags;
procedure DoLogExpressionCallback(Sender: TObject; ASuccess: Boolean;
ResultText: String; ResultDBGType: TDBGType);
procedure SetBreakPoint;
procedure ReleaseBreakPoint;
procedure UpdateProperties(AFlags: TGDBMIBreakPointUpdateFlags);
@ -1275,6 +1278,7 @@ type
TGDBMIDebuggerCommandEvaluate = class(TGDBMIDebuggerCommand)
private
FCallback: TDBGEvaluateResultCallback;
FEvalFlags: TDBGEvaluateFlags;
FExpression: String;
FDisplayFormat: TWatchDisplayFormat;
@ -1305,6 +1309,7 @@ type
property TextValue: String read FTextValue;
property TypeInfo: TGDBType read GetTypeInfo;
property TypeInfoAutoDestroy: Boolean read FTypeInfoAutoDestroy write FTypeInfoAutoDestroy;
property Callback: TDBGEvaluateResultCallback read FCallback write FCallback;
end;
{%endregion ^^^^^ Watches ^^^^^ }
@ -8352,22 +8357,35 @@ begin
end;
end;
function TGDBMIDebugger.GDBEvaluate(const AExpression: String; var AResult: String;
out ATypeInfo: TGDBType; EvalFlags: TDBGEvaluateFlags): Boolean;
procedure TGDBMIDebugger.GDBEvaluateCommandCancelled(Sender: TObject);
begin
TGDBMIDebuggerCommandEvaluate(Sender).Callback(Self, False, '', nil);
end;
procedure TGDBMIDebugger.GDBEvaluateCommandExecuted(Sender: TObject);
begin
if TGDBMIDebuggerCommandEvaluate(Sender).EvalFlags * [defNoTypeInfo, defSimpleTypeInfo, defFullTypeInfo] = [defNoTypeInfo]
then FreeAndNil(TGDBMIDebuggerCommandEvaluate(Sender).FTypeInfo);
with TGDBMIDebuggerCommandEvaluate(Sender) do
Callback(Self, True, TextValue, TypeInfo);
end;
function TGDBMIDebugger.GDBEvaluate(const AExpression: String;
EvalFlags: TDBGEvaluateFlags; ACallback: TDBGEvaluateResultCallback): Boolean;
var
CommandObj: TGDBMIDebuggerCommandEvaluate;
TypeInfo: TGDBType;
begin
CommandObj := TGDBMIDebuggerCommandEvaluate.Create(Self, AExpression, wdfDefault);
CommandObj.EvalFlags := EvalFlags;
CommandObj.AddReference;
CommandObj.Priority := GDCMD_PRIOR_IMMEDIATE; // try run imediately
CommandObj.Callback := ACallback;
CommandObj.OnExecuted := @GDBEvaluateCommandExecuted;
CommandObj.OnCancel := @GDBEvaluateCommandCancelled;
QueueCommand(CommandObj);
Result := CommandObj.State in [dcsExecuting, dcsFinished];
AResult := CommandObj.TextValue;
ATypeInfo := CommandObj.TypeInfo;
if EvalFlags * [defNoTypeInfo, defSimpleTypeInfo, defFullTypeInfo] = [defNoTypeInfo]
then FreeAndNil(ATypeInfo);
CommandObj.ReleaseReference;
Result := true;
end;
function TGDBMIDebugger.GDBModify(const AExpression, ANewValue: String): Boolean;
@ -8866,7 +8884,8 @@ begin
mtInformation, [mbOK], 0);
end;
function TGDBMIDebugger.RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean;
function TGDBMIDebugger.RequestCommand(const ACommand: TDBGCommand;
const AParams: array of const; const ACallback: TMethod): Boolean;
var
EvalFlags: TDBGEvaluateFlags;
begin
@ -8885,11 +8904,10 @@ begin
dcDetach: Result := GDBDetach;
dcEvaluate: begin
EvalFlags := [];
if high(AParams) >= 3 then
EvalFlags := TDBGEvaluateFlags(AParams[3].VInteger);
if high(AParams) >= 1 then
EvalFlags := TDBGEvaluateFlags(AParams[1].VInteger);
Result := GDBEvaluate(String(AParams[0].VAnsiString),
String(AParams[1].VPointer^), TGDBType(AParams[2].VPointer^),
EvalFlags);
EvalFlags, TDBGEvaluateResultCallback(ACallback));
end;
dcModify: Result := GDBModify(String(AParams[0].VAnsiString), String(AParams[1].VAnsiString));
dcEnvironment: Result := GDBEnvironment(String(AParams[0].VAnsiString), AParams[1].VBoolean);
@ -9448,16 +9466,16 @@ begin
end;
end;
procedure TGDBMIBreakPoint.DoLogExpression(const AnExpression: String);
var
s: String;
t: TGDBType;
procedure TGDBMIBreakPoint.DoLogExpressionCallback(Sender: TObject;
ASuccess: Boolean; ResultText: String; ResultDBGType: TDBGType);
begin
s:='';
if TGDBMIDebugger(Debugger).GDBEvaluate(AnExpression, s, t, [defNoTypeInfo])
then begin
TGDBMIDebugger(Debugger).DoDbgEvent(ecBreakpoint, etBreakpointEvaluation, s);
end;
if ASuccess then
TGDBMIDebugger(Sender).DoDbgEvent(ecBreakpoint, etBreakpointEvaluation, ResultText);
end;
procedure TGDBMIBreakPoint.DoLogExpression(const AnExpression: String);
begin
TGDBMIDebugger(Debugger).GDBEvaluate(AnExpression, [defNoTypeInfo], @DoLogExpressionCallback);
end;
procedure TGDBMIBreakPoint.MakeInvalid;

18
components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas
View File

@ -133,7 +133,8 @@ type
function CreateDisassembler: TDBGDisassembler; override;
function CreateBreakPoints: TDBGBreakPoints; override;
function RequestCommand(const ACommand: TDBGCommand;
const AParams: array of const): Boolean; override;
const AParams: array of const;
const ACallback: TMethod): Boolean; override;
function ChangeFileName: Boolean; override;
procedure OnLog(const AString: string; const ALogLevel: TFPDLogLevel);
@ -1625,11 +1626,12 @@ begin
end;
function TFpDebugDebugger.RequestCommand(const ACommand: TDBGCommand;
const AParams: array of const): Boolean;
const AParams: array of const; const ACallback: TMethod): Boolean;
var
EvalFlags: TDBGEvaluateFlags;
AConsoleTty: string;
AConsoleTty, ResText: string;
addr: TDBGPtrArray;
ResType: TDBGType;
begin
result := False;
if assigned(FDbgController) then
@ -1737,11 +1739,13 @@ begin
end;
dcEvaluate:
begin
EvalFlags := TDBGEvaluateFlags(AParams[3].VInteger);
Result := False;
EvalFlags := TDBGEvaluateFlags(AParams[1].VInteger);
Result := EvaluateExpression(nil, String(AParams[0].VAnsiString),
String(AParams[1].VPointer^), TDBGType(AParams[2].VPointer^),
EvalFlags);
ResText, ResType, EvalFlags);
if EvalFlags * [defNoTypeInfo, defSimpleTypeInfo, defFullTypeInfo] = [defNoTypeInfo]
then FreeAndNil(ResType);
TDBGEvaluateResultCallback(ACallback)(Self, Result, ResText, ResType);
Result := True;
end;
dcSendConsoleInput:
begin

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

@ -326,7 +326,9 @@ type
function CreateRegisters: TRegisterSupplier; override;
function CreateCallStack: TCallStackSupplier; override;
function CreateDisassembler: TDBGDisassembler; override;
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; override;
function RequestCommand(const ACommand: TDBGCommand;
const AParams: array of const;
const ACallback: TMethod = nil): 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)
procedure DoOnRunFailed;
@ -1428,7 +1430,8 @@ begin
Result:=TFPDBGDisassembler.Create(Self);
end;
function TFPDServerDebugger.RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean;
function TFPDServerDebugger.RequestCommand(const ACommand: TDBGCommand;
const AParams: array of const; const ACallback: TMethod): Boolean;
var
ASendCommand: TFPDSendEvaluateCommand;
tc: qword;
@ -1494,8 +1497,8 @@ begin
sleep(5);
Application.ProcessMessages;
until (ASendCommand.Validity<>ddsRequested) or ((GetTickCount64-tc)>2000);
String(AParams[1].VPointer^) := ASendCommand.Message;
TDBGType(AParams[2].VPointer^) := nil;
ACallback(Self, True, ASendCommand.Message, nil);
Result := True;
ASendCommand.Free;
end
else

21
components/lazdebuggers/lazdebuggerfpgdbmi/fpgdbmidebugger.pp
View File

@ -84,7 +84,9 @@ type
function HasDwarf: Boolean;
procedure LoadDwarf;
procedure UnLoadDwarf;
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; override;
function RequestCommand(const ACommand: TDBGCommand;
const AParams: array of const;
const ACallback: TMethod): Boolean; override;
procedure QueueCommand(const ACommand: TGDBMIDebuggerCommand; ForceQueue: Boolean = False);
procedure GetCurrentContext(out AThreadId, AStackFrame: Integer);
@ -779,26 +781,31 @@ begin
end;
function TFpGDBMIDebugger.RequestCommand(const ACommand: TDBGCommand;
const AParams: array of const): Boolean;
const AParams: array of const; const ACallback: TMethod): Boolean;
var
EvalFlags: TDBGEvaluateFlags;
ResText: String;
ResType: TDBGType;
begin
if (ACommand = dcEvaluate) then begin
EvalFlags := [];
EvalFlags := TDBGEvaluateFlags(AParams[3].VInteger);
EvalFlags := TDBGEvaluateFlags(AParams[1].VInteger);
Result := False;
if (HasDwarf) and (not UseGDB) then begin
Result := EvaluateExpression(nil, String(AParams[0].VAnsiString),
String(AParams[1].VPointer^), TDBGType(AParams[2].VPointer^),
EvalFlags);
ResText, ResType, EvalFlags);
if EvalFlags * [defNoTypeInfo, defSimpleTypeInfo, defFullTypeInfo] = [defNoTypeInfo]
then FreeAndNil(ResType);
TDBGEvaluateResultCallback(ACallback)(Self, Result, ResText, ResType);
Result := True;
end;
if not Result then begin
Result := inherited RequestCommand(ACommand, AParams);
Result := inherited RequestCommand(ACommand, AParams, ACallback);
String(AParams[1].VPointer^) := '{GDB:}'+String(AParams[1].VPointer^);
end;
end
else
Result := inherited RequestCommand(ACommand, AParams);
Result := inherited RequestCommand(ACommand, AParams, ACallback);
end;
procedure TFpGDBMIDebugger.QueueCommand(const ACommand: TGDBMIDebuggerCommand;

76
debugger/evaluatedlg.pp
View File

@ -39,7 +39,7 @@ interface
uses
Classes, SysUtils, LCLType, Forms,
IDEWindowIntf, IDEImagesIntf, DbgIntfDebuggerBase, LazarusIDEStrConsts,
ComCtrls, StdCtrls, Menus, Dialogs, DebuggerDlg, BaseDebugManager,
ComCtrls, StdCtrls, Menus, Dialogs, Controls, DebuggerDlg, BaseDebugManager,
InputHistory, IDEProcs, Debugger, DebuggerStrConst;
type
@ -87,6 +87,8 @@ type
private
fHistDirection:TEvalHistDirection;
procedure EvaluateCallback(Sender: TObject; ASuccess: Boolean;
ResultText: String; ResultDBGType: TDBGType);
function GetFindText: string;
procedure SetFindText(const NewFindText: string);
procedure Evaluate;
@ -142,49 +144,58 @@ begin
mnuHistory.Items[2].Caption:=dsrEvalHistoryDown;
end;
procedure TEvaluateDlg.Evaluate;
procedure TEvaluateDlg.EvaluateCallback(Sender: TObject; ASuccess: Boolean;
ResultText: String; ResultDBGType: TDBGType);
var
S, R: String;
DBGType: TDBGType;
Opts: TDBGEvaluateFlags;
S: TCaption;
begin
S := cmbExpression.Text;
InputHistories.HistoryLists.Add(ClassName, S,rltCaseSensitive);
DBGType:=nil;
Opts := [];
if chkTypeCast.Checked then
Opts := [defClassAutoCast];
R:='';
if DebugBoss.Evaluate(S, R, DBGType, Opts)
then begin
if ASuccess then begin
if cmbExpression.Items.IndexOf(S) = -1
then cmbExpression.Items.Insert(0, S);
tbModify.Enabled := True;
if (DBGType <> nil) and (DBGType.Attributes * [saArray, saDynArray] <> []) and (DBGType.Len >= 0)
then R := Format(drsLen, [DBGType.Len]) + LineEnding + R;
if (ResultDBGType <> nil) and (ResultDBGType.Attributes * [saArray, saDynArray] <> []) and (ResultDBGType.Len >= 0)
then ResultText := Format(drsLen, [ResultDBGType.Len]) + LineEnding + ResultText;
end
else
tbModify.Enabled := False;
FreeAndNil(DBGType);
FreeAndNil(ResultDBGType);
if fHistDirection<>EHDNone then
begin
if txtResult.Lines.Text='' then
txtResult.Lines.Text := RESULTEVAL+ S+':'+LineEnding+ R + LineEnding
txtResult.Lines.Text := RESULTEVAL+ S+':'+LineEnding+ ResultText + LineEnding
else
if fHistDirection=EHDUp then
txtResult.Lines.Text := RESULTEVAL+ S+':'+LineEnding+ R + LineEnding
txtResult.Lines.Text := RESULTEVAL+ S+':'+LineEnding+ ResultText + LineEnding
+ RESULTSEPARATOR + LineEnding + txtResult.Lines.Text
else
begin
txtResult.Lines.Text := txtResult.Lines.Text + RESULTSEPARATOR + LineEnding
+ RESULTEVAL+ S+':'+LineEnding+ R+LineEnding;
+ RESULTEVAL+ S+':'+LineEnding+ ResultText+LineEnding;
txtResult.SelStart:=length(txtResult.Lines.Text);
end;
end
else
txtResult.Lines.Text := R;
txtResult.Lines.Text := ResultText;
end;
procedure TEvaluateDlg.Evaluate;
var
S: String;
Opts: TDBGEvaluateFlags;
begin
S := cmbExpression.Text;
InputHistories.HistoryLists.Add(ClassName, S,rltCaseSensitive);
Opts := [];
if chkTypeCast.Checked then
Opts := [defClassAutoCast];
if not DebugBoss.Evaluate(S, @EvaluateCallback, Opts)
then
EvaluateCallback(nil, false, '', nil);
end;
procedure TEvaluateDlg.cmbExpressionChange(Sender: TObject);
@ -248,8 +259,7 @@ end;
procedure TEvaluateDlg.Modify;
var
S, V, R: String;
DBGType: TDBGType;
S, V: String;
begin
S := Trim(cmbExpression.Text);
if S = '' then Exit;
@ -263,27 +273,7 @@ begin
if cmbNewValue.Items.IndexOf(V) = -1
then cmbNewValue.Items.Insert(0, V);
DBGType:=nil;
R:='';
if not DebugBoss.Evaluate(S, R, DBGType) then Exit;
FreeAndNil(DBGType);
if fHistDirection<>EHDNone then
begin
if txtResult.Lines.Text='' then
txtResult.Lines.Text := RESULTMOD+ S+':'+LineEnding+ R + LineEnding
else
if fHistDirection=EHDUp then
txtResult.Lines.Text := RESULTMOD+ S+':'+LineEnding+ R + LineEnding
+ RESULTSEPARATOR + LineEnding + txtResult.Lines.Text
else
begin
txtResult.Lines.Text := txtResult.Lines.Text + RESULTSEPARATOR + LineEnding
+ RESULTMOD+ S+':'+LineEnding+ R+LineEnding;
txtResult.SelStart:=length(txtResult.Lines.Text);
end;
end
else
txtResult.Lines.Text := R;
Evaluate;
end;
procedure TEvaluateDlg.FormClose(Sender: TObject; var CloseAction: TCloseAction);

123
debugger/inspectdlg.pas
View File

@ -83,8 +83,14 @@ type
FGridData: TStringGrid;
FGridMethods: TStringGrid;
FUpdateLock, FUpdateNeeded: Boolean;
FTestUpdateLock, FTestUpdateNeeded: Boolean;
FRowClicked: Integer;
FHistory: TStringList;
FHistoryIndex: Integer;
procedure EvaluateCallback(Sender: TObject; ASuccess: Boolean;
ResultText: String; ResultDBGType: TDBGType);
procedure EvaluateTestCallback(Sender: TObject; ASuccess: Boolean;
ResultText: String; ResultDBGType: TDBGType);
procedure Localize;
function ShortenedExpression: String;
procedure ContextChanged(Sender: TObject);
@ -188,14 +194,30 @@ begin
if Button = mbExtra2 then btnForwardClick(nil);
end;
procedure TIDEInspectDlg.EvaluateTestCallback(Sender: TObject;
ASuccess: Boolean; ResultText: String; ResultDBGType: TDBGType);
begin
FTestUpdateLock := False;
if ASuccess and (ResultDBGType <> nil) then begin
if pos('Cannot access memory at address', ResultDBGType.Value.AsString) = 1 then begin
FreeAndNil(ResultDBGType);
Execute(FGridData.Cells[2, FRowClicked] + '(' + FExpression + ')[0]');
exit;
end;
FreeAndNil(ResultDBGType);
end;
Execute('(' + FExpression + ')^');
end;
procedure TIDEInspectDlg.DataGridDoubleClick(Sender: TObject);
var
i: Integer;
s: String;
TestHumanReadable: String;
TestDBGInfo: TDBGType;
TestOpts: TDBGEvaluateFlags;
begin
if FTestUpdateLock then
exit;
if (FDBGInfo = nil) or (FExpression = '') then exit;
if (FDBGInfo.Kind in [skClass, skRecord]) then begin
@ -211,29 +233,23 @@ begin
end;
if (FDBGInfo.Kind in [skPointer]) then begin
i := FGridData.Row;
if (i < 1) or (i >= FGridData.RowCount) then exit;
s := FGridData.Cells[1, i];
FTestUpdateLock := true;
try
//TestOpts := [defFullTypeInfo];
TestOpts := [];
if btnUseInstance.Down then
include(TestOpts, defClassAutoCast);
TestDBGInfo := nil;
TestHumanReadable:='';
if DebugBoss.Evaluate('(' + FExpression + ')^', TestHumanReadable, TestDBGInfo, TestOpts) and
assigned(TestDBGInfo)
then
begin ///TODO: result needs an error flag
if pos('Cannot access memory at address', TestDBGInfo.Value.AsString) = 1 then begin
FreeAndNil(TestDBGInfo);
Execute(FGridData.Cells[2, i] + '(' + FExpression + ')[0]');
exit;
FRowClicked := FGridData.Row;
if (FRowClicked < 1) or (FRowClicked >= FGridData.RowCount) then exit;
s := FGridData.Cells[1, FRowClicked];
//TestOpts := [defFullTypeInfo];
TestOpts := [];
if btnUseInstance.Down then
include(TestOpts, defClassAutoCast);
if not DebugBoss.Evaluate('(' + FExpression + ')^', @EvaluateTestCallback, TestOpts) then
EvaluateTestCallback(nil, False, '', nil);
except
FTestUpdateLock := False;
end;
end;
FreeAndNil(TestDBGInfo);
Execute('(' + FExpression + ')^');
exit;
end;
@ -831,6 +847,38 @@ begin
UpdateData;
end;
procedure TIDEInspectDlg.EvaluateCallback(Sender: TObject; ASuccess: Boolean;
ResultText: String; ResultDBGType: TDBGType);
begin
FUpdateLock := False;
FHumanReadable := ResultText;
FDBGInfo := ResultDBGType;
if not ASuccess or not assigned(FDBGInfo) then
begin
FreeAndNil(FDBGInfo);
Clear;
StatusBar1.SimpleText:=Format(lisInspectUnavailableError, [ShortenedExpression, FHumanReadable]);
Exit;
end;
case FDBGInfo.Kind of
skClass: InspectClass();
skRecord: InspectRecord();
skVariant: InspectVariant();
skEnum: InspectEnum;
skSet: InspectSet;
skProcedure: InspectSimple;
skFunction: InspectSimple;
skSimple,
skInteger,
skCardinal, skBoolean, skChar, skFloat: InspectSimple();
skArray: InspectSimple();
skPointer: InspectPointer();
// skDecomposable: ;
end;
end;
procedure TIDEInspectDlg.UpdateData;
var
Opts: TDBGEvaluateFlags;
@ -858,30 +906,11 @@ begin
Opts := [defFullTypeInfo];
if btnUseInstance.Down then
include(Opts, defClassAutoCast);
if not DebugBoss.Evaluate(FExpression, FHumanReadable, FDBGInfo, Opts)
or not assigned(FDBGInfo) then
begin
FreeAndNil(FDBGInfo);
Clear;
StatusBar1.SimpleText:=Format(lisInspectUnavailableError, [ShortenedExpression, FHumanReadable]);
Exit;
end;
case FDBGInfo.Kind of
skClass: InspectClass();
skRecord: InspectRecord();
skVariant: InspectVariant();
skEnum: InspectEnum;
skSet: InspectSet;
skProcedure: InspectSimple;
skFunction: InspectSimple;
skSimple,
skInteger,
skCardinal, skBoolean, skChar, skFloat: InspectSimple();
skArray: InspectSimple();
skPointer: InspectPointer();
// skDecomposable: ;
end;
finally
if not DebugBoss.Evaluate(FExpression, @EvaluateCallback, Opts) then
EvaluateCallback(nil, False, '', nil);
except
FUpdateLock := False;
end;

5
debugger/processdebugger.pp
View File

@ -54,7 +54,7 @@ type
function ProcessStop: Boolean;
protected
function GetSupportedCommands: TDBGCommands; override;
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; override;
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const; const ACallback: TMethod): Boolean; override;
public
class function Caption: String; override;
class function NeedsExePath: boolean; override;
@ -155,7 +155,8 @@ begin
Result := [dcRun, dcStop, dcEnvironment]
end;
function TProcessDebugger.RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean;
function TProcessDebugger.RequestCommand(const ACommand: TDBGCommand;
const AParams: array of const; const ACallback: TMethod): Boolean;
begin
case ACommand of
dcRun: Result := ProcessRun;

3
ide/basedebugmanager.pas
View File

@ -179,8 +179,7 @@ type
procedure Detach; virtual; abstract;
function FillProcessList(AList: TRunningProcessInfoList): boolean; virtual; abstract;
function Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType;
function Evaluate(const AExpression: String; ACallback: TDBGEvaluateResultCallback;
EvalFlags: TDBGEvaluateFlags = []): Boolean; virtual; abstract; // Evaluates the given expression, returns true if valid
function Modify(const AExpression: String; const ANewValue: String): Boolean; virtual; abstract; // Modify the given expression, returns true if valid

7
ide/debugmanager.pas
View File

@ -211,8 +211,7 @@ type
function FillProcessList(AList: TRunningProcessInfoList): boolean; override;
procedure Detach; override;
function Evaluate(const AExpression: String; var AResult: String;
var ATypeInfo: TDBGType;
function Evaluate(const AExpression: String; ACallback: TDBGEvaluateResultCallback;
EvalFlags: TDBGEvaluateFlags = []): Boolean; override;
function Modify(const AExpression, ANewValue: String): Boolean; override;
@ -2732,13 +2731,13 @@ begin
end;
function TDebugManager.Evaluate(const AExpression: String;
var AResult: String; var ATypeInfo: TDBGType;EvalFlags: TDBGEvaluateFlags = []): Boolean;
ACallback: TDBGEvaluateResultCallback; EvalFlags: TDBGEvaluateFlags): Boolean;
begin
Result := (not Destroying)
and (MainIDE.ToolStatus = itDebugger)
and (FDebugger <> nil)
and (dcEvaluate in FDebugger.Commands)
and FDebugger.Evaluate(AExpression, AResult, ATypeInfo, EvalFlags);
and FDebugger.Evaluate(AExpression, ACallback, EvalFlags);
end;
function TDebugManager.Modify(const AExpression, ANewValue: String): Boolean;

165
ide/main.pp
View File

@ -10963,6 +10963,113 @@ begin
CodeExplorerView.CurrentCodeBufferChanged;
end;
type
{ TSrcNotebookHintCallback
ONLY used by SrcNotebookShowHintForSource
}
TSrcNotebookHintCallback = class
private
FExpression, FBaseURL, FSmartHintStr, FDebugResText: string;
FAutoShown: Boolean;
FSrcEdit: TSourceEditor;
FCaretPos: TPoint;
procedure ShowHint;
public
constructor Create(SrcEdit: TSourceEditor; CaretPos: TPoint; AnExpression, ABaseURL, ASmartHintStr: string; AAutoShown: Boolean);
procedure AddDebuggerResult(Sender: TObject; ASuccess: Boolean; ResultText: String; ResultDBGType: TDBGType);
procedure AddDebuggerResultDeref(Sender: TObject; ASuccess: Boolean; ResultText: String; ResultDBGType: TDBGType);
end;
{ TSrcNotebookHintCallback }
procedure TSrcNotebookHintCallback.ShowHint;
var
AtomStartPos, AtomEndPos: integer;
p: SizeInt;
AtomRect: TRect;
begin
FExpression := FExpression + ' = ' + FDebugResText;
if FSmartHintStr<>'' then
begin
p:=System.Pos('<body>',lowercase(FSmartHintStr));
if p>0 then
Insert('<div class="debuggerhint">'+CodeHelpBoss.TextToHTML(FExpression)+'</div><br>',
FSmartHintStr, p+length('<body>'))
else
FSmartHintStr:=FExpression+LineEnding+LineEnding+FSmartHintStr;
end else
FSmartHintStr:=FExpression;
AtomRect := Rect(-1,-1,-1,-1);
FSrcEdit.EditorComponent.GetWordBoundsAtRowCol(FCaretPos, AtomStartPos, AtomEndPos);
AtomRect.TopLeft := FSrcEdit.EditorComponent.RowColumnToPixels(Point(AtomStartPos, FCaretPos.y));
AtomRect.BottomRight := FSrcEdit.EditorComponent.RowColumnToPixels(Point(AtomEndPos, FCaretPos.y+1));
FSrcEdit.ActivateHint(AtomRect, FBaseURL, FSmartHintStr, FAutoShown, False);
Destroy;
end;
constructor TSrcNotebookHintCallback.Create(SrcEdit: TSourceEditor;
CaretPos: TPoint; AnExpression, ABaseURL, ASmartHintStr: string;
AAutoShown: Boolean);
begin
FExpression := AnExpression;
FSrcEdit := SrcEdit;
FCaretPos := CaretPos;
FBaseURL := ABaseURL;
FSmartHintStr := ASmartHintStr;
FAutoShown := AAutoShown;
end;
procedure TSrcNotebookHintCallback.AddDebuggerResult(Sender: TObject;
ASuccess: Boolean; ResultText: String; ResultDBGType: TDBGType);
var
Opts: TDBGEvaluateFlags;
begin
if not ASuccess then begin
FDebugResText := '???';
end
else begin
// deference a pointer - maybe it is a class
if ASuccess and Assigned(ResultDBGType) and (ResultDBGType.Kind in [skPointer]) and
not( StringCase(Lowercase(ResultDBGType.TypeName), ['char', 'character', 'ansistring']) in [0..2] )
then
begin
if ResultDBGType.Value.AsPointer <> nil then
begin
Opts := [];
if EditorOpts.DbgHintAutoTypeCastClass
then Opts := [defClassAutoCast];
FDebugResText := ResultText;
if DebugBoss.Evaluate('('+FExpression + ')^', @AddDebuggerResultDeref, Opts) then
exit;
end;
end else
FDebugResText := DebugBoss.FormatValue(ResultDBGType, ResultText);
FreeAndNil(ResultDBGType);
end;
ShowHint;
end;
procedure TSrcNotebookHintCallback.AddDebuggerResultDeref(Sender: TObject;
ASuccess: Boolean; ResultText: String; ResultDBGType: TDBGType);
begin
if ASuccess and Assigned(ResultDBGType) and
( (ResultDBGType.Kind <> skPointer) or
(StringCase(Lowercase(ResultDBGType.TypeName), ['char', 'character', 'ansistring']) in [0..2])
)
then
FDebugResText := FDebugResText + LineEnding + LineEnding + '(' + FExpression + ')^ = ' + DebugBoss.FormatValue(ResultDBGType, ResultText);
FreeAndNil(ResultDBGType);
ShowHint;
end;
procedure TMainIDE.SrcNotebookShowHintForSource(SrcEdit: TSourceEditor;
CaretPos: TPoint; AutoShown: Boolean);
@ -10998,6 +11105,7 @@ var
Opts: TDBGEvaluateFlags;
AtomStartPos, AtomEndPos: integer;
AtomRect: TRect;
DebugHint: TSrcNotebookHintCallback;
begin
//DebugLn(['TMainIDE.OnSrcNotebookShowHintForSource START']);
if (SrcEdit=nil) then exit;
@ -11032,53 +11140,20 @@ begin
end
else
Expression := SrcEdit.GetOperandFromCaret(CaretPos);
if Expression='' then exit;
//DebugLn(['TMainIDE.OnSrcNotebookShowHintForSource Expression="',Expression,'"']);
DBGType:=nil;
DBGTypeDerefer:=nil;
Opts := [];
if EditorOpts.DbgHintAutoTypeCastClass
then Opts := [defClassAutoCast];
DebugEval:='';
if DebugBoss.Evaluate(Expression, DebugEval, DBGType, Opts) and not (DebugEval = '') then
begin
// deference a pointer - maybe it is a class
if Assigned(DBGType) and (DBGType.Kind in [skPointer]) and
not( StringCase(Lowercase(DBGType.TypeName), ['char', 'character', 'ansistring']) in [0..2] )
then
begin
if DBGType.Value.AsPointer <> nil then
begin
DebugEvalDerefer:='';
if DebugBoss.Evaluate(Expression + '^', DebugEvalDerefer, DBGTypeDerefer, Opts) then
begin
if Assigned(DBGTypeDerefer) and
( (DBGTypeDerefer.Kind <> skPointer) or
(StringCase(Lowercase(DBGTypeDerefer.TypeName), ['char', 'character', 'ansistring']) in [0..2])
)
then
DebugEval := DebugEval + LineEnding + LineEnding + '(' + Expression + ')^ = ' + DebugEvalDerefer;
end;
end;
end else
DebugEval := DebugBoss.FormatValue(DBGType, DebugEval);
end else
DebugEval := '???';
FreeAndNil(DBGType);
FreeAndNil(DBGTypeDerefer);
HasHint:=true;
Expression := Expression + ' = ' + DebugEval;
if SmartHintStr<>'' then
begin
p:=System.Pos('<body>',lowercase(SmartHintStr));
if p>0 then
Insert('<div class="debuggerhint">'+CodeHelpBoss.TextToHTML(Expression)+'</div><br>',
SmartHintStr, p+length('<body>'))
else
SmartHintStr:=Expression+LineEnding+LineEnding+SmartHintStr;
end else
SmartHintStr:=Expression;
if Expression <> '' then begin
Opts := [];
if EditorOpts.DbgHintAutoTypeCastClass
then Opts := [defClassAutoCast];
DebugHint := TSrcNotebookHintCallback.Create(SrcEdit, CaretPos, Expression, BaseURL, SmartHintStr, AutoShown);
if DebugBoss.Evaluate(Expression, @DebugHint.AddDebuggerResult, Opts) then
exit;
DebugHint.Free; // eval not available
// Add note to SmartHintStr: no debug result for expression
end;
end;
if HasHint then