diff --git a/components/fpcunit/guitestrunner.lfm b/components/fpcunit/guitestrunner.lfm index 670864659a..a84896b102 100644 --- a/components/fpcunit/guitestrunner.lfm +++ b/components/fpcunit/guitestrunner.lfm @@ -4,7 +4,7 @@ object GUITestRunner: TGUITestRunner Top = 123 Width = 575 Caption = 'FPCUnit - run unit tests' - ClientHeight = 636 + ClientHeight = 643 ClientWidth = 575 Constraints.MinHeight = 200 Constraints.MinWidth = 250 @@ -103,20 +103,20 @@ object GUITestRunner: TGUITestRunner end object Panel2: TPanel Left = 0 - Height = 556 + Height = 563 Top = 80 Width = 575 Align = alClient BevelOuter = bvNone Caption = 'Panel2' - ClientHeight = 556 + ClientHeight = 563 ClientWidth = 575 FullRepaint = False TabOrder = 1 TabStop = True object PageControl1: TPageControl Left = 0 - Height = 556 + Height = 563 Top = 0 Width = 575 ActivePage = tsTestTree @@ -126,17 +126,18 @@ object GUITestRunner: TGUITestRunner TabOrder = 0 object tsTestTree: TTabSheet Caption = 'Testcase tree' - ClientHeight = 529 - ClientWidth = 571 + ClientHeight = 535 + ClientWidth = 567 object TestTree: TTreeView Left = 0 - Height = 317 + Height = 323 Top = 3 - Width = 571 + Width = 567 Align = alClient BorderSpacing.Top = 3 BackgroundColor = clBtnFace Color = clBtnFace + DefaultItemHeight = 18 Images = TestTreeImageList PopupMenu = PopupResults ReadOnly = True @@ -154,16 +155,16 @@ object GUITestRunner: TGUITestRunner Cursor = crVSplit Left = 0 Height = 5 - Top = 320 - Width = 571 + Top = 326 + Width = 567 Align = alBottom ResizeAnchor = akBottom end object MemoDetails: TMemo Left = 0 Height = 97 - Top = 432 - Width = 571 + Top = 438 + Width = 567 Align = alBottom PopupMenu = PopupDetails ReadOnly = True @@ -174,16 +175,16 @@ object GUITestRunner: TGUITestRunner Cursor = crVSplit Left = 0 Height = 5 - Top = 427 - Width = 571 + Top = 433 + Width = 567 Align = alBottom ResizeAnchor = akBottom end object MemoLog: TMemo Left = 0 Height = 102 - Top = 325 - Width = 571 + Top = 331 + Width = 567 Align = alBottom ReadOnly = True ScrollBars = ssAutoBoth @@ -213,7 +214,7 @@ object GUITestRunner: TGUITestRunner TabOrder = 0 BookMarkOptions.Xoffset = -18 Gutter.Visible = False - Gutter.Width = 57 + Gutter.Width = 59 Gutter.MouseActions = < item ClickCount = ccAny @@ -652,7 +653,7 @@ object GUITestRunner: TGUITestRunner MouseActions = <> end object TSynGutterLineNumber - Width = 17 + Width = 19 MouseActions = <> MarkupInfo.Background = clBtnFace MarkupInfo.Foreground = clNone @@ -1816,6 +1817,16 @@ object GUITestRunner: TGUITestRunner OnExecute = ActSaveResultsExecute ShortCut = 16467 end + object actNextError: TAction + Caption = 'Next error' + OnExecute = actNextErrorExecute + ShortCut = 16462 + end + object actPrevError: TAction + Caption = 'Previous error' + OnExecute = actPrevErrorExecute + ShortCut = 16464 + end end object PopupResults: TPopupMenu Images = MainImageList @@ -1970,6 +1981,12 @@ object GUITestRunner: TGUITestRunner } OnClick = ActRunHighlightedTestExecute end + object MenuItem22: TMenuItem + Action = actNextError + end + object MenuItem23: TMenuItem + Action = actPrevError + end object MenuItem5: TMenuItem Action = ActCheckAll OnClick = ActCheckAllExecute @@ -2284,6 +2301,12 @@ object GUITestRunner: TGUITestRunner FF00FFFFFF00FFFFFF00 } end + object MenuItem20: TMenuItem + Action = actNextError + end + object MenuItem21: TMenuItem + Action = actPrevError + end object MenuItem13: TMenuItem Caption = '-' end diff --git a/components/fpcunit/guitestrunner.pas b/components/fpcunit/guitestrunner.pas index 8ae8fb65f4..93d26f6c87 100644 --- a/components/fpcunit/guitestrunner.pas +++ b/components/fpcunit/guitestrunner.pas @@ -102,6 +102,12 @@ type tsTestTree: TTabSheet; tsResultsXML: TTabSheet; XMLSynEdit: TSynEdit; + actNextError: TAction; + MenuItem20: TMenuItem; + actPrevError: TAction; + MenuItem21: TMenuItem; + MenuItem22: TMenuItem; + MenuItem23: TMenuItem; procedure ActCheckAllExecute(Sender: TObject); procedure ActCheckCurrentSuiteExecute(Sender: TObject); procedure ActCloseFormExecute(Sender: TObject); @@ -127,6 +133,8 @@ type procedure ActCopyErrorMsgExecute(Sender: TObject); procedure ActCopyErrorMsgUpdate(Sender: TObject); procedure pbBarPaint(Sender: TObject); + procedure actNextErrorExecute(Sender: TObject); + procedure actPrevErrorExecute(Sender: TObject); private failureCounter: Integer; errorCounter: Integer; @@ -159,6 +167,8 @@ type procedure RunTest(ATest: TTest); procedure StartTestSuite(ATestSuite: TTestSuite); procedure EndTestSuite(ATestSuite: TTestSuite); + procedure NextError; + procedure PrevError; end; var @@ -615,6 +625,16 @@ begin end; end; +procedure TGUITestRunner.actNextErrorExecute(Sender: TObject); +begin + NextError; +end; + +procedure TGUITestRunner.actPrevErrorExecute(Sender: TObject); +begin + PrevError; +end; + procedure TGUITestRunner.BuildTree(rootNode: TTreeNode; aSuite: TTestSuite); var @@ -1013,6 +1033,42 @@ begin PaintNodeNonFailed(Node); end; +procedure TGUITestRunner.NextError; +var + Node: TTreeNode; +begin + Node := TestTree.Selected; + while Assigned(Node) do + begin + Node := Node.GetNext; + if Assigned(Node) and (Node.ImageIndex in [imgRedBall, imgPurpleBall]) and + (TObject(Node.Data) is TTestCase) then + begin + TestTree.Selected := Node; + TestTree.MakeSelectionVisible; + Exit; + end; + end; +end; + +procedure TGUITestRunner.PrevError; +var + Node: TTreeNode; +begin + Node := TestTree.Selected; + while Assigned(Node) do + begin + Node := Node.GetPrev; + if Assigned(Node) and (Node.ImageIndex in [imgRedBall, imgPurpleBall]) and + (TObject(Node.Data) is TTestCase) then + begin + TestTree.Selected := Node; + TestTree.MakeSelectionVisible; + Exit; + end; + end; +end; + procedure TranslateResStrings; var Lang, FallbackLang, S: String;