Debugger: Display errors on run/step to user, with a choice to continue; instead of "error state"

git-svn-id: trunk@30416 -

.gitattributes

@@ -2695,6 +2695,8 @@ debugger/evaluatedlg.lfm svneol=native#text/plain
 debugger/evaluatedlg.pp svneol=native#text/pascal
 debugger/exceptiondlg.lfm svneol=native#text/plain
 debugger/exceptiondlg.pas svneol=native#text/pascal
+debugger/feedbackdlg.lfm svneol=native#text/plain
+debugger/feedbackdlg.pp svneol=native#text/pascal
 debugger/fpdebug/dbgclasses.pp svneol=native#text/pascal
 debugger/fpdebug/dbgdisasx86.pp svneol=native#text/plain
 debugger/fpdebug/dbgdwarf.pas svneol=native#text/pascal

debugger/debugger.pp

@@ -1481,6 +1481,10 @@ type
     ecDebugger);  // debugger errors and warnings
   TDBGEventCategories = set of TDBGEventCategory;
 
+  TDBGFeedbackType = (ftWarning, ftError);
+  TDBGFeedbackResult = (frOk, frStop);
+  TDBGFeedbackResults = set of TDBGFeedbackResult;
+
   TDBGEventNotify = procedure(Sender: TObject; const ACategory: TDBGEventCategory;
                               const AText: String) of object;
 
@@ -1496,6 +1500,10 @@ type
                                  const AExceptionText: String;
                                  out AContinue: Boolean) of object;
 
+  TDBGFeedbackEvent = function(Sender: TObject; const AText, AInfo: String;
+                               AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults
+                              ): TDBGFeedbackResult of object;
+
   TDebuggerNotifyReason = (dnrDestroy);
 
   { TDebuggerProperties }
@@ -1525,6 +1533,7 @@ type
     FLocals: TDBGLocals;
     FLineInfo: TDBGLineInfo;
     FOnConsoleOutput: TDBGOutputEvent;
+    FOnFeedback: TDBGFeedbackEvent;
     FRegisters: TDBGRegisters;
     FShowConsole: Boolean;
     FSignals: TDBGSignals;
@@ -1647,6 +1656,7 @@ type
     property OnState: TDebuggerStateChangedEvent read FOnState write FOnState;   // Fires when the current state of the debugger changes
     property OnBreakPointHit: TDebuggerBreakPointHitEvent read FOnBreakPointHit write FOnBreakPointHit;   // Fires when the program is paused at a breakpoint
     property OnConsoleOutput: TDBGOutputEvent read FOnConsoleOutput write FOnConsoleOutput;  // Passes Application Console Output
+    property OnFeedback: TDBGFeedbackEvent read FOnFeedback write FOnFeedback;
   end;
   TDebuggerClass = class of TDebugger;
 

debugger/feedbackdlg.lfm

@@ -0,0 +1,68 @@
+object DbgFeedbackDlg: TDbgFeedbackDlg
+  Left = 480
+  Height = 212
+  Top = 140
+  Width = 605
+  AutoSize = True
+  BorderIcons = [biSystemMenu]
+  BorderStyle = bsDialog
+  Caption = 'DbgFeedbackDlg'
+  ClientHeight = 212
+  ClientWidth = 605
+  Position = poScreenCenter
+  LCLVersion = '0.9.31'
+  object ButtonPanel1: TButtonPanel
+    Left = 6
+    Height = 34
+    Top = 172
+    Width = 593
+    OKButton.Name = 'OKButton'
+    OKButton.Caption = '&OK'
+    HelpButton.Name = 'HelpButton'
+    HelpButton.Caption = '&Help'
+    HelpButton.OnClick = HelpButtonClick
+    CloseButton.Name = 'CloseButton'
+    CloseButton.Caption = '&Close'
+    CloseButton.Enabled = False
+    CancelButton.Name = 'CancelButton'
+    CancelButton.Caption = 'Stop'
+    TabOrder = 0
+    ShowButtons = [pbOK, pbCancel, pbHelp]
+    ShowGlyphs = [pbOK, pbCancel]
+  end
+  object Panel1: TPanel
+    Left = 0
+    Height = 166
+    Top = 0
+    Width = 605
+    Align = alClient
+    BevelOuter = bvNone
+    ClientHeight = 166
+    ClientWidth = 605
+    TabOrder = 1
+    object lblMsg: TLabel
+      Left = 5
+      Height = 61
+      Top = 5
+      Width = 595
+      Align = alClient
+      BorderSpacing.Around = 5
+      Caption = 'lblMsg'
+      ParentColor = False
+    end
+    object Memo1: TMemo
+      Left = 5
+      Height = 90
+      Top = 71
+      Width = 595
+      Align = alBottom
+      BorderSpacing.Around = 5
+      Lines.Strings = (
+        'Memo1'
+      )
+      ReadOnly = True
+      TabOrder = 0
+      Visible = False
+    end
+  end
+end

debugger/feedbackdlg.pp

