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

Debugger: Started TGDBInstructionQueue

Browse Source 
git-svn-id: trunk@42430 -
This commit is contained in:
martin 2013-08-20 09:23:28 +00:00
parent ef6c0db331
commit 9f79ea9d97
8 changed files with 1233 additions and 368 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -3699,6 +3699,7 @@ debugger/frames/debugger_language_exceptions_options.pas svneol=native#text/pasc
debugger/frames/debugger_signals_options.lfm svneol=native#text/plain
debugger/frames/debugger_signals_options.pas svneol=native#text/pascal
debugger/gdbmidebugger.pp svneol=native#text/pascal
debugger/gdbmidebuginstructions.pp svneol=native#text/pascal
debugger/gdbmimiscclasses.pp svneol=native#text/pascal
debugger/gdbmiserverdebugger.pas svneol=native#text/pascal
debugger/gdbtypeinfo.pp svneol=native#text/pascal
@ -3745,6 +3746,7 @@ debugger/test/Gdbmi/testexception.pas svneol=native#text/pascal
debugger/test/Gdbmi/testgdbmicontrol.lfm svneol=native#text/plain
debugger/test/Gdbmi/testgdbmicontrol.pas svneol=native#text/pascal
debugger/test/Gdbmi/testgdbtype.pas svneol=native#text/pascal
debugger/test/Gdbmi/testinstructionqueue.pas svneol=native#text/pascal
debugger/test/Gdbmi/testwatches.pas svneol=native#text/pascal
debugger/test/examples/testcntr.pp svneol=native#text/pascal
debugger/test/examples/testwait.pp svneol=native#text/pascal

7
debugger/cmdlinedebugger.pp
View File

@ -70,7 +70,7 @@ type
procedure SendCmdLn(const ACommand: String); virtual; overload;
procedure SendCmdLn(const ACommand: String; Values: array of const); overload;
procedure SetLineEnds(ALineEnds: TStringDynArray);
property ReadLineTimedOut: Boolean read FReadLineTimedOut;
function ReadLineTimedOut: Boolean; virtual;
public
constructor Create(const AExternalDebugger: String); override;
destructor Destroy; override;
@ -527,6 +527,11 @@ begin
else FLineEnds := ALineEnds;
end;
function TCmdLineDebugger.ReadLineTimedOut: Boolean;
begin
Result := FReadLineTimedOut;
end;
procedure TCmdLineDebugger.TestCmd(const ACommand: String);
begin
SendCmdLn(ACommand);

726
debugger/gdbmidebugger.pp
View File

