paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-04 20:58:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

DBG: Display more info for error-state

Browse Source 
git-svn-id: trunk@30806 -
This commit is contained in:
martin 2011-05-19 12:08:22 +00:00
parent cbb2956bdd
commit ccd2349b54
5 changed files with 124 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
debugger/cmdlinedebugger.pp
View File

@ -57,6 +57,8 @@ type
function WaitForHandles(const AHandles: array of Integer; var ATimeOut: Integer): Integer; overload;
function WaitForHandles(const AHandles: array of Integer): Integer; overload;
protected
procedure DoReadError; virtual;
procedure DoWriteError; virtual;
function GetDebugProcessRunning: Boolean; virtual;
procedure ProcessWhileWaitForHandles; virtual;
function CreateDebugProcess(const AOptions: String): Boolean; virtual;
@ -264,6 +266,16 @@ begin
Result := WaitForHandles(AHandles, t);
end;
procedure TCmdLineDebugger.DoReadError;
begin
SetState(dsError);
end;
procedure TCmdLineDebugger.DoWriteError;
begin
SetState(dsError);
end;
procedure TCmdLineDebugger.ProcessWhileWaitForHandles;
begin
// nothing
@ -417,7 +429,7 @@ begin
if (WaitSet = 0) and not FReadLineTimedOut
then begin
SmartWriteln('[TCmdLineDebugger.Getoutput] Error waiting ');
SetState(dsError);
DoReadError;
Break;
end;
@ -477,7 +489,7 @@ begin
end
else begin
DebugLn('[TCmdLineDebugger.SendCmdLn] Unable to send <', ACommand, '>. No process running.');
SetState(dsError);
DoWriteError;
end;
end;

16
debugger/debugger.pp
View File

@ -2310,6 +2310,8 @@ type
FCurEnvironment: TStrings;
FDisassembler: TDBGDisassembler;
FEnvironment: TStrings;
FErrorStateInfo: String;
FErrorStateMessage: String;
FExceptions: TDBGExceptions;
FExitCode: Integer;
FExternalDebugger: String;
@ -2374,6 +2376,7 @@ type
virtual; abstract; // True if succesful
procedure SetExitCode(const AValue: Integer);
procedure SetState(const AValue: TDBGState);
procedure SetErrorState(const AMsg: String; const AInfo: String = '');
procedure DoRelease; virtual;
public
class function Caption: String; virtual; // The name of the debugger as shown in the debuggeroptions
@ -2440,6 +2443,8 @@ type
property Threads: TThreadsSupplier read FThreads;
property WorkingDir: String read FWorkingDir write FWorkingDir; // The working dir of the exe being debugged
property IsIdle: Boolean read GetIsIdle; // Nothing queued
property ErrorStateMessage: String read FErrorStateMessage;
property ErrorStateInfo: String read FErrorStateInfo;
// Events
property OnCurrent: TDBGCurrentLineEvent read FOnCurrent write FOnCurrent; // Passes info about the current line being debugged
property OnDbgOutput: TDBGOutputEvent read FOnDbgOutput write FOnDbgOutput; // Passes all debuggeroutput
@ -4725,6 +4730,8 @@ end;
procedure TDebugger.Init;
begin
FExitCode := 0;
FErrorStateMessage := '';
FErrorStateInfo := '';
SetState(dsIdle);
end;
@ -4861,6 +4868,15 @@ begin
end;
end;
procedure TDebugger.SetErrorState(const AMsg: String; const AInfo: String = '');
begin
if FErrorStateMessage = ''
then FErrorStateMessage := AMsg;
if FErrorStateInfo = ''
then FErrorStateInfo := AInfo;
SetState(dsError);
end;
procedure TDebugger.DoRelease;
begin
Self.Free;

2
debugger/feedbackdlg.lfm
View File

@ -5,7 +5,7 @@ object DbgFeedbackDlg: TDbgFeedbackDlg
Width = 605
AutoSize = True
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
BorderStyle = bsSizeToolWin
Caption = 'DbgFeedbackDlg'
ClientHeight = 212
ClientWidth = 605

103
debugger/gdbmidebugger.pp
View File

