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

FPCUnit: Add Next failure / Previous failure controls for GUI test runner. Issue #22975, patch from jacobb.

Browse Source 
git-svn-id: trunk@49690 -
This commit is contained in:
juha 2015-08-19 12:16:30 +00:00
parent 5d3813ec5f
commit 6d35e05ae3
2 changed files with 97 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
components/fpcunit/guitestrunner.lfm
View File

@ -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

56
components/fpcunit/guitestrunner.pas
View File

@ -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;