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

fpcunit: guitestrunner: scroll to first error after run, patch from Graeme, issue #27613

Browse Source 
git-svn-id: trunk@48152 -
This commit is contained in:
mattias 2015-03-06 16:25:06 +00:00
parent c4f6dcb1fa
commit 95c74adaba
2 changed files with 40 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
components/fpcunit/guitestrunner.lfm
View File

@ -46,7 +46,7 @@ object GUITestRunner: TGUITestRunner
OnShow = GUITestRunnerShow OnShow = GUITestRunnerShow
Position = poScreenCenter Position = poScreenCenter
ShowHint = True ShowHint = True
LCLVersion = '1.3' LCLVersion = '1.5'
object Panel1: TPanel object Panel1: TPanel
Left = 0 Left = 0
Height = 88 Height = 88
@ -71,7 +71,7 @@ object GUITestRunner: TGUITestRunner
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
Left = 7 Left = 7
Height = 30 Height = 30
Top = 47 Top = 49
Width = 561 Width = 561
Anchors = [akTop, akLeft, akRight] Anchors = [akTop, akLeft, akRight]
BorderSpacing.Around = 6 BorderSpacing.Around = 6
@ -81,9 +81,9 @@ object GUITestRunner: TGUITestRunner
AnchorSideLeft.Control = Panel1 AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = Panel1 AnchorSideTop.Control = Panel1
Left = 7 Left = 7
Height = 34 Height = 36
Top = 7 Top = 7
Width = 79 Width = 71
Action = RunAction Action = RunAction
AutoSize = True AutoSize = True
BorderSpacing.Around = 6 BorderSpacing.Around = 6
@ -172,10 +172,10 @@ object GUITestRunner: TGUITestRunner
AnchorSideTop.Control = Panel1 AnchorSideTop.Control = Panel1
AnchorSideRight.Control = Panel1 AnchorSideRight.Control = Panel1
AnchorSideRight.Side = asrBottom AnchorSideRight.Side = asrBottom
Left = 488 Left = 491
Height = 34 Height = 36
Top = 7 Top = 7
Width = 80 Width = 77
Action = ActCloseForm Action = ActCloseForm
Anchors = [akTop, akRight] Anchors = [akTop, akRight]
AutoSize = True AutoSize = True
@ -266,10 +266,10 @@ object GUITestRunner: TGUITestRunner
AnchorSideLeft.Control = BtnRun AnchorSideLeft.Control = BtnRun
AnchorSideLeft.Side = asrBottom AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1 AnchorSideTop.Control = Panel1
Left = 92 Left = 84
Height = 32 Height = 34
Top = 7 Top = 7
Width = 148 Width = 169
Action = ActRunHighlightedTest Action = ActRunHighlightedTest
AutoSize = True AutoSize = True
BorderSpacing.Around = 6 BorderSpacing.Around = 6
@ -367,27 +367,26 @@ object GUITestRunner: TGUITestRunner
TabOrder = 0 TabOrder = 0
object tsTestTree: TTabSheet object tsTestTree: TTabSheet
Caption = 'Testcase tree' Caption = 'Testcase tree'
ClientHeight = 474 ClientHeight = 465
ClientWidth = 565 ClientWidth = 567
object Splitter1: TSplitter object Splitter1: TSplitter
Cursor = crVSplit Cursor = crVSplit
Left = 0 Left = 0
Height = 5 Height = 5
Top = 336 Top = 327
Width = 565 Width = 567
Align = alBottom Align = alBottom
ResizeAnchor = akBottom ResizeAnchor = akBottom
end end
object TestTree: TTreeView object TestTree: TTreeView
Left = 6 Left = 6
Height = 324 Height = 315
Top = 6 Top = 6
Width = 553 Width = 555
Align = alClient Align = alClient
BorderSpacing.Around = 6 BorderSpacing.Around = 6
BackgroundColor = clBtnFace BackgroundColor = clBtnFace
Color = clBtnFace Color = clBtnFace
DefaultItemHeight = 16
Images = TestTreeImageList Images = TestTreeImageList
PopupMenu = PopupMenu3 PopupMenu = PopupMenu3
ReadOnly = True ReadOnly = True
@ -403,8 +402,8 @@ object GUITestRunner: TGUITestRunner
object Memo1: TMemo object Memo1: TMemo
Left = 6 Left = 6
Height = 121 Height = 121
Top = 347 Top = 338
Width = 553 Width = 555
Align = alBottom Align = alBottom
BorderSpacing.Around = 6 BorderSpacing.Around = 6
PopupMenu = PopupMenu2 PopupMenu = PopupMenu2
@ -415,8 +414,8 @@ object GUITestRunner: TGUITestRunner
end end
object tsResultsXML: TTabSheet object tsResultsXML: TTabSheet
Caption = 'Results XML' Caption = 'Results XML'
ClientHeight = 497 ClientHeight = 465
ClientWidth = 565 ClientWidth = 567
inline XMLSynEdit: TSynEdit inline XMLSynEdit: TSynEdit
Left = 6 Left = 6
Height = 451 Height = 451
@ -436,7 +435,7 @@ object GUITestRunner: TGUITestRunner
TabOrder = 0 TabOrder = 0
BookMarkOptions.Xoffset = -18 BookMarkOptions.Xoffset = -18
Gutter.Visible = False Gutter.Visible = False
Gutter.Width = 59 Gutter.Width = 57
Gutter.MouseActions = < Gutter.MouseActions = <
item item
ClickCount = ccAny ClickCount = ccAny
@ -882,7 +881,7 @@ object GUITestRunner: TGUITestRunner
MouseActions = <> MouseActions = <>
end end
object TSynGutterLineNumber object TSynGutterLineNumber
Width = 19 Width = 17
MouseActions = <> MouseActions = <>
MarkupInfo.Background = clBtnFace MarkupInfo.Background = clBtnFace
MarkupInfo.Foreground = clNone MarkupInfo.Foreground = clNone