@ -185,14 +185,22 @@ type
FState : TGDBMIDebuggerCommandState;
FSeenStates: TGDBMIDebuggerCommandStates;
FTheDebugger: TGDBMIDebugger; // Set during Execute
FLastExecCommand: String;
FLastExecResult: TGDBMIExecResult;
FLogWarnings: String;
function GetDebuggerProperties: TGDBMIDebuggerProperties;
function GetDebuggerProperties: TGDBMIDebuggerProperties;
function GetDebuggerState: TDBGState;
function GetTargetInfo: PGDBMITargetInfo;
procedure SetKeepFinished(const AValue: Boolean);
protected
procedure SetDebuggerState(const AValue: TDBGState);
procedure SetDebuggerErrorState(const AMsg: String; const AInfo: String = '');
function ErrorStateMessage: String; virtual;
function ErrorStateInfo: String; virtual;
property DebuggerState: TDBGState read GetDebuggerState;
property DebuggerProperties: TGDBMIDebuggerProperties read GetDebuggerProperties;
property TargetInfo: PGDBMITargetInfo read GetTargetInfo;
protected
procedure SetState(NewState: TGDBMIDebuggerCommandState);
procedure DoStateChanged(OldState: TGDBMIDebuggerCommandState); virtual;
procedure DoFree; virtual;
@ -204,9 +212,8 @@ type
procedure DoOnExecuted;
procedure DoCancel; virtual;
procedure DoOnCanceled;
property SeenStates: TGDBMIDebuggerCommandStates read FSeenStates;
property DebuggerState: TDBGState read GetDebuggerState;
property DebuggerProperties: TGDBMIDebuggerProperties read GetDebuggerProperties;
property SeenStates: TGDBMIDebuggerCommandStates read FSeenStates;
property QueueRunLevel: Integer read FQueueRunLevel write FQueueRunLevel; // if queue is nested
protected
// ExecuteCommand does execute direct. It does not use the queue
function ExecuteCommand(const ACommand: String;
@ -249,15 +256,13 @@ type
function GetPtrValue(const AExpression: String; const AValues: array of const; ConvertNegative: Boolean = False): TDbgPtr;
function CheckHasType(TypeName: String; TypeFlag: TGDBMITargetFlag): TGDBMIExecResult;
function PointerTypeCast: string;
function FrameToLocation(const AFrame: String = ''): TDBGLocationRec;
function FrameToLocation(const AFrame: String = ''): TDBGLocationRec;
procedure ProcessFrame(const ALocation: TDBGLocationRec); overload;
procedure ProcessFrame(const AFrame: String = ''); overload;
procedure DoDbgEvent(const ACategory: TDBGEventCategory; const AEventType: TDBGEventType; const AText: String);
property TargetInfo: PGDBMITargetInfo read GetTargetInfo;
property LastExecResult: TGDBMIExecResult read FLastExecResult;
property DefaultTimeOut: Integer read FDefaultTimeOut write FDefaultTimeOut;
property ProcessResultTimedOut: Boolean read FProcessResultTimedOut;
property QueueRunLevel: Integer read FQueueRunLevel write FQueueRunLevel; // if queue is nested
public
constructor Create(AOwner: TGDBMIDebugger);
destructor Destroy; override;
@ -362,6 +367,7 @@ type
function StartDebugging(AContinueCommand: TGDBMIDebuggerCommand = nil): Boolean;
protected
FErrorHandlingFlags: set of (ehfDeferReadWriteError, ehfGotReadError, ehfGotWriteError);
{$IFDEF MSWindows}
FPauseRequestInThreadID: Cardinal;
{$ENDIF}
@ -389,6 +395,8 @@ type
procedure ClearCommandQueue;
function GetIsIdle: Boolean; override;
procedure DoState(const OldState: TDBGState); override;
procedure DoReadError; override;
procedure DoWriteError; override;
procedure DoThreadChanged;
property TargetPID: Integer read FTargetInfo.TargetPID;
property TargetPtrSize: Byte read FTargetInfo.TargetPtrSize;
@ -440,6 +448,15 @@ resourcestring
+ 'Press "Stop" to end the debug session';
gdbmiTimeOutForCmd = 'Time-out for command: "%s"';
gdbmiFatalErrorOccured = 'Unrecoverable Error: "%s"';
gdbmiErrorStateGenericInfo = 'Error in: %1:s %0:s';
gdbmiErrorStateInfoCommandError =
'%0:sThe GDB command:%0:s"%1:s"%0:sreturned the error:%0:s"%2:s"%0:s';
gdbmiErrorStateInfoCommandNoResult =
'%0:sThe GDB command:%0:s"%1:s"%0:sdid not return any result%0:s';
gdbmiErrorStateInfoFailedWrite = '%0:sCould not send a command to GDB%0:s';
gdbmiErrorStateInfoFailedRead = '%0:sCould not read output from GDB.%0:s';
gdbmiErrorStateInfoGDBGone = '%0:sThe GDB process is no longer running.%0:s';
implementation
@ -1351,7 +1368,6 @@ type
{ TGDBStringIterator }
TGDBStringIterator=class
private
protected
FDataSize: Integer;
FReadPointer: Integer;
@ -5442,6 +5458,20 @@ begin
inherited DoState(OldState);
end;
procedure TGDBMIDebugger.DoReadError;
begin
include(FErrorHandlingFlags, ehfGotReadError);
if not(ehfDeferReadWriteError in FErrorHandlingFlags)
then inherited DoReadError;
end;
procedure TGDBMIDebugger.DoWriteError;
begin
include(FErrorHandlingFlags, ehfGotWriteError);
if not(ehfDeferReadWriteError in FErrorHandlingFlags)
then inherited DoWriteError;
end;
procedure TGDBMIDebugger.DoThreadChanged;
begin
TGDBMICallstack(CallStack).DoThreadChanged;
@ -6252,6 +6282,7 @@ begin
LockRelease;
try
FPauseWaitState := pwsNone;
FErrorHandlingFlags := [];
FInExecuteCount := 0;
Options := '-silent -i mi -nx';
@ -8704,6 +8735,35 @@ begin
FTheDebugger.SetState(AValue);
end;
procedure TGDBMIDebuggerCommand.SetDebuggerErrorState(const AMsg: String;
const AInfo: String);
begin
FTheDebugger.SetErrorState(AMsg, AInfo);
end;
function TGDBMIDebuggerCommand.ErrorStateMessage: String;
begin
Result := '';
if ehfGotWriteError in FTheDebugger.FErrorHandlingFlags
then Result := Result + Format(gdbmiErrorStateInfoFailedWrite, [LineEnding])
else
if ehfGotReadError in FTheDebugger.FErrorHandlingFlags
then Result := Result + Format(gdbmiErrorStateInfoFailedRead, [LineEnding]);
if not FTheDebugger.DebugProcessRunning
then Result := Result + Format(gdbmiErrorStateInfoGDBGone, [LineEnding]);
end;
function TGDBMIDebuggerCommand.ErrorStateInfo: String;
begin
Result := Format(gdbmiErrorStateGenericInfo, [LineEnding, DebugText]);
if FLastExecResult.Values = ''
then Result := Format(gdbmiErrorStateInfoCommandNoResult, [LineEnding, FLastExecCommand])
else Result := Format(gdbmiErrorStateInfoCommandError, [LineEnding, FLastExecCommand, FLastExecResult.Values]);
if not FTheDebugger.DebugProcessRunning
then Result := Result + Format(gdbmiErrorStateInfoGDBGone, [LineEnding]);
end;
procedure TGDBMIDebuggerCommand.SetState(NewState: TGDBMIDebuggerCommandState);
var
OldState: TGDBMIDebuggerCommandState;
@ -8846,29 +8906,42 @@ begin
AResult.Values := '';
AResult.State := dsNone;
AResult.Flags := [];
FLastExecCommand := ACommand;
if (ATimeOut = -1) and (DefaultTimeOut > 0)
then ATimeOut := DefaultTimeOut;
FTheDebugger.SendCmdLn(ACommand);
try
FTheDebugger.FErrorHandlingFlags := FTheDebugger.FErrorHandlingFlags
+ [ehfDeferReadWriteError] - [ehfGotReadError, ehfGotWriteError];
Result := ProcessResult(AResult, ATimeOut);
FLastExecResult := AResult;
FTheDebugger.SendCmdLn(ACommand);
if ehfGotWriteError in FTheDebugger.FErrorHandlingFlags then begin
ProcessResult(AResult, 50); // not expecting anything
Result := False;
end
else begin
Result := ProcessResult(AResult, ATimeOut);
FLastExecResult := AResult;
if ProcessResultTimedOut then
Result := RevorerTimeOut;
if ProcessResultTimedOut then
Result := RevorerTimeOut;
end;
finally
Exclude(FTheDebugger.FErrorHandlingFlags, ehfDeferReadWriteError);
end;
if not Result
then begin
// either gdb did not return a Result Record: "^xxxx,"
// or the Result Record was not a known one: 'done', 'running', 'exit', 'error'
DebugLn('[WARNING] TGDBMIDebugger: ExecuteCommand "',ACommand,'" failed.');
SetDebuggerState(dsError);
SetDebuggerErrorState(ErrorStateMessage, ErrorStateInfo);
AResult.State := dsError;
end;
if (cfCheckError in AFlags) and (AResult.State = dsError)
then SetDebuggerState(AResult.State);
then SetDebuggerErrorState(ErrorStateMessage, ErrorStateInfo);
if (cfCheckState in AFlags) and not (AResult.State in [dsError, dsNone])
then SetDebuggerState(AResult.State);

9
ide/debugmanager.pas
View File

@ -925,10 +925,11 @@ begin
{$endif}
// shutting down lazarus may kill gdb, so we get an error
if not Application.Terminated
then MessageDlg(lisDebuggerError,
Format(lisDebuggerErrorOoopsTheDebuggerEnteredTheErrorState, [#13#13,
#13, #13#13]),
mtError, [mbOK],0);
then FeedbackDlg.ExecuteFeedbackDialog
(Format(lisDebuggerErrorOoopsTheDebuggerEnteredTheErrorState,
[LineEnding+LineEnding, LineEnding, LineEnding+LineEnding])
+ LineEnding + LineEnding + FDebugger.ErrorStateMessage,
FDebugger.ErrorStateInfo, ftError, [frStop]);
end;
dsStop: begin
if (OldState<>dsIdle)