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

19
components/fpcunit/guitestrunner.pas
View File

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