19
components/fpcunit/guitestrunner.pas
View File

@ -86,6 +86,7 @@ type
tsTestTree: TTabSheet; tsTestTree: TTabSheet;
tsResultsXML: TTabSheet; tsResultsXML: TTabSheet;
XMLSynEdit: TSynEdit; XMLSynEdit: TSynEdit;
FFirstFailure: TTreeNode; // reference to first failed test
procedure ActCheckAllExecute(Sender: TObject); procedure ActCheckAllExecute(Sender: TObject);
procedure ActCheckCurrentSuiteExecute(Sender: TObject); procedure ActCheckCurrentSuiteExecute(Sender: TObject);
procedure ActCloseFormExecute(Sender: TObject); procedure ActCloseFormExecute(Sender: TObject);
@ -271,6 +272,7 @@ end;
procedure TGUITestRunner.RunExecute(Sender: TObject); procedure TGUITestRunner.RunExecute(Sender: TObject);
begin begin
FFirstFailure := nil;
testSuite := GetTestRegistry; testSuite := GetTestRegistry;
TestTree.Selected := TestTree.Items[0]; TestTree.Selected := TestTree.Items[0];
RunTest(testSuite); RunTest(testSuite);
@ -303,11 +305,13 @@ end;
procedure TGUITestRunner.ActRunHighlightedTestExecute(Sender: TObject); procedure TGUITestRunner.ActRunHighlightedTestExecute(Sender: TObject);
begin begin
FFirstFailure := nil;
if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then
begin begin
testSuite := TTest(TestTree.Selected.Data); testSuite := TTest(TestTree.Selected.Data);
end; end;
RunTest(testSuite); RunTest(testSuite);
TestTree.MakeSelectionVisible;
end; end;
procedure TGUITestRunner.ActUncheckAllExecute(Sender: TObject); procedure TGUITestRunner.ActUncheckAllExecute(Sender: TObject);
@ -665,6 +669,8 @@ begin
if not(AFailure.IsIgnoredTest) then if not(AFailure.IsIgnoredTest) then
begin begin
// Genuine failure // Genuine failure
if not Assigned(FFirstFailure) then
FFirstFailure := FailureNode;
node.Message := AFailure.ExceptionMessage; node.Message := AFailure.ExceptionMessage;
node.ImageIndex := imgWarningSign; node.ImageIndex := imgWarningSign;
node.SelectedIndex := imgWarningSign; node.SelectedIndex := imgWarningSign;
@ -672,6 +678,10 @@ begin
Format(rsException, [AFailure.ExceptionClassName])) as TMessageTreeNode; Format(rsException, [AFailure.ExceptionClassName])) as TMessageTreeNode;
node.ImageIndex := imgWarningSign; node.ImageIndex := imgWarningSign;
node.SelectedIndex := imgWarningSign; node.SelectedIndex := imgWarningSign;
node := TestTree.Items.AddChild(FailureNode,
Format('at line %d in <%s>', [AFailure.LineNumber, AFailure.UnitName])) as TMessageTreeNode;
node.ImageIndex := imgWarningSign;
node.SelectedIndex := imgWarningSign;
PaintNodeFailure(FailureNode); PaintNodeFailure(FailureNode);
end end
else else
@ -706,6 +716,8 @@ begin
ErrorNode := FindNode(ATest); ErrorNode := FindNode(ATest);
if Assigned(ErrorNode) then if Assigned(ErrorNode) then
begin begin
if not Assigned(FFirstFailure) then
FFirstFailure := ErrorNode;
MessageNode := TestTree.Items.AddChild(ErrorNode, MessageNode := TestTree.Items.AddChild(ErrorNode,
Format(rsExceptionMes, [FirstLine(AError.ExceptionMessage)])) Format(rsExceptionMes, [FirstLine(AError.ExceptionMessage)]))
as TMessageTreeNode; as TMessageTreeNode;
@ -844,7 +856,12 @@ end;
procedure TGUITestRunner.EndTestSuite(ATestSuite: TTestSuite); procedure TGUITestRunner.EndTestSuite(ATestSuite: TTestSuite);
begin begin
// do nothing // scroll treeview to first failed test
if Assigned(FFirstFailure) then
begin
TestTree.Selected := FFirstFailure;
TestTree.MakeSelectionVisible;
end;
end; end;
procedure TranslateResStrings; procedure TranslateResStrings;