@ -41,7 +41,7 @@ interface
uses
Classes, SysUtils, strutils, Controls, Math, Variants, LCLProc, LazClasses, LazLoggerBase,
Dialogs, DebugUtils, Debugger, FileUtil, BaseIDEIntf, CmdLineDebugger, GDBTypeInfo, Maps,
LCLIntf, Forms,
GDBMIDebugInstructions, LCLIntf, Forms,
{$IFdef MSWindows}
Windows,
{$ENDIF}
@ -179,6 +179,32 @@ type
end;
TGDBMIDebugger = class;
TGDBMIDebuggerCommand = class;
{ TGDBMIDebuggerInstruction }
TGDBMIDebuggerInstruction = class(TGDBInstruction)
private
FCmd: TGDBMIDebuggerCommand;
FFullCmdReply: String;
FHasResult: Boolean;
FInLogWarning: Boolean;
FLogWarnings: String;
FResultData: TGDBMIExecResult;
protected
function ProcessInputFromGdb(const AData: String): Boolean; override;
procedure HandleNoGdbRunning; override;
procedure HandleReadError; override;
procedure HandleTimeOut; override;
function GetTimeOutVerifier: TGDBInstruction; override;
procedure Init; override;
public
property ResultData: TGDBMIExecResult read FResultData;
property HasResult: Boolean read FHasResult; // seen a "^foo" msg from gdb
property FullCmdReply: String read FFullCmdReply;
property LogWarnings: String read FLogWarnings;
property Cmd: TGDBMIDebuggerCommand read FCmd write FCmd;
end;
{ TGDBMIDebuggerCommand }
@ -284,7 +310,6 @@ type
ATimeOut: Integer = -1
): Boolean; overload;
procedure DoTimeoutFeedback;
function ProcessResult(var AResult: TGDBMIExecResult; ATimeOut: Integer = -1): Boolean;
function ProcessGDBResultStruct(S: String; Opts: TGDBMIProcessResultOpts = []): String; // Must have at least one flag for structs
function ProcessGDBResultText(S: String; Opts: TGDBMIProcessResultOpts = []): String;
function GetStackDepth(MaxDepth: integer): Integer;
@ -548,8 +573,9 @@ type
{ TGDBMIDebugger }
TGDBMIDebugger = class(TCmdLineDebugger)
TGDBMIDebugger = class(TGDBMICmdLineDebugger) // TODO: inherit from TDebugger direct
private
FInstructionQueue: TGDBInstructionQueue;
FCommandQueue: TGDBMIDebuggerCommandList;
FCurrentCommand: TGDBMIDebuggerCommand;
FCommandQueueExecLock: Integer;
@ -641,7 +667,6 @@ type
function StartDebugging(AContinueCommand: TGDBMIDebuggerCommand = nil): Boolean;
protected
FErrorHandlingFlags: set of (ehfDeferReadWriteError, ehfGotReadError, ehfGotWriteError);
FNeedStateToIdle: Boolean;
{$IFDEF MSWindows}
FPauseRequestInThreadID: Cardinal;
@ -679,8 +704,6 @@ type
procedure ResetStateToIdle; override;
procedure DoState(const OldState: TDBGState); override;
procedure DoBeforeState(const OldState: TDBGState); override;
procedure DoReadError; override;
procedure DoWriteError; override;
function LineEndPos(const s: string; out LineEndLen: integer): integer; override;
procedure DoThreadChanged;
property TargetPID: Integer read FTargetInfo.TargetPID;
@ -1566,6 +1589,311 @@ begin
then Result := 8;
end;
{ TGDBMIDebuggerInstruction }
function TGDBMIDebuggerInstruction.ProcessInputFromGdb(const AData: String): Boolean;
function DoResultRecord(Line: String; CurRes: Boolean): Boolean;
var
ResultClass: String;
OldResult: Boolean;
begin
ResultClass := GetPart('^', ',', Line);
if Line = ''
then begin
if FResultData.Values <> ''
then Include(FResultData.Flags, rfNoMI);
end
else begin
FResultData.Values := Line;
end;
OldResult := CurRes;
Result := True;
case StringCase(ResultClass, ['done', 'running', 'exit', 'error', 'stopped']) of
0: begin // done
end;
1: begin // running
FResultData.State := dsRun;
end;
2: begin // exit
FResultData.State := dsIdle;
end;
3: begin // error
DebugLn(DBG_WARNINGS, 'TGDBMIDebugger.ProcessResult Error: ', Line);
// todo: implement with values
if (pos('msg=', Line) > 0)
and (pos('not being run', Line) > 0)
then FResultData.State := dsStop
else FResultData.State := dsError;
end;
4: begin
FCmd.FGotStopped := True;
//AStoppedParams := Line;
end;
else
//TODO: should that better be dsError ?
if OldResult and (FResultData.State in [dsError, dsStop]) and
(copy(ResultClass,1,6) = 'error"')
then begin
// Gdb 6.3.5 on Mac, does sometime return a 2nd mis-formatted error line
// The line seems truncated, it simply is (note the misplaced quote): ^error"
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown result class (IGNORING): ', ResultClass);
end
else begin
Result := False;
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown result class: ', ResultClass);
end;
end;
end;
procedure DoConsoleStream(Line: String);
var
len: Integer;
begin
// check for symbol info
if Pos('no debugging symbols', Line) > 0
then begin
FCmd.TargetInfo^.TargetFlags := FCmd.TargetInfo^.TargetFlags - [tfHasSymbols];
FCmd.DoDbgEvent(ecDebugger, etDefault, Format('File ''%s'' has no debug symbols', [FCmd.FTheDebugger.FileName]));
end
else begin
// Strip surrounding ~" "
len := Length(Line) - 3;
if len < 0 then Exit;
Line := Copy(Line, 3, len);
// strip trailing \n (unless it is escaped \\n)
if (len >= 2) and (Line[len - 1] = '\') and (Line[len] = 'n')
then begin
if len = 2
then Line := LineEnding
else if Line[len - 2] <> '\'
then begin
SetLength(Line, len - 2);
Line := Line + LineEnding;
end;
end;
FResultData.Values := FResultData.Values + Line;
end;
end;
procedure DoTargetStream(const Line: String);
begin
DebugLn(DBG_VERBOSE, '[Debugger] Target output: ', Line);
end;
procedure DoLogStream(const Line: String);
const
LogWarning = '&"Warning:\n"';
begin
// check for symbol info
if Pos('No symbol table is loaded. Use the \"file\" command.', Line) > 0
then begin
FCmd.TargetInfo^.TargetFlags := FCmd.TargetInfo^.TargetFlags - [tfHasSymbols];
FCmd.DoDbgEvent(ecDebugger, etDefault, Format('File ''%s'' has no debug symbols', [FCmd.FTheDebugger.FileName]));
end;
if (Pos('internal-error:', LowerCase(Line)) > 0) or
(Pos('internal to gdb has been detected', LowerCase(Line)) > 0) or
(Pos('further debugging may prove unreliable', LowerCase(Line)) > 0)
then begin
FCmd.DoDbgEvent(ecDebugger, etDefault, Format('GDB has encountered an internal error: %s', [Line]));
if FCmd.DebuggerProperties.WarnOnInternalError
then MessageDlg('Warning', 'GDB has encountered an internal error: ' + Line,
mtWarning, [mbOK], 0);
end;
DebugLn(DBG_VERBOSE, '[Debugger] Log output: ', Line);
if Line = '&"kill\n"'
then FResultData.State := dsStop
else if LeftStr(Line, 8) = '&"Error '
then FResultData.State := dsError;
if copy(Line, 1, length(FLogWarnings)) = FLogWarnings
then FInLogWarning := True;
if FInLogWarning
then FLogWarnings := FLogWarnings + copy(Line, 3, length(Line)-5) + LineEnding;
if copy(Line, 1, length(FLogWarnings)) = '&"\n"'
then FInLogWarning := False;
end;
procedure DoExecAsync(Line: String);
var
S: String;
ct: TCurrentThreads;
i: Integer;
t: TThreadEntry;
begin
S := GetPart(['*'], [','], Line);
if S = 'running'
then begin
if (FCmd.FTheDebugger.Threads.Monitor <> nil) and
(FCmd.FTheDebugger.Threads.Monitor.CurrentThreads <> nil)
then begin
ct := FCmd.FTheDebugger.Threads.Monitor.CurrentThreads;
S := GetPart('thread-id="', '"', Line);
if s = 'all' then begin
for i := 0 to ct.Count - 1 do
ct[i].ThreadState := 'running'; // TODO enum?
end
else begin
S := S + ',';
while s <> '' do begin
i := StrToIntDef(GetPart('', ',', s), -1);
if (s <> '') and (s[1] = ',') then delete(s, 1, 1)
else begin
debugln(DBG_WARNINGS, 'GDBMI: Error parsing threads');
break
end;
if i < 0 then Continue;
t := ct.EntryById[i];
if t <> nil then
t.ThreadState := 'running'; // TODO enum?
end;
end;
FCmd.FTheDebugger.Threads.Changed;
end;
FCmd.DoDbgEvent(ecProcess, etProcessStart, 'Process Start: ' + FCmd.FTheDebugger.FileName);
end
else
if S = 'stopped' then begin
FCmd.FGotStopped := True;
// StoppedParam ??
end
else
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unexpected async-record: ', Line);
end;
procedure DoMsgAsync(Line: String);
var
S: String;
i, x: Integer;
ct: TCurrentThreads;
t: TThreadEntry;
begin
S := GetPart('=', ',', Line, False, False);
x := StringCase(S, ['thread-created', 'thread-exited', 'thread-group-started']);
case x of // thread-group-exited // thread-group-added,id="i1"
0,1: begin
i := StrToIntDef(GetPart(',id="', '"', Line, False, False), -1);
if (i > 0) and (FCmd.FTheDebugger.Threads.Monitor <> nil) and
(FCmd.FTheDebugger.Threads.Monitor.CurrentThreads <> nil)
then begin
ct := FCmd.FTheDebugger.Threads.Monitor.CurrentThreads;
t := ct.EntryById[i];
case x of
0: begin
if t = nil then begin
t := TThreadEntry.Create(0, 0, nil, '', nil, 0, i, '', 'unknown');
ct.Add(t);
t.Free;
end
else
debugln(DBG_WARNINGS, 'GDBMI: Duplicate thread');
end;
1: begin
if t <> nil then begin
ct.Remove(t);
end
else
debugln(DBG_WARNINGS, 'GDBMI: Missing thread');
end;
end;
FCmd.FTheDebugger.Threads.Changed;
end;
end;
2: begin // thread-group-started // needed in RunToMain
// Todo, store in seperate field
if FCmd is TGDBMIDebuggerCommandStartDebugging then
FLogWarnings := FLogWarnings + Line + LineEnding;
end;
end;
FCmd.FTheDebugger.DoNotifyAsync(Line);
end;
procedure DoStatusAsync(const Line: String);
begin
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unexpected async-record: ', Line);
end;
begin
Result := True;
FFullCmdReply := FFullCmdReply + AData + LineEnding;
if AData = '(gdb) ' then begin
MarkAsSuccess;
exit;
end;
//if (AData = '^exit') and (FCmd = '-gdb-exit') then begin
// // no (gdb) expected
// MarkAsSuccess;
//end;
if AData <> ''
then case AData[1] of
'^': FHasResult := DoResultRecord(AData, Result);
'~': DoConsoleStream(AData);
'@': DoTargetStream(AData);
'&': DoLogStream(AData);
'*': DoExecAsync(AData);
'+': DoStatusAsync(AData);
'=': DoMsgAsync(AData);
else
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown record: ', AData);
end;
{$IFDEF VerboseIDEToDo}{$message warning condition should also check end-of-file reached for process output stream}{$ENDIF}
end;
procedure TGDBMIDebuggerInstruction.HandleNoGdbRunning;
begin
if FHasResult and (Command = '-gdb-exit') then begin
// no (gdb) expected
MarkAsSuccess;
end
else
inherited HandleNoGdbRunning;
end;
procedure TGDBMIDebuggerInstruction.HandleReadError;
begin
if FHasResult and (Command = '-gdb-exit') then begin
// no (gdb) expected
MarkAsSuccess;
end
else
inherited HandleReadError;
end;
procedure TGDBMIDebuggerInstruction.HandleTimeOut;
begin
if FHasResult and (Command = '-gdb-exit') then begin
// no (gdb) expected
MarkAsSuccess;
end
else
inherited HandleTimeOut;
end;
function TGDBMIDebuggerInstruction.GetTimeOutVerifier: TGDBInstruction;
begin
if FHasResult and (Command = '-gdb-exit') then
Result := nil
else
Result := inherited GetTimeOutVerifier;
end;
procedure TGDBMIDebuggerInstruction.Init;
begin
inherited Init;
FHasResult := False;
FResultData.Values := '';
FResultData.Flags := [];
FResultData.State := dsNone;
FFullCmdReply := '';
FLogWarnings := '';
FInLogWarning := False;
end;
{ TGDBMIDebuggerCommandStartBase }
procedure TGDBMIDebuggerCommandStartBase.SetTargetInfo(const AFileType: String);
@ -1944,7 +2272,7 @@ var
AResult.State := dsIdle;
end;
3: begin // error
DebugLn(DBG_WARNINGS, 'TGDBMIDebugger.ProcessResult Error: ', Line);
DebugLn(DBG_WARNINGS, 'TGDBMIDebugger.ProcessRunning Error: ', Line);
// todo: implement with values
if (pos('msg=', Line) > 0)
and (pos('not being run', Line) > 0)
@ -6608,6 +6936,7 @@ begin
FRunErrorBreak := TGDBMIInternalBreakPoint.Create('FPC_RUNERROR');
FExceptionBreak := TGDBMIInternalBreakPoint.Create('FPC_RAISEEXCEPTION');
FInstructionQueue := TGDBInstructionQueue.Create(Self);
FCommandQueue := TGDBMIDebuggerCommandList.Create;
FTargetInfo.TargetPID := 0;
FTargetInfo.TargetFlags := [];
@ -6699,6 +7028,7 @@ begin
ClearCommandQueue;
//RemoveRunQueueASync;
FreeAndNil(FCommandQueue);
FreeAndNil(FInstructionQueue);
ClearSourceInfo;
FreeAndNil(FSourceNames);
FreeAndNil(FThreadGroups);
@ -6804,20 +7134,6 @@ begin
Threads.CurrentThreads.CurrentThreadId := FCurrentThreadId; // TODO: Works only because CurrentThreadId is always valid
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;
function TGDBMIDebugger.LineEndPos(const s: string; out LineEndLen: integer): integer;
var
l: Integer;
@ -9739,68 +10055,11 @@ end;
function TGDBMIDebuggerCommand.ExecuteCommand(const ACommand: String;
out AResult: TGDBMIExecResult; AFlags: TGDBMICommandFlags = [];
ATimeOut: Integer = -1): Boolean;
function RevorerTimeOut: Boolean;
var
R, R2: TGDBMIExecResult;
List: TGDBMINameValueList;
Got7: Boolean;
begin
Result := False;
List := nil;
try
AResult.State := dsError;
// send 2 commands: - if the "7" is received, it could be the original command
// - but if the "1" is received, after the "7" we know we are in sync
FTheDebugger.SendCmdLn('-data-evaluate-expression 7');
FTheDebugger.SendCmdLn('-data-evaluate-expression 1');
// Not expected to reach it's timeout, so we can use a high value.
if not ProcessResult(R, Max(2*ATimeOut, 2500))
then exit;
// Got either: Result for origonal "ACommand" (could be "7" too) OR got "7"
List := TGDBMINameValueList.Create(R);
Got7 := List.Values['value'] = '7';
// Check next result,
if not ProcessResult(R2, 500)
then exit;
// Got either: "7" OR "1"
// "1" => never got original result, but recovery was ok
// "7" again => maybe recovery, must be followed by a "1" then
List.Init(R2.Values);
if Got7 and (List.Values['value'] = '1')
then begin
// timeout, without value, but recovery
Result := True;
DoDbgEvent(ecDebugger, etDefault, Format(gdbmiTimeOutForCmd, [ACommand]));
// TODO: use feedback dialog
FLastExecwasTimeOut := True;
DoTimeoutFeedback;
end
else
if List.Values['value'] = '7'
then begin
// Got a 2nd "7", check for a "1"
if not ProcessResult(R2, 500)
then exit;
List.Init(R2.Values);
if not(List.Values['value'] = '1')
then exit;
// full recovery, even got orig result
Result := True;
AResult := R;
end;
finally
FreeAndNil(List);
end;
end;
var
Instr: TGDBMIDebuggerInstruction;
ASyncFailed: Boolean;
begin
AResult.Flags := [];
ASyncFailed := False;
if cfTryAsync in AFlags then begin
if FTheDebugger.FAsyncModeEnabled then begin
@ -9809,11 +10068,9 @@ begin
exit;
end;
AResult.Flags := [rfAsyncFailed];
ASyncFailed := True;
end;
AResult.Values := '';
AResult.State := dsNone;
FLastExecCommand := ACommand;
FLastExecwasTimeOut := False;
@ -9821,22 +10078,29 @@ begin
then ATimeOut := DefaultTimeOut;
try
FTheDebugger.FErrorHandlingFlags := FTheDebugger.FErrorHandlingFlags
+ [ehfDeferReadWriteError] - [ehfGotReadError, ehfGotWriteError];
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;
Instr := TGDBMIDebuggerInstruction.Create(ACommand, [], ATimeOut);
Instr.Cmd := Self;
FTheDebugger.FInstructionQueue.RunInstruction(Instr);
if ProcessResultTimedOut then
Result := RevorerTimeOut;
Result := Instr.IsSuccess and Instr.FHasResult;
AResult := Instr.ResultData;
if ASyncFailed then
AResult.Flags := [rfAsyncFailed];
FLastExecResult := AResult;
FLogWarnings := Instr.LogWarnings; // TODO: Do not clear in time-out handling
FFullCmdReply := Instr.FullCmdReply; // TODO: Do not clear in time-out handling
if (ifeTimedOut in Instr.ErrorFlags) then begin
AResult.State := dsError;
FLastExecwasTimeOut := True;
end;
if (ifeRecoveredTimedOut in Instr.ErrorFlags) then begin
// TODO: use feedback dialog
DoDbgEvent(ecDebugger, etDefault, Format(gdbmiTimeOutForCmd, [ACommand]));
DoTimeoutFeedback;
end;
finally
Exclude(FTheDebugger.FErrorHandlingFlags, ehfDeferReadWriteError);
Instr.Free;
end;
if not Result
@ -9878,272 +10142,6 @@ begin
mtWarning, [mbOK], 0);
end;
function TGDBMIDebuggerCommand.ProcessResult(var AResult: TGDBMIExecResult;ATimeOut: Integer = -1): Boolean;
var
InLogWarning: Boolean;
function DoResultRecord(Line: String; CurRes: Boolean): Boolean;
var
ResultClass: String;
OldResult: Boolean;
begin
ResultClass := GetPart('^', ',', Line);
if Line = ''
then begin
if AResult.Values <> ''
then Include(AResult.Flags, rfNoMI);
end
else begin
AResult.Values := Line;
end;
OldResult := CurRes;
Result := True;
case StringCase(ResultClass, ['done', 'running', 'exit', 'error', 'stopped']) of
0: begin // done
end;
1: begin // running
AResult.State := dsRun;
end;
2: begin // exit
AResult.State := dsIdle;
end;
3: begin // error
DebugLn(DBG_WARNINGS, 'TGDBMIDebugger.ProcessResult Error: ', Line);
// todo: implement with values
if (pos('msg=', Line) > 0)
and (pos('not being run', Line) > 0)
then AResult.State := dsStop
else AResult.State := dsError;
end;
4: begin
FGotStopped := True;
//AStoppedParams := Line;
end;
else
//TODO: should that better be dsError ?
if OldResult and (AResult.State in [dsError, dsStop]) and
(copy(ResultClass,1,6) = 'error"')
then begin
// Gdb 6.3.5 on Mac, does sometime return a 2nd mis-formatted error line
// The line seems truncated, it simply is (note the misplaced quote): ^error"
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown result class (IGNORING): ', ResultClass);
end
else begin
Result := False;
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown result class: ', ResultClass);
end;
end;
end;
procedure DoConsoleStream(Line: String);
var
len: Integer;
begin
// check for symbol info
if Pos('no debugging symbols', Line) > 0
then begin
TargetInfo^.TargetFlags := TargetInfo^.TargetFlags - [tfHasSymbols];
DoDbgEvent(ecDebugger, etDefault, Format('File ''%s'' has no debug symbols', [FTheDebugger.FileName]));
end
else begin
// Strip surrounding ~" "
len := Length(Line) - 3;
if len < 0 then Exit;
Line := Copy(Line, 3, len);
// strip trailing \n (unless it is escaped \\n)
if (len >= 2) and (Line[len - 1] = '\') and (Line[len] = 'n')
then begin
if len = 2
then Line := LineEnding
else if Line[len - 2] <> '\'
then begin
SetLength(Line, len - 2);
Line := Line + LineEnding;
end;
end;
AResult.Values := AResult.Values + Line;
end;
end;
procedure DoTargetStream(const Line: String);
begin
DebugLn(DBG_VERBOSE, '[Debugger] Target output: ', Line);
end;
procedure DoLogStream(const Line: String);
const
LogWarning = '&"Warning:\n"';
begin
// check for symbol info
if Pos('No symbol table is loaded. Use the \"file\" command.', Line) > 0
then begin
TargetInfo^.TargetFlags := TargetInfo^.TargetFlags - [tfHasSymbols];
DoDbgEvent(ecDebugger, etDefault, Format('File ''%s'' has no debug symbols', [FTheDebugger.FileName]));
end;
if (Pos('internal-error:', LowerCase(Line)) > 0) or
(Pos('internal to gdb has been detected', LowerCase(Line)) > 0) or
(Pos('further debugging may prove unreliable', LowerCase(Line)) > 0)
then begin
DoDbgEvent(ecDebugger, etDefault, Format('GDB has encountered an internal error: %s', [Line]));
if DebuggerProperties.WarnOnInternalError
then MessageDlg('Warning', 'GDB has encountered an internal error: ' + Line,
mtWarning, [mbOK], 0);
end;
DebugLn(DBG_VERBOSE, '[Debugger] Log output: ', Line);
if Line = '&"kill\n"'
then AResult.State := dsStop
else if LeftStr(Line, 8) = '&"Error '
then AResult.State := dsError;
if copy(Line, 1, length(LogWarning)) = LogWarning
then InLogWarning := True;
if InLogWarning
then FLogWarnings := FLogWarnings + copy(Line, 3, length(Line)-5) + LineEnding;
if copy(Line, 1, length(LogWarning)) = '&"\n"'
then InLogWarning := False;
end;
procedure DoExecAsync(Line: String);
var
S: String;
ct: TCurrentThreads;
i: Integer;
t: TThreadEntry;
begin
S := GetPart(['*'], [','], Line);
if S = 'running'
then begin
if (FTheDebugger.Threads.Monitor <> nil) and
(FTheDebugger.Threads.Monitor.CurrentThreads <> nil)
then begin
ct := FTheDebugger.Threads.Monitor.CurrentThreads;
S := GetPart('thread-id="', '"', Line);
if s = 'all' then begin
for i := 0 to ct.Count - 1 do
ct[i].ThreadState := 'running'; // TODO enum?
end
else begin
S := S + ',';
while s <> '' do begin
i := StrToIntDef(GetPart('', ',', s), -1);
if (s <> '') and (s[1] = ',') then delete(s, 1, 1)
else begin
debugln(DBG_WARNINGS, 'GDBMI: Error parsing threads');
break
end;
if i < 0 then Continue;
t := ct.EntryById[i];
if t <> nil then
t.ThreadState := 'running'; // TODO enum?
end;
end;
FTheDebugger.Threads.Changed;
end;
DoDbgEvent(ecProcess, etProcessStart, 'Process Start: ' + FTheDebugger.FileName);
end
else
if S = 'stopped' then begin
FGotStopped := True;
// StoppedParam ??
end
else
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unexpected async-record: ', Line);
end;
procedure DoMsgAsync(var Line: String);
var
S: String;
i, x: Integer;
ct: TCurrentThreads;
t: TThreadEntry;
begin
S := GetPart('=', ',', Line, False, False);
x := StringCase(S, ['thread-created', 'thread-exited', 'thread-group-started']);
case x of // thread-group-exited // thread-group-added,id="i1"
0,1: begin
i := StrToIntDef(GetPart(',id="', '"', Line, False, False), -1);
if (i > 0) and (FTheDebugger.Threads.Monitor <> nil) and
(FTheDebugger.Threads.Monitor.CurrentThreads <> nil)
then begin
ct := FTheDebugger.Threads.Monitor.CurrentThreads;
t := ct.EntryById[i];
case x of
0: begin
if t = nil then begin
t := TThreadEntry.Create(0, 0, nil, '', nil, 0, i, '', 'unknown');
ct.Add(t);
t.Free;
end
else
debugln(DBG_WARNINGS, 'GDBMI: Duplicate thread');
end;
1: begin
if t <> nil then begin
ct.Remove(t);
end
else
debugln(DBG_WARNINGS, 'GDBMI: Missing thread');
end;
end;
FTheDebugger.Threads.Changed;
end;
end;
2: begin // thread-group-started // needed in RunToMain
// Todo, store in seperate field
if self is TGDBMIDebuggerCommandStartDebugging then
FLogWarnings := FLogWarnings + Line + LineEnding;
end;
end;
FTheDebugger.DoNotifyAsync(Line);
end;
procedure DoStatusAsync(const Line: String);
begin
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unexpected async-record: ', Line);
end;
var
S: String;
begin
Result := False;
FProcessResultTimedOut := False;
AResult.Values := '';
AResult.Flags := [];
AResult.State := dsNone;
InLogWarning := False;
FLogWarnings := ''; // TODO: Do not clear in time-out handling
FFullCmdReply := ''; // TODO: Do not clear in time-out handling
repeat
S := FTheDebugger.ReadLine(ATimeOut);
FFullCmdReply := FFullCmdReply + s + LineEnding;
if S = '(gdb) ' then Break;
if s <> ''
then case S[1] of
'^': Result := DoResultRecord(S, Result);
'~': DoConsoleStream(S);
'@': DoTargetStream(S);
'&': DoLogStream(S);
'*': DoExecAsync(S);
'+': DoStatusAsync(S);
'=': DoMsgAsync(S);
else
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown record: ', S);
end;
{$IFDEF VerboseIDEToDo}{$message warning condition should also check end-of-file reached for process output stream}{$ENDIF}
if FTheDebugger.ReadLineTimedOut
then begin
FProcessResultTimedOut := True;
Result := False;
break;
end;
until not FTheDebugger.DebugProcessRunning;
end;
function TGDBMIDebuggerCommand.ProcessGDBResultStruct(S: String;
Opts: TGDBMIProcessResultOpts): String;

583
debugger/gdbmidebuginstructions.pp Normal file
View File

@ -0,0 +1,583 @@
unit GDBMIDebugInstructions;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, math, CmdLineDebugger, GDBMIMiscClasses, LazLoggerBase;
type
{ TGDBMICmdLineDebugger }
TGDBMICmdLineDebugger = class(TCmdLineDebugger)
protected
FErrorHandlingFlags: set of (ehfDeferReadWriteError, ehfGotReadError, ehfGotWriteError);
procedure DoReadError; override;
procedure DoWriteError; override;
end;
{ TGDBInstruction }
TGDBInstructionFlag = (
ifAutoDestroy,
ifRequiresThread,
ifRequiresStackFrame
);
TGDBInstructionFlags = set of TGDBInstructionFlag;
TGDBInstructionResultFlag = (
ifrComleted,
ifrFailed
);
TGDBInstructionResultFlags = set of TGDBInstructionResultFlag;
TGDBInstructionErrorFlag = (
ifeWriteError,
ifeReadError,
ifeGdbNotRunning,
ifeTimedOut,
ifeRecoveredTimedOut
);
TGDBInstructionErrorFlags = set of TGDBInstructionErrorFlag;
TGDBInstructionQueue = class;
{ TGDBInstruction }
TGDBInstruction = class
private
FCommand: String;
FFlags: TGDBInstructionFlags;
FStackFrame: Integer;
FThreadId: Integer;
protected
FResultFlags: TGDBInstructionResultFlags;
FErrorFlags: TGDBInstructionErrorFlags;
FTimeOut: Integer;
procedure SendCommandDataToGDB(AQueue: TGDBInstructionQueue); virtual;
function ProcessInputFromGdb(const AData: String): Boolean; virtual; abstract; // True if data was handled
function IsCompleted: boolean; virtual; // No more InputFromGdb required
procedure MarkAsSuccess;
procedure HandleWriteError(ASender: TGDBInstruction); virtual;
procedure HandleReadError; virtual;
procedure HandleTimeOut; virtual;
procedure HandleRecoveredTimeOut; virtual;
procedure HandleNoGdbRunning; virtual;
function GetTimeOutVerifier: TGDBInstruction; virtual;
procedure Init; virtual;
procedure InternalCreate(ACommand: String;
AThread, AFrame: Integer; // ifRequiresThread, ifRequiresStackFrame will always be included
AFlags: TGDBInstructionFlags;
ATimeOut: Integer
);
public
constructor Create(ACommand: String;
AFlags: TGDBInstructionFlags = [];
ATimeOut: Integer = 0
);
constructor Create(ACommand: String;
AThread: Integer; // ifRequiresThread will always be included
AOtherFlags: TGDBInstructionFlags = [];
ATimeOut: Integer = 0
);
constructor Create(ACommand: String;
AThread, AFrame: Integer; // ifRequiresThread, ifRequiresStackFrame will always be included
AOtherFlags: TGDBInstructionFlags = [];
ATimeOut: Integer = 0
);
function IsSuccess: Boolean;
property Command: String read FCommand;
property ThreadId: Integer read FThreadId;
property StackFrame: Integer read FStackFrame;
property Flags: TGDBInstructionFlags read FFlags;
property ResultFlags: TGDBInstructionResultFlags read FResultFlags;
property ErrorFlags: TGDBInstructionErrorFlags read FErrorFlags;
property TimeOut: Integer read FTimeOut;
end;
{ TGDBInstructionVerifyTimeOut }
TGDBInstructionVerifyTimeOutState = (
vtSent, vtError,
vtGotPrompt,
vtGotPrompt7, vtGotPrompt7gdb, vtGotPrompt7and7, vtGotPrompt7and7gdb,
vtGotPrompt1, vtGotPrompt1gdb,
vtGot7, vtGot7gdb, vtGot7and7, vtGot7and7gdb, vtGot1, vtGot1gdb
);
TGDBInstructionVerifyTimeOut = class(TGDBInstruction)
private
FRunnigInstruction: TGDBInstruction;
FList: TGDBMINameValueList;
FPromptAfterErrorCount: Integer;
FVal7Data: String;
FState: TGDBInstructionVerifyTimeOutState;
protected
procedure SendCommandDataToGDB(AQueue: TGDBInstructionQueue); override;
function ProcessInputFromGdb(const AData: String): Boolean; override;
procedure HandleWriteError(ASender: TGDBInstruction); override;
procedure HandleReadError; override;
procedure HandleTimeOut; override;
procedure HandleNoGdbRunning; override;
function GetTimeOutVerifier: TGDBInstruction; override;
public
constructor Create(ARunnigInstruction: TGDBInstruction);
destructor Destroy; override;
end;
{ TGDBInstructionQueue }
TGDBInstructionQueueFlag = (
ifqValidThread,
ifqValidStackFrame
);
TGDBInstructionQueueFlags = set of TGDBInstructionQueueFlag;
TGDBInstructionQueue = class
private
FCurrentInstruction: TGDBInstruction;
FCurrentStackFrame: Integer;
FCurrunetThreadId: Integer;
FDebugger: TGDBMICmdLineDebugger;
FFlags: TGDBInstructionQueueFlags;
procedure FinishCurrentInstruction;
procedure SetCurrentInstruction(AnInstruction: TGDBInstruction);
protected
function SendDataToGDB(ASender: TGDBInstruction; AData: String): Boolean;
//function ReadDataFromGDB(ASender: TGDBInstruction; AData: String): Boolean;
procedure SelectThread(AThreadId: Integer);
procedure SelectFrame(AFrame: Integer);
public
constructor Create(ADebugger: TGDBMICmdLineDebugger);
procedure InvalidateThredAndFrame;
procedure RunInstruction(AnInstruction: TGDBInstruction); // Wait for instruction to be finished, not queuing
property CurrunetThreadId: Integer read FCurrunetThreadId;
property CurrentStackFrame: Integer read FCurrentStackFrame;
property Flags: TGDBInstructionQueueFlags read FFlags;
end;
function dbgs(AState: TGDBInstructionVerifyTimeOutState): String; overload;
implementation
var
DBGMI_TIMEOUT_DEBUG: PLazLoggerLogGroup;
const
TIMEOUT_AFTER_WRITE_ERROR = 50;
TIMEOUT_FOR_SYNC_AFTER_TIMEOUT = 2500; // extra timeout, while trying to recover from a suspected timeout
TIMEOUT_FOR_SYNC_AFTER_TIMEOUT_MAX = 3000; // upper limit, when using 2*original_timeout
function dbgs(AState: TGDBInstructionVerifyTimeOutState): String; overload;
begin
writestr(Result{%H-}, AState);
end;
{ TGDBInstructionVerifyTimeOut }
procedure TGDBInstructionVerifyTimeOut.SendCommandDataToGDB(AQueue: TGDBInstructionQueue);
begin
AQueue.SendDataToGDB(Self, '-data-evaluate-expression 7');
AQueue.SendDataToGDB(Self, '-data-evaluate-expression 1');
FState := vtSent;
end;
function TGDBInstructionVerifyTimeOut.ProcessInputFromGdb(const AData: String): Boolean;
type
TLineDataTipe = (ldOther, ldGdb, ldValue7, ldValue1);
function CheckData(const ALineData: String): TLineDataTipe;
begin
Result := ldOther;
if ALineData= '(gdb) ' then begin
Result := ldGdb;
exit;
end;
if copy(AData, 1, 6) = '^done,' then begin
if FList = nil then
FList := TGDBMINameValueList.Create(ALineData)
else
FList.Init(ALineData);
if FList.Values['value'] = '7' then
Result := ldValue7
else
if FList.Values['value'] = '1' then
Result := ldValue1
end;
end;
procedure SetError(APromptCount: Integer);
begin
FState := vtError;
FPromptAfterErrorCount := APromptCount; // prompt for val7 and val1 needed
FRunnigInstruction.HandleTimeOut;
if FPromptAfterErrorCount <= 0 then
FTimeOut := 50; // wait for timeout
end;
begin
if FState = vtError then begin
dec(FPromptAfterErrorCount);
if FPromptAfterErrorCount <= 0 then
FTimeOut := 50; // wait for timeout
exit;
end;
case CheckData(AData) of
ldOther: begin
debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Got other data']);
FRunnigInstruction.ProcessInputFromGdb(AData);
end;
ldGdb:
case FState of
vtSent: begin
debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Got prompt in order']);
FState := vtGotPrompt;
FRunnigInstruction.ProcessInputFromGdb(AData);
if not FRunnigInstruction.IsCompleted then begin
debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Prompt was not accepted']);
SetError(2); // prompt for val=7 and val=1 needed
end;
end;
vtGotPrompt7: FState := vtGotPrompt7gdb;
vtGotPrompt7and7: FState := vtGotPrompt7and7gdb;
vtGotPrompt1: FState := vtGotPrompt1gdb;
vtGot7: FState := vtGot7gdb;
vtGot7and7: FState := vtGot7and7gdb;
vtGot1: FState := vtGot1gdb;
else begin
debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Extra Prompt ']);
if FState = vtGotPrompt
then SetError(1) // prompt val=1 needed
else SetError(0); // no more prompt needed
end;
end;
ldValue7:
case FState of
vtSent, vtGotPrompt: begin
debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Got value 7']);
FVal7Data := AData;
if FState = vtSent
then FState := vtGot7
else FState := vtGotPrompt7;
end;
vtGotPrompt7gdb, vtGot7gdb: begin
debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Got value 7 twice. Original Result?']);
FRunnigInstruction.ProcessInputFromGdb(FVal7Data);
if FState = vtGotPrompt7gdb
then FState := vtGotPrompt7and7
else FState := vtGot7and7;
end;
else begin
debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Extra VAlue 7']);
if FState in [vtGotPrompt7, vtGot7]
then SetError(1) // prompt val=1 needed
else SetError(0); // no more prompt needed
end;
end;
ldValue1:
case FState of
vtSent: begin
debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Got other data']);
FRunnigInstruction.ProcessInputFromGdb(AData);
end;
vtGotPrompt7gdb: FState := vtGotPrompt1;
vtGotPrompt7and7gdb: FState := vtGotPrompt1;
vtGot7gdb: FState := vtGot1;
vtGot7and7gdb: FState := vtGot1;
else begin
debugln(DBGMI_TIMEOUT_DEBUG, ['GDBMI TimeOut(', dbgs(FState), '): Wrong Value 1']);
SetError(0);
end;
end;
end;
if FState = vtGot1gdb then begin
// timeout, but recovored
FRunnigInstruction.ProcessInputFromGdb('(gdb) '); // simulate prompt
FRunnigInstruction.HandleRecoveredTimeOut;
end;
if FState in [vtGot1gdb, vtGotPrompt1gdb] then begin
Include(FResultFlags, ifrComleted);
if not FRunnigInstruction.IsCompleted then
FRunnigInstruction.HandleTimeOut;
end;
end;
procedure TGDBInstructionVerifyTimeOut.HandleWriteError(ASender: TGDBInstruction);
begin
inherited HandleWriteError(ASender);
FRunnigInstruction.HandleWriteError(ASender);
end;
procedure TGDBInstructionVerifyTimeOut.HandleReadError;
begin
inherited HandleReadError;
FRunnigInstruction.HandleReadError;
end;
procedure TGDBInstructionVerifyTimeOut.HandleTimeOut;
begin
inherited HandleTimeOut;
FRunnigInstruction.HandleTimeOut;
end;
procedure TGDBInstructionVerifyTimeOut.HandleNoGdbRunning;
begin
inherited HandleNoGdbRunning;
FRunnigInstruction.HandleNoGdbRunning;
end;
function TGDBInstructionVerifyTimeOut.GetTimeOutVerifier: TGDBInstruction;
begin
Result := nil;
end;
constructor TGDBInstructionVerifyTimeOut.Create(ARunnigInstruction: TGDBInstruction);
var
t: Integer;
begin
FRunnigInstruction := ARunnigInstruction;
t := FRunnigInstruction.TimeOut;
t := max(TIMEOUT_FOR_SYNC_AFTER_TIMEOUT, Min(TIMEOUT_FOR_SYNC_AFTER_TIMEOUT_MAX, t * 2));
inherited Create('', FRunnigInstruction.ThreadId, FRunnigInstruction.StackFrame,
FRunnigInstruction.Flags * [ifRequiresThread, ifRequiresStackFrame] + [ifAutoDestroy],
t);
end;
destructor TGDBInstructionVerifyTimeOut.Destroy;
begin
inherited Destroy;
FreeAndNil(FList);
if (FRunnigInstruction <> nil) and (ifAutoDestroy in FRunnigInstruction.Flags) then
FRunnigInstruction.Free;
end;
{ TGDBMICmdLineDebugger }
procedure TGDBMICmdLineDebugger.DoReadError;
begin
include(FErrorHandlingFlags, ehfGotReadError);
if not(ehfDeferReadWriteError in FErrorHandlingFlags)
then inherited DoReadError;
end;
procedure TGDBMICmdLineDebugger.DoWriteError;
begin
include(FErrorHandlingFlags, ehfGotWriteError);
if not(ehfDeferReadWriteError in FErrorHandlingFlags)
then inherited DoWriteError;
end;
{ TGDBInstruction }
procedure TGDBInstruction.SendCommandDataToGDB(AQueue: TGDBInstructionQueue);
begin
AQueue.SendDataToGDB(Self, FCommand);
end;
function TGDBInstruction.IsCompleted: boolean;
begin
Result := FResultFlags * [ifrComleted, ifrFailed] <> [];
end;
procedure TGDBInstruction.MarkAsSuccess;
begin
Include(FResultFlags, ifrComleted);
end;
procedure TGDBInstruction.HandleWriteError(ASender: TGDBInstruction);
begin
//Include(FResultFlags, ifrFailed); // Do not fail yet
Include(FErrorFlags, ifeWriteError);
if (FTimeOut = 0) or (FTimeOut > TIMEOUT_AFTER_WRITE_ERROR) then
FTimeOut := TIMEOUT_AFTER_WRITE_ERROR;
end;
procedure TGDBInstruction.HandleReadError;
begin
Include(FResultFlags, ifrFailed);
Include(FErrorFlags, ifeReadError);
end;
procedure TGDBInstruction.HandleTimeOut;
begin
Include(FResultFlags, ifrFailed);
Include(FErrorFlags, ifeTimedOut);
end;
procedure TGDBInstruction.HandleRecoveredTimeOut;
begin
Include(FErrorFlags, ifeRecoveredTimedOut);
end;
procedure TGDBInstruction.HandleNoGdbRunning;
begin
Include(FResultFlags, ifrFailed);
Include(FErrorFlags, ifeGdbNotRunning);
end;
function TGDBInstruction.GetTimeOutVerifier: TGDBInstruction;
begin
if (ifeWriteError in ErrorFlags) then
Result := nil
else
Result := TGDBInstructionVerifyTimeOut.Create(Self);
end;
procedure TGDBInstruction.Init;
begin
//
end;
procedure TGDBInstruction.InternalCreate(ACommand: String; AThread, AFrame: Integer;
AFlags: TGDBInstructionFlags; ATimeOut: Integer);
begin
FCommand := ACommand;
FThreadId := AThread;
FStackFrame := AFrame;
FFlags := AFlags;
FTimeOut := ATimeOut;
end;
constructor TGDBInstruction.Create(ACommand: String; AFlags: TGDBInstructionFlags;
ATimeOut: Integer = 0);
begin
InternalCreate(ACommand, -1, -1, AFlags, ATimeOut);
Init;
end;
constructor TGDBInstruction.Create(ACommand: String; AThread: Integer;
AOtherFlags: TGDBInstructionFlags; ATimeOut: Integer = 0);
begin
InternalCreate(ACommand, AThread, -1,
AOtherFlags + [ifRequiresThread], ATimeOut);
Init;
end;
constructor TGDBInstruction.Create(ACommand: String; AThread, AFrame: Integer;
AOtherFlags: TGDBInstructionFlags; ATimeOut: Integer = 0);
begin
InternalCreate(ACommand, AThread, AFrame,
AOtherFlags + [ifRequiresThread, ifRequiresStackFrame], ATimeOut);
Init;
end;
function TGDBInstruction.IsSuccess: Boolean;
begin
Result := ResultFlags * [ifrComleted, ifrFailed] = [ifrComleted]
end;
{ TGDBInstructionQueue }
procedure TGDBInstructionQueue.FinishCurrentInstruction;
var
S: String;
NewInstr: TGDBInstruction;
begin
while (FCurrentInstruction <> nil) and
(not FCurrentInstruction.IsCompleted)
do begin
if not FDebugger.DebugProcessRunning then begin
FCurrentInstruction.HandleNoGdbRunning;
break;
end;
S := FDebugger.ReadLine(FCurrentInstruction.TimeOut);
// Readline, may go into Application.ProcessMessages.
// If it does, it has not (yet) read any data.
// Therefore, if it does, another nested call to readline will work, and data will be returned in the correct order.
// If a nested readline reads all data, then the outer will have nothing to return.
// TODO: need a flag, so the outer will immediately return empty.
// TODO: also need a ReadlineCallCounter, to detect inner nested calls
if (not FDebugger.ReadLineTimedOut) or (S <> '') then
FCurrentInstruction.ProcessInputFromGdb(S);
if (ehfGotReadError in FDebugger.FErrorHandlingFlags) then begin
FCurrentInstruction.HandleReadError;
break;
end;
if FDebugger.ReadLineTimedOut then begin
NewInstr := FCurrentInstruction.GetTimeOutVerifier;
if NewInstr <> nil then begin
// TODO: Run NewInstr;
FCurrentInstruction := NewInstr;
FCurrentInstruction.SendCommandDataToGDB(Self);
end
else begin
FCurrentInstruction.HandleTimeOut;
break;
end;
end;
end; // while
if (FCurrentInstruction <> nil) and (ifAutoDestroy in FCurrentInstruction.Flags) then
FCurrentInstruction.Free;
FCurrentInstruction := nil;
end;
procedure TGDBInstructionQueue.SetCurrentInstruction(AnInstruction: TGDBInstruction);
begin
FinishCurrentInstruction;
FCurrentInstruction := AnInstruction;
end;
function TGDBInstructionQueue.SendDataToGDB(ASender: TGDBInstruction; AData: String): Boolean;
begin
Result := True;
FDebugger.FErrorHandlingFlags := FDebugger.FErrorHandlingFlags
+ [ehfDeferReadWriteError] - [ehfGotReadError, ehfGotWriteError];
FDebugger.SendCmdLn(AData);
if ehfGotWriteError in FDebugger.FErrorHandlingFlags then begin
Result := False;
// TODO try reading, but ensure timeout
if FCurrentInstruction <> nil then
FCurrentInstruction.HandleWriteError(ASender)
else
if ASender <> nil then
ASender.HandleWriteError(ASender);
end;
end;
procedure TGDBInstructionQueue.SelectThread(AThreadId: Integer);
begin
end;
procedure TGDBInstructionQueue.SelectFrame(AFrame: Integer);
begin
end;
constructor TGDBInstructionQueue.Create(ADebugger: TGDBMICmdLineDebugger);
begin
FDebugger := ADebugger;
end;
procedure TGDBInstructionQueue.InvalidateThredAndFrame;
begin
FFlags := FFlags - [ifqValidThread, ifqValidStackFrame];
end;
procedure TGDBInstructionQueue.RunInstruction(AnInstruction: TGDBInstruction);
begin
SetCurrentInstruction(AnInstruction);
FCurrentInstruction.SendCommandDataToGDB(Self);
FinishCurrentInstruction;
end;
initialization
DBGMI_TIMEOUT_DEBUG := DebugLogger.RegisterLogGroup('DBGMI_TIMEOUT_DEBUG' {$IFDEF DBGMI_TIMEOUT_DEBUG} , True {$ENDIF} );
end.

10
debugger/test/Gdbmi/TestGdbmi.lpi
View File

@ -1,4 +1,4 @@
<?xml version="1.0"?>
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
@ -46,7 +46,7 @@
<PackageName Value="FCL"/>
</Item5>
</RequiredPackages>
<Units Count="12">
<Units Count="13">
<Unit0>
<Filename Value="TestGdbmi.lpr"/>
<IsPartOfProject Value="True"/>
@ -108,6 +108,11 @@
<IsPartOfProject Value="True"/>
<UnitName Value="TestArgV"/>
</Unit11>
<Unit12>
<Filename Value="testinstructionqueue.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="TestInstructionQueue"/>
</Unit12>
</Units>
</ProjectOptions>
<CompilerOptions>
@ -152,6 +157,7 @@
</Item3>
<Item4>
<Name Value="EAssertionFailedError"/>
<Enabled Value="False"/>
</Item4>
<Item5>
<Name Value="EReadError"/>

2
debugger/test/Gdbmi/TestGdbmi.lpr
View File

@ -4,7 +4,7 @@ program TestGdbmi;
uses
Interfaces, Forms, GuiTestRunner, CompileHelpers,
TestGdbType, TestDisAss,
TestGdbType, TestInstructionQueue, TestDisAss,
TestGDBMIControl,
TestBase, TestException, Testwatches, TestBreakPoint, TestEnvironment, TestArgV;

1
debugger/test/Gdbmi/testbase.pas
View File

@ -1254,6 +1254,7 @@ initialization
DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS', True )^.Enabled := True;
DebugLogger.FindOrRegisterLogGroup('DBG_DISASSEMBLER', True )^.Enabled := True;
DebugLogger.FindOrRegisterLogGroup('DBGMI_TYPE_INFO', True )^.Enabled := True;
DebugLogger.FindOrRegisterLogGroup('DBGMI_TIMEOUT_DEBUG', True )^.Enabled := True;
AppDir := AppendPathDelim(ExtractFilePath(Paramstr(0)));

270
debugger/test/Gdbmi/testinstructionqueue.pas Normal file
View File

@ -0,0 +1,270 @@
unit TestInstructionQueue;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testutils, testregistry, DebugUtils, GDBTypeInfo, strutils, LCLProc,
GDBMIDebugInstructions, LazLoggerBase;
type
{ TTestGdbInstructionQueue }
TTestGdbInstructionQueue = class(TTestCase)
private
published
procedure TestTimeout;
end;
TTestDbgControl = Record
Action: (AEnd,
aExpSend, aReadResp, aReadRespTimeOut,
aKillDbgProcess);
Data: String;
end;
PTestDbgControl = ^TTestDbgControl;
{ TTestDebugger }
TTestDebugger = class(TGDBMICmdLineDebugger)
private
FTestDbgProcessRunning: Boolean;
FTestData: PTestDbgControl;
FTest: TTestGdbInstructionQueue;
FTestReadLineTimedOut: Boolean;
protected
function GetDebugProcessRunning: Boolean; override;
procedure SendCmdLn(const ACommand: String); override;
function ReadLine(const APeek: Boolean; ATimeOut: Integer = - 1): String; override;
function CreateDebugProcess(const AOptions: String): Boolean; override;
function ReadLineTimedOut: Boolean; override;
public
procedure TestInit;
end;
TTestGDBInstruction = class(TGDBInstruction)
protected
FInput: String;
function ProcessInputFromGdb(const AData: String): Boolean; override;
end;
implementation
var
DBG_CMD_ECHO, DBG_CMD_ECHO_FULL: PLazLoggerLogGroup;
{ TTestGDBInstruction }
function TTestGDBInstruction.ProcessInputFromGdb(const AData: String): Boolean;
begin
if AData = '(gdb) ' then
Include(FResultFlags, ifrComleted)
else
FInput := FInput + AData + LineEnding;
end;
{ TTestDebugger }
function TTestDebugger.GetDebugProcessRunning: Boolean;
begin
Result := FTestDbgProcessRunning;
end;
procedure TTestDebugger.SendCmdLn(const ACommand: String);
begin
if (DBG_CMD_ECHO_FULL <> nil) and (DBG_CMD_ECHO_FULL^.Enabled)
then debugln(DBG_CMD_ECHO_FULL, '>> TCmdLineDebugger.SendCmdLn "',ACommand,'"')
else debugln(DBG_CMD_ECHO, '>> TCmdLineDebugger.SendCmdLn "',ACommand,'"');
//If FTestData^.Action = AEnd then exit;
FTest.AssertTrue('Action <> AEnd', FTestData^.Action <> AEnd);
FTest.AssertTrue('Action = aExpSend', FTestData^.Action = aExpSend);
FTest.AssertEquals('SendCmdLn()', FTestData^.Data, ACommand);
inc(FTestData);
end;
function TTestDebugger.ReadLine(const APeek: Boolean; ATimeOut: Integer): String;
begin
Result := '';
FTestReadLineTimedOut := False;
//If FTestData^.Action = AEnd then exit;
FTest.AssertTrue('Action <> AEnd', FTestData^.Action <> AEnd);
If FTestData^.Action = aReadResp then begin
Result := FTestData^.Data;
if ((DBG_CMD_ECHO_FULL <> nil) and (DBG_CMD_ECHO_FULL^. Enabled))
then debugln(DBG_CMD_ECHO_FULL, '<< TCmdLineDebugger.ReadLn "',Result,'"')
else if (length(Result) < 300)
then debugln(DBG_CMD_ECHO, '<< TCmdLineDebugger.ReadLn "',Result,'"')
else debugln(DBG_CMD_ECHO, ['<< TCmdLineDebugger.ReadLn "',copy(Result, 1, 200), '" ..(',length(Result)-250,').. "',copy(Result, length(Result)-99, 100),'"']);
inc(FTestData);
exit;
end;
If FTestData^.Action = aReadRespTimeOut then begin
FTest.AssertTrue('can timeout', ATimeOut > 0);
FTestReadLineTimedOut := True;
debugln(DBG_CMD_ECHO_FULL, '<< TCmdLineDebugger.ReadLn -- TimeOut');
inc(FTestData);
exit;
end;
FTest.AssertTrue('Action = aReadResp', False);
end;
function TTestDebugger.CreateDebugProcess(const AOptions: String): Boolean;
begin
Result := True;
end;
function TTestDebugger.ReadLineTimedOut: Boolean;
begin
Result := FTestReadLineTimedOut;
end;
procedure TTestDebugger.TestInit;
begin
FTestDbgProcessRunning := True;
end;
{ TTestGdbInstructionQueue }
const
// No timeout
TestControl1: array [0..3] of TTestDbgControl = (
(Action: aExpSend; Data: '-test-send';),
(Action: aReadResp; Data: '^done,foo';),
(Action: aReadResp; Data: '(gdb) ';),
(Action: AEnd; Data: '';)
);
// Recover timeout
TestControl2: array [0..9] of TTestDbgControl = (
(Action: aExpSend; Data: '-test-send';),
(Action: aReadResp; Data: '^done,foo';),
(Action: aReadRespTimeOut; Data: '';),
(Action: aExpSend; Data: '-data-evaluate-expression 7';),
(Action: aExpSend; Data: '-data-evaluate-expression 1';),
(Action: aReadResp; Data: '^done,value="7"';),
(Action: aReadResp; Data: '(gdb) ';),
(Action: aReadResp; Data: '^done,value="1"';),
(Action: aReadResp; Data: '(gdb) ';),
(Action: AEnd; Data: '';)
);
// late (gdb) / no timeout
TestControl3: array [0..10] of TTestDbgControl = (
(Action: aExpSend; Data: '-test-send';),
(Action: aReadResp; Data: '^done,foo';),
(Action: aReadRespTimeOut; Data: '';),
(Action: aExpSend; Data: '-data-evaluate-expression 7';),
(Action: aExpSend; Data: '-data-evaluate-expression 1';),
(Action: aReadResp; Data: '(gdb) ';),
(Action: aReadResp; Data: '^done,value="7"';),
(Action: aReadResp; Data: '(gdb) ';),
(Action: aReadResp; Data: '^done,value="1"';),
(Action: aReadResp; Data: '(gdb) ';),
(Action: AEnd; Data: '';)
);
// late response + (gdb) / no timeout
TestControl3A: array [0..10] of TTestDbgControl = (
(Action: aExpSend; Data: '-test-send';),
(Action: aReadRespTimeOut; Data: '';),
(Action: aExpSend; Data: '-data-evaluate-expression 7';),
(Action: aExpSend; Data: '-data-evaluate-expression 1';),
(Action: aReadResp; Data: '^done,foo';),
(Action: aReadResp; Data: '(gdb) ';),
(Action: aReadResp; Data: '^done,value="7"';),
(Action: aReadResp; Data: '(gdb) ';),
(Action: aReadResp; Data: '^done,value="1"';),
(Action: aReadResp; Data: '(gdb) ';),
(Action: AEnd; Data: '';)
);
// timeout
TestControl4: array [0..6] of TTestDbgControl = (
(Action: aExpSend; Data: '-test-send';),
(Action: aReadResp; Data: '^done,foo';),
(Action: aReadRespTimeOut; Data: '';),
(Action: aExpSend; Data: '-data-evaluate-expression 7';),
(Action: aExpSend; Data: '-data-evaluate-expression 1';),
(Action: aReadRespTimeOut; Data: '';),
(Action: AEnd; Data: '';)
);
procedure TTestGdbInstructionQueue.TestTimeout;
var
Dbg: TTestDebugger;
Queue: TGDBInstructionQueue;
Instr: TTestGDBInstruction;
begin
Dbg := TTestDebugger.Create('');
Queue := TGDBInstructionQueue.Create(Dbg);
// No timeout
Instr := TTestGDBInstruction.Create('-test-send', [], 100);
Dbg.TestInit;
dbg.FTest := Self;
Dbg.FTestData := @TestControl1[0];
Queue.RunInstruction(Instr);
AssertTrue('ifrComleted', Instr.ResultFlags * [ifrComleted, ifrFailed] = [ifrComleted]);
AssertTrue('no error', Instr.ErrorFlags = []);
AssertEquals('data', '^done,foo'+LineEnding, Instr.FInput);
Instr.Free;
// Recover timeout
Instr := TTestGDBInstruction.Create('-test-send', [], 100);
Dbg.TestInit;
dbg.FTest := Self;
Dbg.FTestData := @TestControl2[0];
Queue.RunInstruction(Instr);
AssertTrue('ifrComleted', Instr.ResultFlags * [ifrComleted, ifrFailed] = [ifrComleted]);
AssertTrue('no error, but warning', Instr.ErrorFlags = [ifeRecoveredTimedOut]);
AssertEquals('data', '^done,foo'+LineEnding, Instr.FInput);
Instr.Free;
// late (gdb) / no timeout
Instr := TTestGDBInstruction.Create('-test-send', [], 100);
Dbg.TestInit;
dbg.FTest := Self;
Dbg.FTestData := @TestControl3[0];
Queue.RunInstruction(Instr);
AssertTrue('ifrComleted', Instr.ResultFlags * [ifrComleted, ifrFailed] = [ifrComleted]);
AssertTrue('no error', Instr.ErrorFlags = []);
AssertEquals('data', '^done,foo'+LineEnding, Instr.FInput);
Instr.Free;
// late response + (gdb) / no timeout
Instr := TTestGDBInstruction.Create('-test-send', [], 100);
Dbg.TestInit;
dbg.FTest := Self;
Dbg.FTestData := @TestControl3A[0];
Queue.RunInstruction(Instr);
AssertTrue('ifrComleted', Instr.ResultFlags * [ifrComleted, ifrFailed] = [ifrComleted]);
AssertTrue('no error', Instr.ErrorFlags = []);
AssertEquals('data', '^done,foo'+LineEnding, Instr.FInput);
Instr.Free;
// timeout
Instr := TTestGDBInstruction.Create('-test-send', [], 100);
Dbg.TestInit;
dbg.FTest := Self;
Dbg.FTestData := @TestControl4[0];
Queue.RunInstruction(Instr);
AssertTrue('ifrFailed', Instr.ResultFlags * [ifrComleted, ifrFailed] = [ifrFailed]);
AssertTrue('error', Instr.ErrorFlags = [ifeTimedOut]);
Instr.Free;
Queue.Free;
Dbg.Free;
end;
initialization
RegisterTest(TTestGdbInstructionQueue);
DBG_CMD_ECHO := DebugLogger.FindOrRegisterLogGroup('DBG_CMD_ECHO');
DBG_CMD_ECHO_FULL := DebugLogger.FindOrRegisterLogGroup('DBG_CMD_ECHO_FULL');
end.