@@ -0,0 +1,102 @@
+unit FeedbackDlg;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Forms, Controls, ButtonPanel, StdCtrls, ExtCtrls, Debugger, LazarusIDEStrConsts;
+
+type
+
+  { TDbgFeedbackDlg }
+
+  TDbgFeedbackDlg = class(TForm)
+    ButtonPanel1: TButtonPanel;
+    lblMsg: TLabel;
+    Memo1: TMemo;
+    Panel1: TPanel;
+    procedure HelpButtonClick(Sender: TObject);
+  private
+    { private declarations }
+  public
+    { public declarations }
+    function Execute(const AText, AInfo: String;
+                     AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults
+                    ): TDBGFeedbackResult;
+  end;
+
+var
+  DbgFeedbackDlg: TDbgFeedbackDlg;
+
+function ExecuteFeedbackDialog(const AText, AInfo: String;
+                               AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults
+                              ): TDBGFeedbackResult;
+
+implementation
+
+function ExecuteFeedbackDialog(const AText, AInfo: String; AType: TDBGFeedbackType;
+  AButtons: TDBGFeedbackResults): TDBGFeedbackResult;
+var
+  ADialog: TDbgFeedbackDlg;
+begin
+  ADialog := TDbgFeedbackDlg.Create(Application);
+  try
+    Result := ADialog.Execute(AText, AInfo, AType, AButtons);
+  finally
+    ADialog.Free;
+  end;
+end;
+
+{ TDbgFeedbackDlg }
+
+procedure TDbgFeedbackDlg.HelpButtonClick(Sender: TObject);
+begin
+  AutoSize := False;
+  Memo1.Visible := not Memo1.Visible;
+  if Memo1.Visible then
+    ButtonPanel1.HelpButton.Caption := lisDebuggerFeedbackLess
+  else
+    ButtonPanel1.HelpButton.Caption := lisDebuggerFeedbackMore;
+  AutoSize := True;
+end;
+
+function TDbgFeedbackDlg.Execute(const AText, AInfo: String; AType: TDBGFeedbackType;
+  AButtons: TDBGFeedbackResults): TDBGFeedbackResult;
+begin
+  case AType of
+    ftWarning: begin
+        Caption := lisDebuggerFeedbackWarning;
+      end;
+    ftError: begin
+        Caption := lisDebuggerFeedbackError;
+      end;
+  end;
+  lblMsg.Caption := AText;
+  memo1.Text := AInfo;
+  memo1.Visible := False;
+  if AInfo <> '' then begin
+    ButtonPanel1.HelpButton.Caption := lisDebuggerFeedbackMore;
+    ButtonPanel1.HelpButton.Visible := True;
+  end
+  else begin
+    ButtonPanel1.HelpButton.Visible := False;
+  end;
+
+
+  ButtonPanel1.OKButton.Visible := frOk in AButtons;
+  ButtonPanel1.CancelButton.Visible := frStop in AButtons;
+
+  ButtonPanel1.OKButton.Caption := lisDebuggerFeedbackOk;
+  ButtonPanel1.CancelButton.Caption := lisDebuggerFeedbackStop;
+
+  case ShowModal of
+    mrOk: Result := frOk;
+    mrCancel: Result := frStop;
+  end;
+end;
+
+{$R *.lfm}
+
+end.
+

debugger/gdbmidebugger.pp

@@ -399,6 +399,14 @@ type
     procedure TestCmd(const ACommand: String); override;
   end;
 
+resourcestring
+  gdbmiErrorOnRunCommand = 'The debugger encountered an error when trying to '
+    + 'run/step the application:%0:s%0:s%1:s%0:s%0:s'
+    + 'Press "Ok" to continue debugging (paused), '
+    + 'and correct the problem, or choose an alternative run command%0:s'
+    + 'Press "Stop" to end the debug session';
+  gdbmiErrorOnRunCommandWithWarning = '%0:s%0:sIn addition to the Error the following '
+    + 'warning was encountered:%0:s%0:s%1:s';
 
 implementation
 
@@ -514,6 +522,7 @@ type
     FExecType: TGDBMIExecCommandType;
     FCommand: String;
     FCanKillNow, FDidKillNow: Boolean;
+    FLogWarnings: String;
   protected
     procedure DoLockQueueExecute; override;
     procedure DoUnockQueueExecute; override;
@@ -2903,7 +2912,6 @@ function TGDBMIDebuggerCommandStartDebugging.DoExecute: Boolean;
     FTheDebugger.FMainAddr := StrToQWordDef(ResultList.Values['addr'], 0);
     ResultList.Free;
   end;
-
 var
   R: TGDBMIExecResult;
   FileType, EntryPoint: String;
@@ -3167,6 +3175,8 @@ begin
 end;
 
 function TGDBMIDebuggerCommandExecute.ProcessRunning(var AStoppedParams: String): Boolean;
+var
+  InLogWarning: Boolean;
 
   function DoExecAsync(var Line: String): Boolean;
   var
@@ -3222,8 +3232,16 @@ function TGDBMIDebuggerCommandExecute.ProcessRunning(var AStoppedParams: String)
   end;
 
   procedure DoLogStream(const Line: String);
