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

DBG: Added timeout to stop-command

Browse Source 
git-svn-id: trunk@30562 -
This commit is contained in:
martin 2011-05-05 22:02:59 +00:00
parent 20c335471a
commit 4348781a98
1 changed files with 39 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
debugger/gdbmidebugger.pp
View File

@ -336,7 +336,6 @@ type
function ConvertPascalExpression(var AExpression: String): Boolean;
// ---
procedure ClearSourceInfo;
procedure GDBStopCallback(const AResult: TGDBMIExecResult; const ATag: PtrInt);
function FindBreakpoint(const ABreakpoint: Integer): TDBGBreakPoint;
procedure SelectStackFrame(AIndex: Integer);
@ -547,6 +546,13 @@ type
function KillNow: Boolean;
end;
{ TGDBMIDebuggerCommandKill }
TGDBMIDebuggerCommandKill = class(TGDBMIDebuggerCommand)
protected
function DoExecute: Boolean; override;
end;
{%endregion *^^^* TGDBMIDebuggerCommands *^^^* }
{%region ***** Locals ***** }
@ -1382,6 +1388,29 @@ begin
Result := '"' + Result + '"';
end;
{ TGDBMIDebuggerCommandKill }
function TGDBMIDebuggerCommandKill.DoExecute: Boolean;
var
R: TGDBMIExecResult;
CmdRes: Boolean;
begin
Result := True;
// not supported yet
// ExecuteCommand('-exec-abort');
CmdRes := ExecuteCommand('kill', [], [], 1500); // Hardcoded timeout
if CmdRes
then CmdRes := ExecuteCommand('info program', R, [], 1500); // Hardcoded timeout
if (not CmdRes)
or (Pos('not being run', R.Values) <= 0)
then begin
FTheDebugger.DebugProcess.Terminate(0);
SetDebuggerState(dsError); // failed to stop
exit;
end;
SetDebuggerState(dsStop);
end;
{ TGDBMIDebuggerCommandChangeThread }
function TGDBMIDebuggerCommandChangeThread.DoExecute: Boolean;
@ -4289,10 +4318,16 @@ begin
FTheDebugger.GDBPause(True);
FTheDebugger.CancelAllQueued; // before ProcessStopped
Result := ProcessRunning(StoppedParams);
if ProcessResultTimedOut then begin
// the uter Processrunning should stop, due to process no longer running
FTheDebugger.DebugProcess.Terminate(0);
Result := True;
exit;
end;
if StoppedParams <> ''
then ProcessStopped(StoppedParams, FTheDebugger.PauseWaitState = pwsInternal);
ExecuteCommand('kill');
ExecuteCommand('kill', [], 1500);
Result := ExecuteCommand('info program', [], R);
Result := Result and (Pos('not being run', R.Values) > 0);
if Result
@ -5671,21 +5706,8 @@ begin
then GDBPause(True);
CancelAllQueued;
// not supported yet
// ExecuteCommand('-exec-abort');
Result := ExecuteCommand('kill', [cfNoMiCommand], @GDBStopCallback, 0);
end;
procedure TGDBMIDebugger.GDBStopCallback(const AResult: TGDBMIExecResult; const ATag: PtrInt);
var
R: TGDBMIExecResult;
begin
// verify stop
if not ExecuteCommand('info program', [], [cfNoMICommand], R) then Exit;
if Pos('not being run', R.Values) > 0
then SetState(dsStop);
QueueCommand(TGDBMIDebuggerCommandKill.Create(Self));
Result := True;
end;
function TGDBMIDebugger.GetSupportedCommands: TDBGCommands;