diff --git a/components/fpcunit/guitestrunner.lfm b/components/fpcunit/guitestrunner.lfm index 2e8373f9ee..454ab249b0 100644 --- a/components/fpcunit/guitestrunner.lfm +++ b/components/fpcunit/guitestrunner.lfm @@ -21,15 +21,17 @@ object GUITestRunner: TGUITestRunner } OnCreate = GUITestRunnerCreate OnDestroy = GUITestRunnerDestroy + OnShow = GUITestRunnerShow PixelsPerInch = 95 - HorzScrollBar.Page = 647 - VertScrollBar.Page = 713 + HorzScrollBar.Page = 645 + VertScrollBar.Page = 711 Left = 372 Height = 712 Top = 142 Width = 646 object Panel1: TPanel Align = alTop + BorderSpacing.OnChange = nil ClientHeight = 82 ClientWidth = 646 FullRepaint = False @@ -37,7 +39,17 @@ object GUITestRunner: TGUITestRunner TabStop = True Height = 82 Width = 646 + object Label1: TLabel + BorderSpacing.OnChange = nil + Caption = 'Selected Test Suite:' + ParentColor = True + Left = 160 + Height = 17 + Top = 16 + Width = 176 + end object btnRun: TBitBtn + BorderSpacing.OnChange = nil Caption = '&Run' Glyph.Data = { 191C00002F2A2058504D202A2F0A7374617469632063686172202A2062746E5F @@ -274,6 +286,7 @@ object GUITestRunner: TGUITestRunner Width = 103 end object btnClose: TBitBtn + BorderSpacing.OnChange = nil Caption = '&Exit' Glyph.Data = { B42500002F2A2058504D202A2F0A7374617469632063686172202A2065786974 @@ -586,20 +599,13 @@ object GUITestRunner: TGUITestRunner Top = 15 Width = 96 end - object Label1: TLabel - Caption = 'Selected Test Suite:' - Left = 160 - Height = 17 - Top = 16 - Width = 176 - end object ComboBox1: TComboBox + BorderSpacing.OnChange = nil Items.Strings = ( 'All' ) MaxLength = 0 Style = csDropDownList - TabOrder = 3 Text = 'All' Left = 160 Height = 21 @@ -609,6 +615,7 @@ object GUITestRunner: TGUITestRunner end object Panel2: TPanel Align = alClient + BorderSpacing.OnChange = nil Caption = 'Panel2' ClientHeight = 630 ClientWidth = 646 @@ -621,6 +628,7 @@ object GUITestRunner: TGUITestRunner object PageControl1: TPageControl ActivePage = tsTestTree Align = alClient + BorderSpacing.OnChange = nil TabIndex = 0 TabOrder = 0 Left = 1 @@ -637,8 +645,10 @@ object GUITestRunner: TGUITestRunner object TestTree: TTreeView Align = alTop AutoExpand = True + BorderSpacing.OnChange = nil BackgroundColor = clBtnFace - DefaultItemHeight = 17 + ChangeDelay = 1 + DefaultItemHeight = 16 Images = ImageList1 ParentCtl3D = False ScrollBars = ssAutoBoth @@ -651,6 +661,7 @@ object GUITestRunner: TGUITestRunner end object Panel4: TPanel Align = alTop + BorderSpacing.OnChange = nil ClientHeight = 63 ClientWidth = 644 FullRepaint = False @@ -658,6 +669,7 @@ object GUITestRunner: TGUITestRunner Height = 63 Width = 644 object pbBar: TPaintBox + BorderSpacing.OnChange = nil ParentColor = True OnPaint = pbBarPaint Left = 22 @@ -680,8 +692,9 @@ object GUITestRunner: TGUITestRunner end object Memo1: TMemo Align = alClient + BorderSpacing.OnChange = nil PopupMenu = PopupMenu2 - TabOrder = 3 + TabOrder = 2 Height = 53 Top = 553 Width = 644 @@ -696,6 +709,7 @@ object GUITestRunner: TGUITestRunner Width = 644 object Panel3: TPanel Align = alClient + BorderSpacing.OnChange = nil Caption = 'Panel3' ClientHeight = 606 ClientWidth = 644 @@ -706,6 +720,7 @@ object GUITestRunner: TGUITestRunner Width = 644 object Panel5: TPanel Align = alTop + BorderSpacing.OnChange = nil BorderWidth = 1 ClientHeight = 58 ClientWidth = 642 @@ -717,6 +732,7 @@ object GUITestRunner: TGUITestRunner Width = 642 object SpeedButton1: TSpeedButton Action = actCopy + BorderSpacing.OnChange = nil Flat = True Glyph.Data = { 880D00002F2A2058504D202A2F0A7374617469632063686172202A2065646974 @@ -840,6 +856,7 @@ object GUITestRunner: TGUITestRunner end object SpeedButton2: TSpeedButton Action = actCut + BorderSpacing.OnChange = nil Flat = True Glyph.Data = { CC0500002F2A2058504D202A2F0A7374617469632063686172202A2065646974 @@ -900,6 +917,7 @@ object GUITestRunner: TGUITestRunner Width = 31 end object pbBar1: TPaintBox + BorderSpacing.OnChange = nil ParentColor = True OnPaint = pbBarPaint Left = 110 @@ -910,6 +928,7 @@ object GUITestRunner: TGUITestRunner end object XMLMemo: TMemo Align = alClient + BorderSpacing.OnChange = nil PopupMenu = PopupMenu1 TabOrder = 1 Left = 1 @@ -1739,8 +1758,8 @@ object GUITestRunner: TGUITestRunner end object ActionList1: TActionList Images = ImageList2 - left = 112 - top = 288 + left = 116 + top = 280 object actCopy: TAction Hint = 'Copy results to clipboard' OnExecute = actCopyExecute diff --git a/components/fpcunit/guitestrunner.pas b/components/fpcunit/guitestrunner.pas index a17dbd54ea..257fef2022 100644 --- a/components/fpcunit/guitestrunner.pas +++ b/components/fpcunit/guitestrunner.pas @@ -32,6 +32,8 @@ const type + { TGUITestRunner } + TGUITestRunner = class(TForm, ITestListener) actCopy: TAction; actCut: TAction; @@ -66,6 +68,7 @@ type procedure BtnCloseClick(Sender: TObject); procedure GUITestRunnerCreate(Sender: TObject); procedure GUITestRunnerDestroy(Sender: TObject); + procedure GUITestRunnerShow(Sender: TObject); procedure MenuItem3Click(Sender: TObject); procedure TestTreeSelectionChanged(Sender: TObject); procedure pbBarPaint(Sender: TObject); @@ -80,6 +83,7 @@ type errorCounter: Integer; testsCounter: Integer; barColor: TColor; + testSuite: TTest; protected { IInterface } function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; @@ -131,6 +135,12 @@ begin suiteList.Free; end; +procedure TGUITestRunner.GUITestRunnerShow(Sender: TObject); +begin + if (ParamStr(1) = '--now') or (ParamStr(1) = '-n') then + BtnRunClick(Self); +end; + procedure TGUITestRunner.MenuItem3Click(Sender: TObject); begin Clipboard.AsText := Memo1.Lines.Text; @@ -148,21 +158,25 @@ var begin with (Sender as TPaintBox) do begin - Canvas.Brush.Color := clGray; + Canvas.Brush.Color := clSilver; Canvas.Rectangle(0, 0, Width, Height); - if (FailureCounter = 0) and (ErrorCounter = 0) then - barColor := clGreen; - Canvas.Brush.Color := barColor; - if TestsCounter <> 0 then + if Assigned(TestSuite) then begin - Canvas.Rectangle(0, 0, round(TestsCounter / GetTestRegistry.CountTestCases * Width), Height); - Canvas.Font.Color := clWhite; - msg := 'Runs: ' + IntToStr(TestsCounter); - if ErrorCounter <> 0 then + if (FailureCounter = 0) and (ErrorCounter = 0) and + (TestsCounter = TestSuite.CountTestCases) then + barColor := clGreen; + Canvas.Brush.Color := barColor; + if TestsCounter <> 0 then + begin + Canvas.Rectangle(0, 0, round(TestsCounter / TestSuite.CountTestCases * Width), Height); + Canvas.Font.Color := clWhite; + msg := 'Runs: ' + IntToStr(TestsCounter); + if ErrorCounter <> 0 then msg := msg + ' Number of test errors: ' + IntToStr(ErrorCounter); - if (FailureCounter <> 0) then + if (FailureCounter <> 0) then msg := msg + ' Number of test failures: ' + IntToStr(FailureCounter); - Canvas.Textout(10, 10, msg) + Canvas.Textout(10, 10, msg) + end; end; end; end; @@ -170,8 +184,8 @@ end; procedure TGUITestRunner.btnRunClick(Sender: TObject); var testResult: TTestResult; - testSuite: TTest; begin + barcolor := clGray; TestTree.items.Clear; suiteList.Clear; currentTestNode := nil;