+  const
+    LogWarning = '&"Warning:\n"';
   begin
     DebugLn('[Debugger] Log output: ', Line);
+    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;
 
 var
@@ -3231,6 +3249,8 @@ var
   idx: Integer;
 begin
   Result := True;
+  InLogWarning := False;
+  FLogWarnings := '';
   while FTheDebugger.DebugProcessRunning do
   begin
     S := FTheDebugger.ReadLine;
@@ -3631,9 +3651,10 @@ end;
 
 function TGDBMIDebuggerCommandExecute.DoExecute: Boolean;
 var
-  StoppedParams: String;
+  StoppedParams, s, s2: String;
   ContinueExecution: Boolean;
   NextExecCmdObj: TGDBMIDebuggerCommandExecute;
+  List: TGDBMINameValueList;
 begin
   Result := True;
   FCanKillNow := False;
@@ -3646,8 +3667,31 @@ begin
     if not ExecuteCommand(FCommand, FResult)
     then exit;
 
+    if (FResult.State = dsError) and assigned(FTheDebugger.OnFeedback) then begin
+      List := TGDBMINameValueList.Create(FResult);
+      s := List.Values['msg'];
+      FreeAndNil(List);
+      if FLogWarnings <> ''
+      then s2 := Format(gdbmiErrorOnRunCommandWithWarning, [LineEnding, FLogWarnings])
+      else s2 := '';
+      FLogWarnings := '';
+      if s <> '' then begin
+        case FTheDebugger.OnFeedback(self,
+                                     Format(gdbmiErrorOnRunCommand, [LineEnding, s]) + s2,
+                                     FResult.Values, ftError, [frOk, frStop]
+             ) of
+          frOk: FResult.State := dsPause;
+          frStop: begin
+              FTheDebugger.Stop;
+              FResult.State := dsStop;
+              exit;
+            end;
+        end;
+      end
+    end;
     if (FResult.State <> dsNone)
     then SetDebuggerState(FResult.State);
+
     // if ContinueExecution will be true, the we ignore dsError..
 
     // TODO: chack for cancelled

ide/debugmanager.pas

@@ -56,7 +56,7 @@ uses
   SourceMarks,
   DebuggerDlg, Watchesdlg, BreakPointsdlg, BreakPropertyDlg, LocalsDlg, WatchPropertyDlg,
   CallStackDlg, EvaluateDlg, RegistersDlg, AssemblerDlg, DebugOutputForm, ExceptionDlg,
-  InspectDlg, DebugEventsForm, PseudoTerminalDlg,
+  InspectDlg, DebugEventsForm, PseudoTerminalDlg, FeedbackDlg,
   GDBMIDebugger, SSHGDBMIDebugger, ProcessDebugger,
   BaseDebugManager;
 
@@ -80,6 +80,8 @@ type
     procedure DebuggerOutput(Sender: TObject; const AText: String);
     procedure DebuggerEvent(Sender: TObject; const ACategory: TDBGEventCategory; const AText: String);
     procedure DebuggerConsoleOutput(Sender: TObject; const AText: String);
+    function DebuggerFeedback(Sender: TObject; const AText, AInfo: String;
+      AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults): TDBGFeedbackResult;
     procedure DebuggerException(Sender: TObject;
       const AExceptionType: TDBGExceptionType;
       const AExceptionClass, AExceptionText: String;
@@ -1487,6 +1489,12 @@ begin
   TPseudoConsoleDlg(FDialogs[ddtPseudoTerminal]).AddOutput(AText);
 end;
 
+function TDebugManager.DebuggerFeedback(Sender: TObject; const AText, AInfo: String;
+  AType: TDBGFeedbackType; AButtons: TDBGFeedbackResults): TDBGFeedbackResult;
+begin
+  Result := ExecuteFeedbackDialog(AText, AInfo, AType, AButtons);
+end;
+
 procedure TDebugManager.BreakAutoContinueTimer(Sender: TObject);
 begin
   FAutoContinueTimer.Enabled := False;
@@ -2611,7 +2619,8 @@ begin
     FDebugger.OnDbgOutput     := @DebuggerOutput;
     FDebugger.OnDbgEvent      := @DebuggerEvent;
     FDebugger.OnException     := @DebuggerException;
-    FDebugger.OnConsoleOutput :=@DebuggerConsoleOutput;
+    FDebugger.OnConsoleOutput := @DebuggerConsoleOutput;
+    FDebugger.OnFeedback      := @DebuggerFeedback;
 
     if FDebugger.State = dsNone
     then begin

ide/lazarusidestrconsts.pas

@@ -5251,6 +5251,12 @@ resourcestring
   lisFileNotFound3 = 'file %s not found';
   lisFileNotFound4 = 'file not found';
   lisISDDirectoryNotFound = 'directory not found';
+  lisDebuggerFeedbackWarning = 'Debugger Warning';
+  lisDebuggerFeedbackError = 'Debugger Error';
+  lisDebuggerFeedbackStop = 'Stop';
+  lisDebuggerFeedbackLess = 'Less';
+  lisDebuggerFeedbackMore = 'More';
+  lisDebuggerFeedbackOk = 'Ok';
 
 implementation