View Issue Details

IDProjectCategoryView StatusLast Update
0027765LazarusOtherpublic2015-04-09 15:58
ReporterSerguei TarassovAssigned ToJuha Manninen 
PrioritynormalSeverityminorReproducibilityalways
Status resolvedResolutionfixed 
Platformx68 64OSWindows, UbuntuOS Versionall
Product Version1.2.6Product Build 
Target VersionFixed in Version 
Summary0027765: FPCUnit: GUI ergonomy improvements
DescriptionHello,

I work with both DUnit and FPCUnit at the same time and would propose some FPCUnit improvements.

- "Run all tests" with Ctrl+R is less intuitive and usable that F9 in DUnit
- Check box states not saved between the runs so I need to do it every time...
- Cannot close form by "Escape" as in DUnit, Alt+F4 or mouse manipulations are required

If you interested these improvements I can modifications and publish patched files (normally, only 2 file concerned)
Steps To ReproduceRun any test under FPCUint GUI
TagsNo tags attached.
Fixed in Revisionr48686
LazTarget-
Widgetset
Attached Files
  • guitestrunner.lfm.patch (3,793 bytes)
    --- /cygdrive/C/lazarus/components/fpcunit/guitestrunner.lfm	2014-05-06 23:52:07.524235000 +0200
    +++ guitestrunner.lfm	2015-04-02 15:32:08.231268800 +0200
    @@ -46,7 +46,7 @@
       OnShow = GUITestRunnerShow
       Position = poScreenCenter
       ShowHint = True
    -  LCLVersion = '1.3'
    +  LCLVersion = '1.2.6.0'
       object Panel1: TPanel
         Left = 0
         Height = 88
    @@ -172,10 +172,10 @@
           AnchorSideTop.Control = Panel1
           AnchorSideRight.Control = Panel1
           AnchorSideRight.Side = asrBottom
    -      Left = 488
    +      Left = 482
           Height = 34
           Top = 7
    -      Width = 80
    +      Width = 86
           Action = ActCloseForm
           Anchors = [akTop, akRight]
           AutoSize = True
    @@ -269,7 +269,7 @@
           Left = 92
           Height = 32
           Top = 7
    -      Width = 148
    +      Width = 174
           Action = ActRunHighlightedTest
           AutoSize = True
           BorderSpacing.Around = 6
    @@ -367,27 +367,26 @@
           TabOrder = 0
           object tsTestTree: TTabSheet
             Caption = 'Testcase tree'
    -        ClientHeight = 474
    +        ClientHeight = 470
             ClientWidth = 565
             object Splitter1: TSplitter
               Cursor = crVSplit
               Left = 0
               Height = 5
    -          Top = 336
    +          Top = 332
               Width = 565
               Align = alBottom
               ResizeAnchor = akBottom
             end
             object TestTree: TTreeView
               Left = 6
    -          Height = 324
    +          Height = 320
               Top = 6
               Width = 553
               Align = alClient
               BorderSpacing.Around = 6
               BackgroundColor = clBtnFace
               Color = clBtnFace
    -          DefaultItemHeight = 16
               Images = TestTreeImageList
               PopupMenu = PopupMenu3
               ReadOnly = True
    @@ -403,7 +402,7 @@
             object Memo1: TMemo
               Left = 6
               Height = 121
    -          Top = 347
    +          Top = 343
               Width = 553
               Align = alBottom
               BorderSpacing.Around = 6
    @@ -436,7 +435,7 @@
               TabOrder = 0
               BookMarkOptions.Xoffset = -18
               Gutter.Visible = False
    -          Gutter.Width = 59
    +          Gutter.Width = 61
               Gutter.MouseActions = <          
                 item
                   ClickCount = ccAny
    @@ -882,7 +881,7 @@
                   MouseActions = <>
                 end
                 object TSynGutterLineNumber
    -              Width = 19
    +              Width = 21
                   MouseActions = <>
                   MarkupInfo.Background = clBtnFace
                   MarkupInfo.Foreground = clNone
    @@ -1850,16 +1849,22 @@
         top = 176
         object RunAction: TAction
           Category = 'Run'
    -      Caption = '  &Run'
    +      Caption = '&Run'
           Hint = 'Run all checked test(s)'
           ImageIndex = 3
           OnExecute = RunExecute
    +      SecondaryShortCuts.Strings = (
    +        'F9'
    +      )
           ShortCut = 16466
         end
         object ActCloseForm: TAction
           Caption = 'Quit'
           Hint = 'Quit Testing'
           OnExecute = ActCloseFormExecute
    +      SecondaryShortCuts.Strings = (
    +        'Esc'
    +      )
           ShortCut = 16451
         end
         object actCopyErrorMsg: TAction
    @@ -1897,6 +1902,7 @@
           ImageIndex = 4
           OnExecute = ActRunHighlightedTestExecute
           OnUpdate = ActRunHighLightedTestUpdate
    +      ShortCut = 119
         end
       end
       object PopupMenu3: TPopupMenu
    @@ -1905,7 +1911,8 @@
         top = 240
         object miRunTest: TMenuItem
           Action = RunAction
    -      Caption = '  &Run all selected (checked) tests'
    +      Caption = '&Run all selected (checked) tests'
    +      ShortCutKey2 = 120
           OnClick = RunExecute
         end
         object MenuItem4: TMenuItem
        end
         object MenuItem4: TMenuItem
    
    guitestrunner.lfm.patch (3,793 bytes)
  • guitestrunner.pas.patch (3,103 bytes)
    --- /cygdrive/C/lazarus/components/fpcunit/guitestrunner.pas	2014-05-06 23:52:07.524235000 +0200
    +++ guitestrunner.pas	2015-04-02 15:32:08.201225600 +0200
    @@ -117,6 +117,8 @@
         testSuite: TTest;
         procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
         function  FindNode(aTest: TTest): TTreeNode;
    +    function GetConfFileName: string;
    +    function MakeTestPath(Node: TTreeNode): string;
         procedure ResetNodeColors;
         procedure PaintNodeError(aNode: TTreeNode);
         procedure PaintNodeFailure(aNode: TTreeNode);
    @@ -125,6 +127,8 @@
         procedure PaintNodeBusy(aNode: TTreeNode);
         procedure MemoLog(LogEntry: string);
         procedure EnableRunActions(AValue: boolean);
    +    procedure RestoreTree;
    +    procedure SaveTree;
       public
         procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
         procedure AddError(ATest: TTest; AError: TTestFailure);
    @@ -169,7 +173,7 @@
       sactCheckAll = 'Check all Tests';
       sactUncheckAll = 'Uncheck all tests';
       sactRunHighlightedTest = 'Run highlighted test';
    -  smiRunTest = '  &Run all selected (checked) tests';
    +  smiRunTest = '&Run all selected (checked) tests';
       smiShowfail= 'Copy message to clipboard';
       smiCopy = '&Copy';
       smiCut = 'C&ut';
    @@ -180,8 +184,10 @@
     {$R *.lfm}
     
     uses
    +  IniFiles,
       xmlwrite
       ;
    +
     const
       // TestTreeImageList indexes:
       imgGreenBall = 0; //success result
    @@ -232,12 +238,59 @@
       XMLSynEdit.Lines.Clear;
     end;
     
    +function TGUITestRunner.GetConfFileName: string;
    +begin
    +  Result := ParamStr(0) + '.fpcunit.ini';
    +end;
    +
    +function TGUITestRunner.MakeTestPath(Node: TTreeNode): string;
    +begin
    +  Result := '';
    +  while Node <> nil do
    +  begin
    +    Result := Node.Text + '_' + Result;
    +    Node := Node.Parent;
    +  end;
    +end;
    +
    +procedure TGUITestRunner.SaveTree;
    +var
    +  Conf: TIniFile;
    +  i: integer;
    +begin
    +  Conf := TIniFile.Create(GetConfFileName);
    +  try
    +    for i := 0 to TestTree.Items.Count - 1 do
    +      Conf.WriteBool('Tests', MakeTestPath(TestTree.Items[i]), TestTree.Items[i].StateIndex = Ord(tsChecked));
    +  finally
    +    Conf.Free;
    +  end;
    +end;
    +
    +procedure TGUITestRunner.RestoreTree;
    +var
    +  Conf: TIniFile;
    +  i: integer;
    +begin
    +  Conf := TIniFile.Create(GetConfFileName);
    +  try
    +    for i := 0 to TestTree.Items.Count - 1 do
    +      if Conf.ReadBool('Tests', MakeTestPath(TestTree.Items[i]), true) then
    +        TestTree.Items[i].StateIndex := Ord(tsChecked)
    +      else
    +        TestTree.Items[i].StateIndex := Ord(tsUnChecked);
    +  finally
    +    Conf.Free;
    +  end;
    +end;
    +
     procedure TGUITestRunner.GUITestRunnerCreate(Sender: TObject);
     begin
       barColor := clGreen;
       TestTree.Items.Clear;
       BuildTree(TestTree.Items.AddObject(nil, rsAllTests, GetTestRegistry),
         GetTestRegistry);
    +  RestoreTree;
       PageControl1.ActivePage := tsTestTree;
       //
       BtnRun.Caption:= sbtnRun;
    @@ -780,6 +833,7 @@
       m: TMemoryStream;
     
     begin
    +  SaveTree;
       barcolor := clGreen;
       ResetNodeColors;
       failureCounter := 0;
    ResetNodeColors;
       failureCounter := 0;
    
    guitestrunner.pas.patch (3,103 bytes)
  • guitestrunner.pas (26,511 bytes)
    {
      Copyright (C) 2004-2015 Dean Zobec, contributors
    
      This library is free software; you can redistribute it and/or modify it
      under the terms of the GNU Library General Public License as published by
      the Free Software Foundation; either version 2 of the License, or (at your
      option) any later version.
    
      This program is distributed in the hope that it will be useful, but WITHOUT
      ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
      FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
      for more details.
    
      You should have received a copy of the GNU Library General Public License
      along with this library; if not, write to the Free Software Foundation,
      Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
      
      
      Modified:
        Graeme Geldenhuys <graemeg@gmail.com>
        Darius Blaszijk <dhkblaszyk@zeelandnet.nl>
        Reinier Olislagers <reinierolislagers@gmail.com>
        Serguei Tarassov <serge@arbinada.com>
    }
    
    unit GuiTestRunner;
    
    {$mode objfpc}{$H+}
    
    interface
    
    uses
      Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
      ExtCtrls, Buttons, ComCtrls, ActnList, Menus, Clipbrd, StdCtrls,
      testdecorator, xmltestreport,
      fpcunit, testregistry, SynEdit, SynHighlighterXML, gettext, Translations,
      inifiles;
    
    type
    
      { TGUITestRunner }
    
      TGUITestRunner = class(TForm, ITestListener)
        actCopy: TAction;
        actCut: TAction;
        ActCloseForm: TAction;
        actCopyErrorMsg: TAction;
        ActCheckCurrentSuite: TAction;
        ActCheckAll: TAction;
        ActRunHighlightedTest: TAction;
        ActUncheckAll: TAction;
        ActUncheckCurrentSuite: TAction;
        btnRunHighlighted: TBitBtn;
        ilNodeStates: TImageList;
        Memo1: TMemo;
        MenuItem4: TMenuItem;
        MenuItem5: TMenuItem;
        MenuItem6: TMenuItem;
        MenuItem7: TMenuItem;
        MenuItem8: TMenuItem;
        miRunTest: TMenuItem;
        miShowfailureMsg: TMenuItem;
        pbBar: TPaintBox;
        PopupMenu3: TPopupMenu;
        RunAction: TAction;
        ActionList1: TActionList;
        ActionList2: TActionList;
        BtnRun: TBitBtn;
        BtnClose: TBitBtn;
        TestTreeImageList: TImageList;
        ResultsXMLImageList: TImageList;
        MenuItem1: TMenuItem;
        MenuItem2: TMenuItem;
        MenuItem3: TMenuItem;
        PopupMenu1: TPopupMenu;
        PopupMenu2: TPopupMenu;
        SaveDialog: TSaveDialog;
        Splitter1: TSplitter;
        TestTree: TTreeView;
        SynXMLSyn1: TSynXMLSyn;
        PageControl1: TPageControl;
        Panel1: TPanel;
        Panel2: TPanel;
        XMLToolBar: TToolBar;
        CopyXMLToolButton: TToolButton;
        CutXMLToolButton: TToolButton;
        SaveAsToolButton: TToolButton;
        tsTestTree: TTabSheet;
        tsResultsXML: TTabSheet;
        XMLSynEdit: TSynEdit;
        procedure ActCheckAllExecute(Sender: TObject);
        procedure ActCheckCurrentSuiteExecute(Sender: TObject);
        procedure ActCloseFormExecute(Sender: TObject);
        procedure ActRunHighlightedTestExecute(Sender: TObject);
        procedure ActUncheckAllExecute(Sender: TObject);
        procedure ActRunHighLightedTestUpdate(Sender: TObject);
        procedure ActUncheckCurrentSuiteExecute(Sender: TObject);
        procedure FormDestroy(Sender: TObject);
        procedure RunExecute(Sender: TObject);
        procedure GUITestRunnerCreate(Sender: TObject);
        procedure GUITestRunnerShow(Sender: TObject);
        procedure MenuItem3Click(Sender: TObject);
        procedure SaveAsToolButtonClick(Sender: TObject);
        procedure TestTreeCreateNodeClass(Sender: TCustomTreeView;
          var NodeClass: TTreeNodeClass);
        procedure TestTreeMouseDown(Sender: TOBject; Button: TMouseButton;
          Shift: TShiftState; X, Y: Integer);
        procedure TestTreeSelectionChanged(Sender: TObject);
        procedure actCopyErrorMsgExecute(Sender: TObject);
        procedure actCopyErrorMsgUpdate(Sender: TObject);
        procedure pbBarPaint(Sender: TObject);
        procedure actCopyExecute(Sender: TObject);
        procedure actCutExecute(Sender: TObject);
      private
        failureCounter: Integer;
        errorCounter: Integer;
        testsCounter: Integer;
        skipsCounter: Integer;
        barColor: TColor;
        testSuite: TTest;
        FFirstFailure: TTreeNode; // reference to first failed test
        FINI: TINIFile;
        procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
        function  FindNode(aTest: TTest): TTreeNode;
        function MakeTestPath(Node: TTreeNode): string;
        procedure ResetNodeColors;
        procedure PaintNodeError(aNode: TTreeNode);
        procedure PaintNodeFailure(aNode: TTreeNode);
        procedure PaintNodeIgnore(aNode: TTreeNode);
        procedure PaintNodeNonFailed(aNode: TTreeNode);
        procedure PaintNodeBusy(aNode: TTreeNode);
        procedure MemoLog(LogEntry: string);
        procedure EnableRunActions(AValue: boolean);
        procedure RestoreTree;
        procedure SaveTree;
      public
        procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
        procedure AddError(ATest: TTest; AError: TTestFailure);
        procedure StartTest(ATest: TTest);
        procedure EndTest(ATest: TTest);
        procedure RunTest(ATest: TTest);
        procedure StartTestSuite(ATestSuite: TTestSuite);
        procedure EndTestSuite(ATestSuite: TTestSuite);
      end;
    
    var
      TestRunner: TGUITestRunner;
    
    resourcestring
      rsAllTests = 'All Tests';
      rsRun = 'Run ';
      rsRuns = 'Runs: %s/%s';
      rsErrors = '%s    Errors: %s';
      rsFailures = '%s     Failures: %s';
      rsMessage = 'Message: %s';
      rsException = 'Exception: %s';
      rsExceptionMes = 'Exception message: %s';
      rsExceptionCla = 'Exception class: %s';
      rsUnitName = 'Unit name: %s';
      rsMethodName = 'Method name: %s';
      rsLineNumber = 'Line number: %s';
      rsRunning = 'Running %s';
      rsNumberOfExec = 'Number of executed tests: %s  Time elapsed: %s';
      // Visual components captions
      sfrmGUITest = 'FPCUnit - run unit test';
      sbtnRun = 'Run';
      sbtnRunH = 'Run highlighted test';
      sbtnClose = 'Close';
      stshTree = 'Testcase tree';
      stshResults = 'Results XML';
      sactRunAction = '&Run';
      sactRunActionH = 'Run all checked test(s)';
      sactCloseForm = 'Quit';
      sactCloseFormH = 'Quit Testting';
      sactCheckCurrentSuite = 'Check the Current Suite';
      sactUncheckCurrentSuite = 'Uncheck the Current Suite';
      sactCheckAll = 'Check all Tests';
      sactUncheckAll = 'Uncheck all tests';
      sactRunHighlightedTest = 'Run highlighted test';
      smiRunTest = '&Run all selected (checked) tests';
      smiShowfail= 'Copy message to clipboard';
      smiCopy = '&Copy';
      smiCut = 'C&ut';
      smiCopyClipbrd = 'Copy to clipboard';
    
    implementation
    
    {$R *.lfm}
    
    uses
      xmlwrite
      ;
    
    const
      // TestTreeImageList indexes:
      imgGreenBall = 0; //success result
      imgRedBall = 2;
      imgPurpleBall = 3;
      imgWarningSign = 4; //failure result
      imgInfoSign = 11; //error result
      imgGrayBall = 12; //default
      imgBlueBall = 13; //busy
    
    type
    
      TTreeNodeState=(tsUnChecked, tsChecked);
    
    type
    
      { TMessageTreeNode }
    
      TMessageTreeNode = class(TTreeNode)
      private
        FMessage: string;
      public
        property Message: string read FMessage write FMessage;
      end;
    
    function FirstLine(const s: string): string;
    var
      NewLinePos: integer;
    begin
      NewLinePos := pos(LineEnding, s);
      if NewLinePos > 0 then
        Result := copy(s, 1, NewLinePos-1)
      else
        Result := s;
    end;
    
    { TGUITestRunner }
    
    procedure TGUITestRunner.actCopyExecute(Sender: TObject);
    begin
      Clipboard.AsText := XMLSynEdit.Lines.Text;
    end;
    
    
    procedure TGUITestRunner.actCutExecute(Sender: TObject);
    begin
      Clipboard.AsText := XMLSynEdit.Lines.Text;
      XMLSynEdit.Lines.Clear;
    end;
    
    function TGUITestRunner.MakeTestPath(Node: TTreeNode): string;
    begin
      Result := '';
      while Node <> nil do
      begin
        Result := Node.Text + '_' + Result;
        Node := Node.Parent;
      end;
    end;
    
    procedure TGUITestRunner.SaveTree;
    var
      i: integer;
    begin
      for i := 0 to TestTree.Items.Count - 1 do
        FINI.WriteBool('Tests', MakeTestPath(TestTree.Items[i]), TestTree.Items[i].StateIndex = Ord(tsChecked));
    end;
    
    procedure TGUITestRunner.RestoreTree;
    var
      i: integer;
    begin
      for i := 0 to TestTree.Items.Count - 1 do
        if FINI.ReadBool('Tests', MakeTestPath(TestTree.Items[i]), true) then
          TestTree.Items[i].StateIndex := Ord(tsChecked)
        else
          TestTree.Items[i].StateIndex := Ord(tsUnChecked);
    end;
    
    procedure TGUITestRunner.GUITestRunnerCreate(Sender: TObject);
    begin
      barColor := clGreen;
      TestTree.Items.Clear;
      BuildTree(TestTree.Items.AddObject(nil, rsAllTests, GetTestRegistry),
        GetTestRegistry);
      RestoreTree;
      PageControl1.ActivePage := tsTestTree;
      //
      BtnRun.Caption:= sbtnRun;
      btnRunHighlighted.Caption := sbtnRunH;
      BtnClose.Caption:= sbtnClose;
      tsTestTree.Caption:= stshTree;
      tsResultsXML.Caption:= stshResults;
      //
      Caption:= sfrmGUITest;
      RunAction.Caption:= sactRunAction;
      RunAction.Hint:= sactRunActionH;
      ActCloseForm.Caption:= sactCloseForm;
      ActCloseForm.Hint:= sactCloseFormH;
      ActCheckCurrentSuite.Caption:= sactCheckCurrentSuite;
      ActUncheckCurrentSuite.Caption:= sactUncheckCurrentSuite;
      ActCheckAll.Caption:= sactCheckAll;
      ActUncheckAll.Caption:= sactUncheckAll;
      ActRunHighlightedTest.Caption:= sactRunHighlightedTest;
      miRunTest.Caption:= smiRunTest;
      miShowfailureMsg.Caption:= smiShowfail;
      MenuItem1.Caption:= smiCopy;
      MenuItem2.Caption:= smiCut;
      MenuItem3.Caption:= smiCopyClipbrd;
      // Select the first entry in the tree in order to immediately activate the 
      // Run All tests button:
      if TestTree.Items.Count>0 then begin
        TestTree.Items.SelectOnlyThis(TestTree.Items[0]);
        TestTree.Items[0].Expand(False);
      end;
    
      FINI := TINIFile.Create(ExtractFileNameOnly(ParamStr(0)) + '.fpcunit.ini'); // Prevent ini file names conflict if tests are embedded in application
    end;
    
    procedure TGUITestRunner.RunExecute(Sender: TObject);
    begin
      FFirstFailure := nil;
      testSuite := GetTestRegistry;
      TestTree.Selected := TestTree.Items[0];
      RunTest(testSuite);
    end;
    
    procedure TGUITestRunner.ActCloseFormExecute(Sender: TObject);
    begin
      Close;
    end;
    
    procedure TGUITestRunner.ActCheckAllExecute(Sender: TObject);
    var
      i: integer;
    begin
      for i := 0 to TestTree.Items.Count -1 do
        TestTree.Items[i].StateIndex := ord(tsChecked);
    end;
    
    procedure TGUITestRunner.ActCheckCurrentSuiteExecute(Sender: TObject);
    var
      i: integer;
    begin
      if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then
      begin
        TestTree.Selected.StateIndex := ord(tsChecked);
        for i := 0 to TestTree.Selected.Count - 1 do
          TestTree.Selected.Items[i].StateIndex := ord(tsChecked);
      end;
    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);
    var
      i: integer;
    begin
      for i := 0 to TestTree.Items.Count -1 do
        TestTree.Items[i].StateIndex := ord(tsUnChecked);
    end;
    
    
    procedure TGUITestRunner.ActRunHighLightedTestUpdate(Sender: TObject);
    begin
      (Sender as TAction).Enabled := ((TestTree.Selected <> nil)
        and (TestTree.Selected.Data <> nil));
    end;
    
    procedure TGUITestRunner.ActUncheckCurrentSuiteExecute(Sender: TObject);
    var
      i: integer;
    begin
      if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then
      begin
        TestTree.Selected.StateIndex := ord(tsUnchecked);
        for i := 0 to TestTree.Selected.Count - 1 do
          TestTree.Selected.Items[i].StateIndex := ord(tsUnChecked);
      end;
    end;
    
    procedure TGUITestRunner.FormDestroy(Sender: TObject);
    begin
      // store window position and size
      FINI.WriteInteger('WindowState', 'Left', Left);
      FINI.WriteInteger('WindowState', 'Top', Top);
      FINI.WriteInteger('WindowState', 'Width', Width);
      FINI.WriteInteger('WindowState', 'Height', Height);
      FINI.Free;
    end;
    
    procedure TGUITestRunner.GUITestRunnerShow(Sender: TObject);
    begin
      if (ParamStrUTF8(1) = '--now') or (ParamStrUTF8(1) = '-n') then
        RunExecute(Self);
      // restore last used position and size
      Left := FINI.ReadInteger('WindowState', 'Left', Left);
      Top := FINI.ReadInteger('WindowState', 'Top', Top);
      Width := FINI.ReadInteger('WindowState', 'Width', Width);
      Height := FINI.ReadInteger('WindowState', 'Height', Height);
    end;
    
    procedure TGUITestRunner.MenuItem3Click(Sender: TObject);
    begin
      Clipboard.AsText := Memo1.Lines.Text;
    end;
    
    procedure TGUITestRunner.SaveAsToolButtonClick(Sender: TObject);
    begin
      if SaveDialog.Execute then
        XMLSynEdit.Lines.SaveToFile(SaveDialog.FileName);
    end;
    
    procedure TGUITestRunner.TestTreeCreateNodeClass(Sender: TCustomTreeView;
      var NodeClass: TTreeNodeClass);
    begin
      NodeClass := TMessageTreeNode;
    end;
    
    procedure TGUITestRunner.TestTreeMouseDown(Sender: TOBject;
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    
      procedure ChangeCheck(aNode: TTreeNode; aCheck: TTreeNodeState);
      var
        i: integer;
        n: TTreeNode;
      begin
        if Assigned(aNode) then
        begin
          aNode.StateIndex := ord(aCheck);
          if (TTest(aNode.Data) is TTestSuite) then
            for i := 0 to aNode.Count - 1 do
            begin
              n := aNode.Items[i];
              ChangeCheck(n, aCheck);
            end;
        end;
      end;
    
    var
      ht: THitTests;
      lNode: TTreeNode;
    begin
      ht := (Sender as TTreeview).GetHitTestInfoAt(X, Y);
      if htOnStateIcon in ht then
      begin
        lNode := (Sender as TTreeview).GetNodeAt(X, Y);
        case lNode.StateIndex of
            0: ChangeCheck(lNode, tsChecked);
            1: ChangeCheck(lNode, tsUnChecked);
          end;
       end;
    end;
    
    
    procedure TGUITestRunner.TestTreeSelectionChanged(Sender: TObject);
    begin
      if ((Sender as TTreeView).Selected <> nil) and
        Assigned((Sender as TTreeview).Selected.Data)  then
      begin
        btnRunHighlighted.Visible := true;
        btnRunHighlighted.Caption := rsRun + (Sender as TTreeview).Selected.Text;
      end
      else
        begin
          btnRunHighlighted.Visible := false;
          btnRunHighlighted.Caption := '';
        end;
    end;
    
    
    procedure TGUITestRunner.actCopyErrorMsgExecute(Sender: TObject);
    begin
      ClipBoard.AsText := (TestTree.Selected as TMessageTreeNode).Message;
    end;
    
    
    procedure TGUITestRunner.actCopyErrorMsgUpdate(Sender: TObject);
    begin
      (Sender as TAction).Enabled := Assigned(TestTree.selected) and
        (Copy(TestTree.Selected.Text, 1, 9) = 'Message: ');
    end;
    
    
    procedure TGUITestRunner.pbBarPaint(Sender: TObject);
    var
      msg: string;
      alltests: integer;
      OldStyle: TBrushStyle;
    begin
      with (Sender as TPaintBox) do
      begin
        Canvas.Lock;
        Canvas.Brush.Color := clSilver;
        Canvas.Rectangle(0, 0, Width, Height);
        Canvas.Font.Color := clWhite;
        if Assigned(TestSuite) then
        begin
          alltests := TestSuite.CountTestCases;
          if alltests - skipsCounter <> 0 then
          begin
            if FailureCounter + ErrorCounter = 0 then
              barColor := clGreen;
            Canvas.Brush.Color := barColor;
            Canvas.Rectangle(0, 0, round(TestsCounter / (alltests - skipsCounter) * Width), Height);
            msg := Format(rsRuns, [IntToStr(TestsCounter), IntToStr(alltests -
              skipsCounter)]);
            msg := Format(rsErrors, [msg, IntToStr(ErrorCounter)]);
            msg := Format(rsFailures, [msg, IntToStr(FailureCounter)]);
            OldStyle := Canvas.Brush.Style;
            Canvas.Brush.Style := bsClear;
            Canvas.Textout(10, 10,  msg);
            Canvas.Brush.Style := OldStyle;
          end;
        end;
        Canvas.UnLock;
      end;
    end;
    
    
    procedure TGUITestRunner.BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
    var
      node: TTreeNode;
      i: integer;
    begin
      rootNode.StateIndex := Ord(tsChecked);
      for i := 0 to ASuite.Tests.Count - 1 do
      begin
        node := TestTree.Items.AddChildObject(rootNode, ASuite.Test[i].TestName, ASuite.Test[i]);
        if ASuite.Test[i] is TTestSuite then
          BuildTree(Node, TTestSuite(ASuite.Test[i]))
        else
          if TObject(ASuite.Test[i]).InheritsFrom(TTestDecorator) then
            BuildTree(Node, TTestSuite(TTestDecorator(ASuite.Test[i]).Test));
        node.ImageIndex := imgGrayBall;
        node.SelectedIndex := imgGrayBall;
        node.StateIndex := ord(tsChecked);
      end;
      ResetNodeColors;
    end;
    
    
    function TGUITestRunner.FindNode(aTest: TTest): TTreeNode;
    var
      i: integer;
    begin
      Result := nil;
      for i := 0 to TestTree.Items.Count -1 do
        if (TTest(TestTree.Items[i].data) = aTest) then
        begin
          Result :=  TestTree.Items[i];
          Exit;
        end;
    end;
    
    
    procedure TGUITestRunner.ResetNodeColors;
    var
      i: integer;
    begin
      for i := 0 to TestTree.Items.Count - 1 do
      begin
        TestTree.Items[i].ImageIndex := imgGrayBall;
        TestTree.Items[i].SelectedIndex := imgGrayBall;
      end;
    end;
    
    
    procedure TGUITestRunner.PaintNodeError(aNode: TTreeNode);
    begin
      while Assigned(aNode) do
      begin
        aNode.ImageIndex := imgRedBall;
        aNode.SelectedIndex := imgRedBall;
        if aNode.AbsoluteIndex<>0 then begin
          aNode.Expand(True);
        end;
        aNode := aNode.Parent;
        if Assigned(aNode) and
          ((aNode.ImageIndex in [imgGreenBall, imgPurpleBall, imgGrayBall, imgBlueBall]) or
          (ANode.ImageIndex = -1)) then
          PaintNodeError(aNode);
      end;
    end;
    
    
    procedure TGUITestRunner.PaintNodeFailure(aNode: TTreeNode);
    begin
      while Assigned(aNode) do
      begin
        if ((aNode.ImageIndex in [imgGreenBall, imgGrayBall, imgBlueBall]) or
          (ANode.ImageIndex = -1)) then
        begin
          aNode.ImageIndex := imgPurpleBall;
          aNode.SelectedIndex := imgPurpleBall;
          if aNode.AbsoluteIndex<>0 then begin
            aNode.Expand(true);
          end;
        end;
        aNode := aNode.Parent;
        if Assigned(aNode) and ((aNode.ImageIndex in [imgGreenBall, imgGrayBall, imgBlueBall]) or
          (ANode.ImageIndex = -1)) then
          PaintNodeFailure(aNode);
      end;
    end;
    
    procedure TGUITestRunner.PaintNodeIgnore(aNode: TTreeNode);
    // Test results with Ignore
    var
      noFailedSibling: boolean;
      i: integer;
    begin
      if Assigned(aNode) then
      begin
        if ((aNode.ImageIndex in [imgGrayBall, imgBlueBall]) or
          (ANode.ImageIndex = -1)) then
        begin
          aNode.ImageIndex := imgGreenBall;
          aNode.SelectedIndex := imgGreenBall;
        end;
      end;
      if Assigned(aNode.Parent) then
        if aNode.Index = aNode.Parent.Count -1 then
        begin
        aNode := aNode.Parent;
        noFailedSibling := true;
        for i := 0 to aNode.Count -2 do
        begin
          if aNode.Items[i].ImageIndex <> imgGreenBall then
            noFailedSibling := false;;
        end;
        if (aNode.ImageIndex = imgBlueBall) and
          noFailedSibling then
          PaintNodeIgnore(aNode);
        end;
    end;
    
    
    procedure TGUITestRunner.PaintNodeNonFailed(aNode: TTreeNode);
    var
      noFailedSibling: boolean;
      i: integer;
    begin
      if Assigned(aNode) then
      begin
        if ((aNode.ImageIndex in [imgGrayBall, imgBlueBall]) or
          (ANode.ImageIndex = -1)) then
        begin
          aNode.ImageIndex := imgGreenBall;
          aNode.SelectedIndex := imgGreenBall;
        end;
      end;
      if Assigned(aNode.Parent) then
        if aNode.Index = aNode.Parent.Count -1 then
        begin
        aNode := aNode.Parent;
        noFailedSibling := true;
        for i := 0 to aNode.Count -2 do
        begin
          if aNode.Items[i].ImageIndex <> imgGreenBall then
            noFailedSibling := false;;
        end;
        if (aNode.ImageIndex = imgBlueBall) and
          noFailedSibling then
          PaintNodeNonFailed(aNode);
        end;
    end;
    
    
    procedure TGUITestRunner.PaintNodeBusy(aNode: TTreeNode);
    var
      BusySibling: boolean;
      i: integer;
    begin
      if Assigned(aNode) then
      begin
        aNode.ImageIndex := imgBlueBall;
        aNode.SelectedIndex := imgBlueBall;
      end;
      if Assigned(aNode.Parent) then
      begin
        if aNode.Index = aNode.Parent.Count -1 then
        begin
          aNode := aNode.Parent;
          BusySibling := true;
          for i := 0 to aNode.Count -2 do
          begin
            if aNode.Items[i].ImageIndex <> imgGreenBall then
              BusySibling := false;;
          end;
          if (aNode.ImageIndex = imgBlueBall) and
            BusySibling then
            PaintNodeBusy(aNode);
        end;
      end;
    end;
    
    
    procedure TGUITestRunner.MemoLog(LogEntry: string);
    begin
      Memo1.Lines.Add(TimeToStr(Now) + ' - ' + LogEntry);
    end;
    
    procedure TGUITestRunner.EnableRunActions(AValue: boolean);
    begin
      ActRunHighlightedTest.Enabled := AValue;
      RunAction.Enabled := AValue;
    end;
    
    procedure TGUITestRunner.AddFailure(ATest: TTest; AFailure: TTestFailure);
    var
      FailureNode: TTreeNode;
      node: TMessageTreeNode;
    begin
      FailureNode := FindNode(ATest);
      if Assigned(FailureNode) then
      begin
        node := TestTree.Items.AddChild(FailureNode,
          Format(rsMessage, [FirstLine(AFailure.ExceptionMessage)]))
          as TMessageTreeNode;
        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;
          node := TestTree.Items.AddChild(FailureNode,
            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
        begin
          // Although reported as a failure, the test was set up
          // to be ignored so it is actually a success of sorts
          node.Message := AFailure.ExceptionMessage;
          node.ImageIndex := imgGreenBall;
          node.SelectedIndex := imgGreenBall;
          node := TestTree.Items.AddChild(FailureNode,
            Format(rsException, [AFailure.ExceptionClassName])) as TMessageTreeNode;
          node.ImageIndex := imgGreenBall;
          node.SelectedIndex := imgGreenBall;
          PaintNodeIgnore(FailureNode);
        end;
      end;
    
      if not(AFailure.IsIgnoredTest) then
      begin
        Inc(failureCounter);
        if errorCounter = 0 then
          barColor := clFuchsia;
      end;
    end;
    
    
    procedure TGUITestRunner.AddError(ATest: TTest; AError: TTestFailure);
    var
      ErrorNode, node: TTreeNode;
      MessageNode: TMessageTreeNode;
    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;
        MessageNode.Message := AError.ExceptionMessage;
        MessageNode.ImageIndex := imgWarningSign;
        MessageNode.SelectedIndex := imgWarningSign;
        node := TestTree.Items.AddChild(ErrorNode, Format(rsExceptionCla, [
          AError.ExceptionClassName]));
        node.ImageIndex := imgWarningSign;
        node.SelectedIndex := imgWarningSign;
        if (AError.SourceUnitName <> '') and
          (AError.FailedMethodName <> '')
        then
        begin
          node := TestTree.Items.AddChild(ErrorNode, Format(rsUnitName, [
            AError.SourceUnitName]));
          node.ImageIndex := imgInfoSign;
          node.SelectedIndex := imgInfoSign;
          node := TestTree.Items.AddChild(ErrorNode, Format(rsMethodName, [
            AError.FailedMethodName]));
          node.ImageIndex := imgInfoSign;
          node.SelectedIndex := imgInfoSign;
          node := TestTree.Items.AddChild(ErrorNode, Format(rsLineNumber, [IntToStr(
            AError.LineNumber)]));
          node.ImageIndex := imgInfoSign;
          node.SelectedIndex := imgInfoSign;
        end;
        PaintNodeError(ErrorNode);
      end;
      Inc(errorCounter);
      barColor := clRed;
    end;
    
    
    procedure TGUITestRunner.StartTest(ATest: TTest);
    var
      Node: TTreeNode;
    begin
      TestTree.BeginUpdate;
      Node := FindNode(ATest);
      Node.DeleteChildren;
      PaintNodeBusy(Node);
      if Node.Level=1 then begin
        Node.MakeVisible;
      end;
      if assigned(Node.Parent) and (Node.Parent.Level=1) then begin
        Node.Parent.MakeVisible;
      end;
      Application.ProcessMessages;
      TestTree.EndUpdate;
    end;
    
    
    procedure TGUITestRunner.EndTest(ATest: TTest);
    var
      Node: TTreeNode;
    begin
      TestTree.BeginUpdate;
      Inc(testsCounter);
      Node := FindNode(ATest);
      PaintNodeNonFailed(Node);
      pbbar.Refresh;
      Application.ProcessMessages;
      TestTree.EndUpdate;
    end;
    
    procedure TGUITestRunner.RunTest(ATest: TTest);
      procedure SkipUncheckedTests(aResult: TTestResult; aNode: TTreeNode);
      var
        i: integer;
      begin
        if (aNode.StateIndex = ord(tsUnChecked)) and (TTest(aNode.Data) is TTestCase) then
          aResult.AddToSkipList(TTest(aNode.Data) as TTestCase);
        for i := 0 to aNode.Count - 1 do
          SkipUncheckedTests(aResult, aNode.Items[i]);
      end;
    
    var
      TestResult:TTestResult;
      w: TXMLResultsWriter;
      m: TMemoryStream;
    
    begin
      SaveTree;
      barcolor := clGreen;
      ResetNodeColors;
      failureCounter := 0;
      errorCounter := 0;
      testsCounter := 0;
      skipsCounter := 0;
      EnableRunActions(false);
      TestResult := TTestResult.Create;
      try
        SkipUncheckedTests(TestResult, TestTree.Selected);
        skipsCounter := TestResult.NumberOfSkippedTests;
        TestResult.AddListener(self);
        pbBar.Invalidate;
        w := TXMLResultsWriter.Create(nil);
        try
          w.FileName := 'null'; // prevents output to the console
          TestResult.AddListener(w);
    
          MemoLog(Format(rsRunning, [TestTree.Selected.Text]));
          aTest.Run(TestResult);
          MemoLog(Format(rsNumberOfExec, [IntToStr(TestResult.RunTests),
            FormatDateTime('hh:nn:ss.zzz', Now - TestResult.StartingTime)]));
    
          w.WriteResult(TestResult);
          m := TMemoryStream.Create;
          try
            try
              WriteXMLFile(w.Document, m);
              m.Position := 0;
              XMLSynEdit.Lines.LoadFromStream(m);
            except
              on E: Exception do
                XMLSynEdit.Lines.Text:='WriteXMLFile exception: '+E.ClassName+'/'+E.Message;
            end;
          finally
            m.Free;
          end;
          pbBar.Invalidate;
        finally
          w.Free;
        end;
       finally
        EnableRunActions(true);
    
        TestResult.Free;
      end;
    end;
    
    procedure TGUITestRunner.StartTestSuite(ATestSuite: TTestSuite);
    begin
      // do nothing
    end;
    
    procedure TGUITestRunner.EndTestSuite(ATestSuite: TTestSuite);
    begin
      // scroll treeview to first failed test
      if Assigned(FFirstFailure) then
      begin
        TestTree.Selected := FFirstFailure;
        TestTree.MakeSelectionVisible;
      end;
    end;
    
    procedure TranslateResStrings;
    var
      Lang, FallbackLang, S: String;
    
    begin
      GetLanguageIDs(Lang,FallbackLang); // in unit gettext
      S:=AppendPathDelim(AppendPathDelim(ExtractFileDir(ParamStr(0))) + 'languages');
      if FallbackLang = 'pt' then
         Lang := 'pb';
      TranslateUnitResourceStrings('guitestrunner',S+'guitestrunner.%s.po', Lang,FallbackLang);
    end;
    
    initialization
      TranslateResStrings;
    
    end.
    
    
    guitestrunner.pas (26,511 bytes)
  • guitestrunner.lfm (109,656 bytes)
  • guitestrunner.pas.48679.patch (3,317 bytes)
    Index: /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas
    ===================================================================
    --- /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas	(revision 48679)
    +++ /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas	(working copy)
    @@ -20,6 +20,7 @@
         Graeme Geldenhuys <graemeg@gmail.com>
         Darius Blaszijk <dhkblaszyk@zeelandnet.nl>
         Reinier Olislagers <reinierolislagers@gmail.com>
    +    Serguei Tarassov <serge@arbinada.com>
     }
     
     unit GuiTestRunner;
    @@ -121,6 +122,7 @@
         FINI: TINIFile;
         procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
         function  FindNode(aTest: TTest): TTreeNode;
    +    function MakeTestPath(Node: TTreeNode): string;
         procedure ResetNodeColors;
         procedure PaintNodeError(aNode: TTreeNode);
         procedure PaintNodeFailure(aNode: TTreeNode);
    @@ -129,6 +131,8 @@
         procedure PaintNodeBusy(aNode: TTreeNode);
         procedure MemoLog(LogEntry: string);
         procedure EnableRunActions(AValue: boolean);
    +    procedure RestoreTree;
    +    procedure SaveTree;
       public
         procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
         procedure AddError(ATest: TTest; AError: TTestFailure);
    @@ -173,7 +177,7 @@
       sactCheckAll = 'Check all Tests';
       sactUncheckAll = 'Uncheck all tests';
       sactRunHighlightedTest = 'Run highlighted test';
    -  smiRunTest = '  &Run all selected (checked) tests';
    +  smiRunTest = '&Run all selected (checked) tests';
       smiShowfail= 'Copy message to clipboard';
       smiCopy = '&Copy';
       smiCut = 'C&ut';
    @@ -186,6 +190,7 @@
     uses
       xmlwrite
       ;
    +
     const
       // TestTreeImageList indexes:
       imgGreenBall = 0; //success result
    @@ -236,12 +241,42 @@
       XMLSynEdit.Lines.Clear;
     end;
     
    +function TGUITestRunner.MakeTestPath(Node: TTreeNode): string;
    +begin
    +  Result := '';
    +  while Node <> nil do
    +  begin
    +    Result := Node.Text + '_' + Result;
    +    Node := Node.Parent;
    +  end;
    +end;
    +
    +procedure TGUITestRunner.SaveTree;
    +var
    +  i: integer;
    +begin
    +  for i := 0 to TestTree.Items.Count - 1 do
    +    FINI.WriteBool('Tests', MakeTestPath(TestTree.Items[i]), TestTree.Items[i].StateIndex = Ord(tsChecked));
    +end;
    +
    +procedure TGUITestRunner.RestoreTree;
    +var
    +  i: integer;
    +begin
    +  for i := 0 to TestTree.Items.Count - 1 do
    +    if FINI.ReadBool('Tests', MakeTestPath(TestTree.Items[i]), true) then
    +      TestTree.Items[i].StateIndex := Ord(tsChecked)
    +    else
    +      TestTree.Items[i].StateIndex := Ord(tsUnChecked);
    +end;
    +
     procedure TGUITestRunner.GUITestRunnerCreate(Sender: TObject);
     begin
       barColor := clGreen;
       TestTree.Items.Clear;
       BuildTree(TestTree.Items.AddObject(nil, rsAllTests, GetTestRegistry),
         GetTestRegistry);
    +  RestoreTree;
       PageControl1.ActivePage := tsTestTree;
       //
       BtnRun.Caption:= sbtnRun;
    @@ -272,7 +307,7 @@
         TestTree.Items[0].Expand(False);
       end;
     
    -  FINI := TINIFile.Create(ExtractFileNameOnly(ParamStr(0))+ '.ini');
    +  FINI := TINIFile.Create(ExtractFileNameOnly(ParamStr(0)) + '.fpcunit.ini'); // Prevent ini file names conflict if tests are embedded in application
     end;
     
     procedure TGUITestRunner.RunExecute(Sender: TObject);
    @@ -820,6 +855,7 @@
       m: TMemoryStream;
     
     begin
    +  SaveTree;
       barcolor := clGreen;
       ResetNodeColors;
       failureCounter := 0;
    
  • guitestrunner.lfm.48679.patch (1,428 bytes)
    Index: /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm
    ===================================================================
    --- /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm	(revision 48679)
    +++ /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm	(working copy)
    @@ -1850,16 +1850,22 @@
         top = 176
         object RunAction: TAction
           Category = 'Run'
    -      Caption = '  &Run'
    +      Caption = '&Run'
           Hint = 'Run all checked test(s)'
           ImageIndex = 3
           OnExecute = RunExecute
    +      SecondaryShortCuts.Strings = (
    +        'F9'
    +      )
           ShortCut = 16466
         end
         object ActCloseForm: TAction
           Caption = 'Quit'
           Hint = 'Quit Testing'
           OnExecute = ActCloseFormExecute
    +      SecondaryShortCuts.Strings = (
    +        'Esc'
    +      )
           ShortCut = 16451
         end
         object actCopyErrorMsg: TAction
    @@ -1897,6 +1903,7 @@
           ImageIndex = 4
           OnExecute = ActRunHighlightedTestExecute
           OnUpdate = ActRunHighLightedTestUpdate
    +      ShortCut = 119
         end
       end
       object PopupMenu3: TPopupMenu
    @@ -1905,7 +1912,8 @@
         top = 240
         object miRunTest: TMenuItem
           Action = RunAction
    -      Caption = '  &Run all selected (checked) tests'
    +      Caption = '&Run all selected (checked) tests'
    +      ShortCutKey2 = 120
           OnClick = RunExecute
         end
         object MenuItem4: TMenuItem
    
  • guitestrunner.lfm.48684.patch (1,428 bytes)
    Index: /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm
    ===================================================================
    --- /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm	(revision 48684)
    +++ /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm	(working copy)
    @@ -1850,16 +1850,22 @@
         top = 176
         object RunAction: TAction
           Category = 'Run'
    -      Caption = '  &Run'
    +      Caption = '&Run'
           Hint = 'Run all checked test(s)'
           ImageIndex = 3
           OnExecute = RunExecute
    +      SecondaryShortCuts.Strings = (
    +        'F9'
    +      )
           ShortCut = 16466
         end
         object ActCloseForm: TAction
           Caption = 'Quit'
           Hint = 'Quit Testing'
           OnExecute = ActCloseFormExecute
    +      SecondaryShortCuts.Strings = (
    +        'Esc'
    +      )
           ShortCut = 16451
         end
         object actCopyErrorMsg: TAction
    @@ -1897,6 +1903,7 @@
           ImageIndex = 4
           OnExecute = ActRunHighlightedTestExecute
           OnUpdate = ActRunHighLightedTestUpdate
    +      ShortCut = 119
         end
       end
       object PopupMenu3: TPopupMenu
    @@ -1905,7 +1912,8 @@
         top = 240
         object miRunTest: TMenuItem
           Action = RunAction
    -      Caption = '  &Run all selected (checked) tests'
    +      Caption = '&Run all selected (checked) tests'
    +      ShortCutKey2 = 120
           OnClick = RunExecute
         end
         object MenuItem4: TMenuItem
    
  • guitestrunner.pas.48684.patch (4,916 bytes)
    Index: /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas
    ===================================================================
    --- /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas	(revision 48684)
    +++ /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas	(working copy)
    @@ -20,6 +20,7 @@
         Graeme Geldenhuys <graemeg@gmail.com>
         Darius Blaszijk <dhkblaszyk@zeelandnet.nl>
         Reinier Olislagers <reinierolislagers@gmail.com>
    +    Serguei Tarassov <serge@arbinada.com>
     }
     
     unit GuiTestRunner;
    @@ -118,9 +119,10 @@
         barColor: TColor;
         testSuite: TTest;
         FFirstFailure: TTreeNode; // reference to first failed test
    -    FINI: TINIFile;
    +    FConfStore: TIniFile;
         procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
         function  FindNode(aTest: TTest): TTreeNode;
    +    function MakeTestPath(Node: TTreeNode): string;
         procedure ResetNodeColors;
         procedure PaintNodeError(aNode: TTreeNode);
         procedure PaintNodeFailure(aNode: TTreeNode);
    @@ -129,6 +131,8 @@
         procedure PaintNodeBusy(aNode: TTreeNode);
         procedure MemoLog(LogEntry: string);
         procedure EnableRunActions(AValue: boolean);
    +    procedure RestoreTree;
    +    procedure SaveTree;
       public
         procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
         procedure AddError(ATest: TTest; AError: TTestFailure);
    @@ -173,7 +177,7 @@
       sactCheckAll = 'Check all Tests';
       sactUncheckAll = 'Uncheck all tests';
       sactRunHighlightedTest = 'Run highlighted test';
    -  smiRunTest = '  &Run all selected (checked) tests';
    +  smiRunTest = '&Run all selected (checked) tests';
       smiShowfail= 'Copy message to clipboard';
       smiCopy = '&Copy';
       smiCut = 'C&ut';
    @@ -186,6 +190,7 @@
     uses
       xmlwrite
       ;
    +
     const
       // TestTreeImageList indexes:
       imgGreenBall = 0; //success result
    @@ -236,12 +241,43 @@
       XMLSynEdit.Lines.Clear;
     end;
     
    +function TGUITestRunner.MakeTestPath(Node: TTreeNode): string;
    +begin
    +  Result := '';
    +  while Node <> nil do
    +  begin
    +    Result := Node.Text + '_' + Result;
    +    Node := Node.Parent;
    +  end;
    +end;
    +
    +procedure TGUITestRunner.SaveTree;
    +var
    +  i: integer;
    +begin
    +  for i := 0 to TestTree.Items.Count - 1 do
    +    FConfStore.WriteBool('Tests', MakeTestPath(TestTree.Items[i]), TestTree.Items[i].StateIndex = Ord(tsChecked));
    +end;
    +
    +procedure TGUITestRunner.RestoreTree;
    +var
    +  i: integer;
    +begin
    +  for i := 0 to TestTree.Items.Count - 1 do
    +    if FConfStore.ReadBool('Tests', MakeTestPath(TestTree.Items[i]), true) then
    +      TestTree.Items[i].StateIndex := Ord(tsChecked)
    +    else
    +      TestTree.Items[i].StateIndex := Ord(tsUnChecked);
    +end;
    +
     procedure TGUITestRunner.GUITestRunnerCreate(Sender: TObject);
     begin
    +  FConfStore := TIniFile.Create(ExtractFileNameOnly(ParamStr(0)) + '.fpcunit.ini'); // Prevent ini file names conflict if tests are embedded in application
       barColor := clGreen;
       TestTree.Items.Clear;
       BuildTree(TestTree.Items.AddObject(nil, rsAllTests, GetTestRegistry),
         GetTestRegistry);
    +  RestoreTree;
       PageControl1.ActivePage := tsTestTree;
       //
       BtnRun.Caption:= sbtnRun;
    @@ -271,8 +307,6 @@
         TestTree.Items.SelectOnlyThis(TestTree.Items[0]);
         TestTree.Items[0].Expand(False);
       end;
    -
    -  FINI := TINIFile.Create(ExtractFileNameOnly(ParamStr(0))+ '.ini');
     end;
     
     procedure TGUITestRunner.RunExecute(Sender: TObject);
    @@ -349,11 +383,11 @@
     procedure TGUITestRunner.FormDestroy(Sender: TObject);
     begin
       // store window position and size
    -  FINI.WriteInteger('WindowState', 'Left', Left);
    -  FINI.WriteInteger('WindowState', 'Top', Top);
    -  FINI.WriteInteger('WindowState', 'Width', Width);
    -  FINI.WriteInteger('WindowState', 'Height', Height);
    -  FINI.Free;
    +  FConfStore.WriteInteger('WindowState', 'Left', Left);
    +  FConfStore.WriteInteger('WindowState', 'Top', Top);
    +  FConfStore.WriteInteger('WindowState', 'Width', Width);
    +  FConfStore.WriteInteger('WindowState', 'Height', Height);
    +  FConfStore.Free;
     end;
     
     procedure TGUITestRunner.GUITestRunnerShow(Sender: TObject);
    @@ -361,10 +395,10 @@
       if (ParamStrUTF8(1) = '--now') or (ParamStrUTF8(1) = '-n') then
         RunExecute(Self);
       // restore last used position and size
    -  Left := FINI.ReadInteger('WindowState', 'Left', Left);
    -  Top := FINI.ReadInteger('WindowState', 'Top', Top);
    -  Width := FINI.ReadInteger('WindowState', 'Width', Width);
    -  Height := FINI.ReadInteger('WindowState', 'Height', Height);
    +  Left := FConfStore.ReadInteger('WindowState', 'Left', Left);
    +  Top := FConfStore.ReadInteger('WindowState', 'Top', Top);
    +  Width := FConfStore.ReadInteger('WindowState', 'Width', Width);
    +  Height := FConfStore.ReadInteger('WindowState', 'Height', Height);
     end;
     
     procedure TGUITestRunner.MenuItem3Click(Sender: TObject);
    @@ -820,6 +854,7 @@
       m: TMemoryStream;
     
     begin
    +  SaveTree;
       barcolor := clGreen;
       ResetNodeColors;
       failureCounter := 0;
    

Activities

Juha Manninen

2015-04-01 20:12

developer   ~0082536

Could you provide a patch please?

Serguei Tarassov

2015-04-03 11:02

reporter  

guitestrunner.lfm.patch (3,793 bytes)
--- /cygdrive/C/lazarus/components/fpcunit/guitestrunner.lfm	2014-05-06 23:52:07.524235000 +0200
+++ guitestrunner.lfm	2015-04-02 15:32:08.231268800 +0200
@@ -46,7 +46,7 @@
   OnShow = GUITestRunnerShow
   Position = poScreenCenter
   ShowHint = True
-  LCLVersion = '1.3'
+  LCLVersion = '1.2.6.0'
   object Panel1: TPanel
     Left = 0
     Height = 88
@@ -172,10 +172,10 @@
       AnchorSideTop.Control = Panel1
       AnchorSideRight.Control = Panel1
       AnchorSideRight.Side = asrBottom
-      Left = 488
+      Left = 482
       Height = 34
       Top = 7
-      Width = 80
+      Width = 86
       Action = ActCloseForm
       Anchors = [akTop, akRight]
       AutoSize = True
@@ -269,7 +269,7 @@
       Left = 92
       Height = 32
       Top = 7
-      Width = 148
+      Width = 174
       Action = ActRunHighlightedTest
       AutoSize = True
       BorderSpacing.Around = 6
@@ -367,27 +367,26 @@
       TabOrder = 0
       object tsTestTree: TTabSheet
         Caption = 'Testcase tree'
-        ClientHeight = 474
+        ClientHeight = 470
         ClientWidth = 565
         object Splitter1: TSplitter
           Cursor = crVSplit
           Left = 0
           Height = 5
-          Top = 336
+          Top = 332
           Width = 565
           Align = alBottom
           ResizeAnchor = akBottom
         end
         object TestTree: TTreeView
           Left = 6
-          Height = 324
+          Height = 320
           Top = 6
           Width = 553
           Align = alClient
           BorderSpacing.Around = 6
           BackgroundColor = clBtnFace
           Color = clBtnFace
-          DefaultItemHeight = 16
           Images = TestTreeImageList
           PopupMenu = PopupMenu3
           ReadOnly = True
@@ -403,7 +402,7 @@
         object Memo1: TMemo
           Left = 6
           Height = 121
-          Top = 347
+          Top = 343
           Width = 553
           Align = alBottom
           BorderSpacing.Around = 6
@@ -436,7 +435,7 @@
           TabOrder = 0
           BookMarkOptions.Xoffset = -18
           Gutter.Visible = False
-          Gutter.Width = 59
+          Gutter.Width = 61
           Gutter.MouseActions = <          
             item
               ClickCount = ccAny
@@ -882,7 +881,7 @@
               MouseActions = <>
             end
             object TSynGutterLineNumber
-              Width = 19
+              Width = 21
               MouseActions = <>
               MarkupInfo.Background = clBtnFace
               MarkupInfo.Foreground = clNone
@@ -1850,16 +1849,22 @@
     top = 176
     object RunAction: TAction
       Category = 'Run'
-      Caption = '  &Run'
+      Caption = '&Run'
       Hint = 'Run all checked test(s)'
       ImageIndex = 3
       OnExecute = RunExecute
+      SecondaryShortCuts.Strings = (
+        'F9'
+      )
       ShortCut = 16466
     end
     object ActCloseForm: TAction
       Caption = 'Quit'
       Hint = 'Quit Testing'
       OnExecute = ActCloseFormExecute
+      SecondaryShortCuts.Strings = (
+        'Esc'
+      )
       ShortCut = 16451
     end
     object actCopyErrorMsg: TAction
@@ -1897,6 +1902,7 @@
       ImageIndex = 4
       OnExecute = ActRunHighlightedTestExecute
       OnUpdate = ActRunHighLightedTestUpdate
+      ShortCut = 119
     end
   end
   object PopupMenu3: TPopupMenu
@@ -1905,7 +1911,8 @@
     top = 240
     object miRunTest: TMenuItem
       Action = RunAction
-      Caption = '  &Run all selected (checked) tests'
+      Caption = '&Run all selected (checked) tests'
+      ShortCutKey2 = 120
       OnClick = RunExecute
     end
     object MenuItem4: TMenuItem
    end
     object MenuItem4: TMenuItem
guitestrunner.lfm.patch (3,793 bytes)

Serguei Tarassov

2015-04-03 11:03

reporter  

guitestrunner.pas.patch (3,103 bytes)
--- /cygdrive/C/lazarus/components/fpcunit/guitestrunner.pas	2014-05-06 23:52:07.524235000 +0200
+++ guitestrunner.pas	2015-04-02 15:32:08.201225600 +0200
@@ -117,6 +117,8 @@
     testSuite: TTest;
     procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
     function  FindNode(aTest: TTest): TTreeNode;
+    function GetConfFileName: string;
+    function MakeTestPath(Node: TTreeNode): string;
     procedure ResetNodeColors;
     procedure PaintNodeError(aNode: TTreeNode);
     procedure PaintNodeFailure(aNode: TTreeNode);
@@ -125,6 +127,8 @@
     procedure PaintNodeBusy(aNode: TTreeNode);
     procedure MemoLog(LogEntry: string);
     procedure EnableRunActions(AValue: boolean);
+    procedure RestoreTree;
+    procedure SaveTree;
   public
     procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
     procedure AddError(ATest: TTest; AError: TTestFailure);
@@ -169,7 +173,7 @@
   sactCheckAll = 'Check all Tests';
   sactUncheckAll = 'Uncheck all tests';
   sactRunHighlightedTest = 'Run highlighted test';
-  smiRunTest = '  &Run all selected (checked) tests';
+  smiRunTest = '&Run all selected (checked) tests';
   smiShowfail= 'Copy message to clipboard';
   smiCopy = '&Copy';
   smiCut = 'C&ut';
@@ -180,8 +184,10 @@
 {$R *.lfm}
 
 uses
+  IniFiles,
   xmlwrite
   ;
+
 const
   // TestTreeImageList indexes:
   imgGreenBall = 0; //success result
@@ -232,12 +238,59 @@
   XMLSynEdit.Lines.Clear;
 end;
 
+function TGUITestRunner.GetConfFileName: string;
+begin
+  Result := ParamStr(0) + '.fpcunit.ini';
+end;
+
+function TGUITestRunner.MakeTestPath(Node: TTreeNode): string;
+begin
+  Result := '';
+  while Node <> nil do
+  begin
+    Result := Node.Text + '_' + Result;
+    Node := Node.Parent;
+  end;
+end;
+
+procedure TGUITestRunner.SaveTree;
+var
+  Conf: TIniFile;
+  i: integer;
+begin
+  Conf := TIniFile.Create(GetConfFileName);
+  try
+    for i := 0 to TestTree.Items.Count - 1 do
+      Conf.WriteBool('Tests', MakeTestPath(TestTree.Items[i]), TestTree.Items[i].StateIndex = Ord(tsChecked));
+  finally
+    Conf.Free;
+  end;
+end;
+
+procedure TGUITestRunner.RestoreTree;
+var
+  Conf: TIniFile;
+  i: integer;
+begin
+  Conf := TIniFile.Create(GetConfFileName);
+  try
+    for i := 0 to TestTree.Items.Count - 1 do
+      if Conf.ReadBool('Tests', MakeTestPath(TestTree.Items[i]), true) then
+        TestTree.Items[i].StateIndex := Ord(tsChecked)
+      else
+        TestTree.Items[i].StateIndex := Ord(tsUnChecked);
+  finally
+    Conf.Free;
+  end;
+end;
+
 procedure TGUITestRunner.GUITestRunnerCreate(Sender: TObject);
 begin
   barColor := clGreen;
   TestTree.Items.Clear;
   BuildTree(TestTree.Items.AddObject(nil, rsAllTests, GetTestRegistry),
     GetTestRegistry);
+  RestoreTree;
   PageControl1.ActivePage := tsTestTree;
   //
   BtnRun.Caption:= sbtnRun;
@@ -780,6 +833,7 @@
   m: TMemoryStream;
 
 begin
+  SaveTree;
   barcolor := clGreen;
   ResetNodeColors;
   failureCounter := 0;
ResetNodeColors;
   failureCounter := 0;
guitestrunner.pas.patch (3,103 bytes)

Serguei Tarassov

2015-04-03 11:05

reporter   ~0082561

I added patches, the full sources are available in my blog: http://sgbd.arbinada.com/node/105

Juha Manninen

2015-04-06 11:07

developer   ~0082651

Last edited: 2015-04-06 11:13

View 3 revisions

Your patches fail to apply completely. See below. All patches should be made against trunk.
Other things to make applying (valid) patches easier :
1. You can add all changes into one patch.
2. You should create a patch from the top level Lazarus directory, like :
  $ svn diff /components/fpcunit/guitestrunner.lfm /components/fpcunit/guitestrunner.pas > guitestrunner.patch

BTW, the "(different line endings)" below is not an error. Patch command can deal with line endings correctly.
---

juha@juhan-kone:~/SW/lazarus_gitsvn/components/fpcunit > patch -p0 < ~/patch/guitestrunner.lfm.patch
patching file guitestrunner.lfm
Hunk 0000001 FAILED at 46 (different line endings).
Hunk 0000002 FAILED at 172 (different line endings).
Hunk 0000003 FAILED at 269 (different line endings).
Hunk 0000004 FAILED at 367 (different line endings).
Hunk 0000005 FAILED at 403 (different line endings).
Hunk 0000006 FAILED at 436 (different line endings).
Hunk 0000007 FAILED at 882 (different line endings).
Hunk 0000008 FAILED at 1850 (different line endings).
Hunk 0000009 FAILED at 1897 (different line endings).
Hunk 0000010 FAILED at 1905 (different line endings).
10 out of 10 hunks FAILED -- saving rejects to file guitestrunner.lfm.rej
juha@juhan-kone:~/SW/lazarus_gitsvn/components/fpcunit > patch -p0 < ~/patch/guitestrunner.pas.patch
patching file guitestrunner.pas
Hunk 0000001 FAILED at 117 (different line endings).
Hunk 0000002 FAILED at 125 (different line endings).
Hunk 0000003 FAILED at 169 (different line endings).
Hunk 0000004 FAILED at 180 (different line endings).
Hunk 0000005 FAILED at 232 (different line endings).
Hunk 0000006 FAILED at 780 (different line endings).
6 out of 6 hunks FAILED -- saving rejects to file guitestrunner.pas.rej

Serguei Tarassov

2015-04-07 12:18

reporter   ~0082688

I use 1.2.6 for Win32/Linux64 and the patches are taken from sources provided with Win32 distribution (it explains line endings difference).

Could you please provide SVN URL to get required sources?
I will make patches from it.

Zeljan Rikalo

2015-04-07 13:23

developer   ~0082690

http://wiki.lazarus.freepascal.org/index.php/Getting_Lazarus
You must install trunk lazarus version from svn and then create patches.

Juha Manninen

2015-04-07 13:57

developer   ~0082691

SVN URL:
  http://svn.freepascal.org/svn/lazarus/trunk

Wiki page:
  http://wiki.freepascal.org/Getting_Lazarus

Serguei Tarassov

2015-04-07 15:28

reporter   ~0082696

I see that the files was modified a little so I cannot make the patch but only merge them (reusing introduced FINI variable).

Here is 2 files attached (I don't have rights to commit them directly): quitestrunner.pas and .lfm.

Serguei Tarassov

2015-04-07 15:29

reporter  

guitestrunner.pas (26,511 bytes)
{
  Copyright (C) 2004-2015 Dean Zobec, contributors

  This library is free software; you can redistribute it and/or modify it
  under the terms of the GNU Library General Public License as published by
  the Free Software Foundation; either version 2 of the License, or (at your
  option) any later version.

  This program is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
  for more details.

  You should have received a copy of the GNU Library General Public License
  along with this library; if not, write to the Free Software Foundation,
  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  
  
  Modified:
    Graeme Geldenhuys <graemeg@gmail.com>
    Darius Blaszijk <dhkblaszyk@zeelandnet.nl>
    Reinier Olislagers <reinierolislagers@gmail.com>
    Serguei Tarassov <serge@arbinada.com>
}

unit GuiTestRunner;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
  ExtCtrls, Buttons, ComCtrls, ActnList, Menus, Clipbrd, StdCtrls,
  testdecorator, xmltestreport,
  fpcunit, testregistry, SynEdit, SynHighlighterXML, gettext, Translations,
  inifiles;

type

  { TGUITestRunner }

  TGUITestRunner = class(TForm, ITestListener)
    actCopy: TAction;
    actCut: TAction;
    ActCloseForm: TAction;
    actCopyErrorMsg: TAction;
    ActCheckCurrentSuite: TAction;
    ActCheckAll: TAction;
    ActRunHighlightedTest: TAction;
    ActUncheckAll: TAction;
    ActUncheckCurrentSuite: TAction;
    btnRunHighlighted: TBitBtn;
    ilNodeStates: TImageList;
    Memo1: TMemo;
    MenuItem4: TMenuItem;
    MenuItem5: TMenuItem;
    MenuItem6: TMenuItem;
    MenuItem7: TMenuItem;
    MenuItem8: TMenuItem;
    miRunTest: TMenuItem;
    miShowfailureMsg: TMenuItem;
    pbBar: TPaintBox;
    PopupMenu3: TPopupMenu;
    RunAction: TAction;
    ActionList1: TActionList;
    ActionList2: TActionList;
    BtnRun: TBitBtn;
    BtnClose: TBitBtn;
    TestTreeImageList: TImageList;
    ResultsXMLImageList: TImageList;
    MenuItem1: TMenuItem;
    MenuItem2: TMenuItem;
    MenuItem3: TMenuItem;
    PopupMenu1: TPopupMenu;
    PopupMenu2: TPopupMenu;
    SaveDialog: TSaveDialog;
    Splitter1: TSplitter;
    TestTree: TTreeView;
    SynXMLSyn1: TSynXMLSyn;
    PageControl1: TPageControl;
    Panel1: TPanel;
    Panel2: TPanel;
    XMLToolBar: TToolBar;
    CopyXMLToolButton: TToolButton;
    CutXMLToolButton: TToolButton;
    SaveAsToolButton: TToolButton;
    tsTestTree: TTabSheet;
    tsResultsXML: TTabSheet;
    XMLSynEdit: TSynEdit;
    procedure ActCheckAllExecute(Sender: TObject);
    procedure ActCheckCurrentSuiteExecute(Sender: TObject);
    procedure ActCloseFormExecute(Sender: TObject);
    procedure ActRunHighlightedTestExecute(Sender: TObject);
    procedure ActUncheckAllExecute(Sender: TObject);
    procedure ActRunHighLightedTestUpdate(Sender: TObject);
    procedure ActUncheckCurrentSuiteExecute(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure RunExecute(Sender: TObject);
    procedure GUITestRunnerCreate(Sender: TObject);
    procedure GUITestRunnerShow(Sender: TObject);
    procedure MenuItem3Click(Sender: TObject);
    procedure SaveAsToolButtonClick(Sender: TObject);
    procedure TestTreeCreateNodeClass(Sender: TCustomTreeView;
      var NodeClass: TTreeNodeClass);
    procedure TestTreeMouseDown(Sender: TOBject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure TestTreeSelectionChanged(Sender: TObject);
    procedure actCopyErrorMsgExecute(Sender: TObject);
    procedure actCopyErrorMsgUpdate(Sender: TObject);
    procedure pbBarPaint(Sender: TObject);
    procedure actCopyExecute(Sender: TObject);
    procedure actCutExecute(Sender: TObject);
  private
    failureCounter: Integer;
    errorCounter: Integer;
    testsCounter: Integer;
    skipsCounter: Integer;
    barColor: TColor;
    testSuite: TTest;
    FFirstFailure: TTreeNode; // reference to first failed test
    FINI: TINIFile;
    procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
    function  FindNode(aTest: TTest): TTreeNode;
    function MakeTestPath(Node: TTreeNode): string;
    procedure ResetNodeColors;
    procedure PaintNodeError(aNode: TTreeNode);
    procedure PaintNodeFailure(aNode: TTreeNode);
    procedure PaintNodeIgnore(aNode: TTreeNode);
    procedure PaintNodeNonFailed(aNode: TTreeNode);
    procedure PaintNodeBusy(aNode: TTreeNode);
    procedure MemoLog(LogEntry: string);
    procedure EnableRunActions(AValue: boolean);
    procedure RestoreTree;
    procedure SaveTree;
  public
    procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
    procedure AddError(ATest: TTest; AError: TTestFailure);
    procedure StartTest(ATest: TTest);
    procedure EndTest(ATest: TTest);
    procedure RunTest(ATest: TTest);
    procedure StartTestSuite(ATestSuite: TTestSuite);
    procedure EndTestSuite(ATestSuite: TTestSuite);
  end;

var
  TestRunner: TGUITestRunner;

resourcestring
  rsAllTests = 'All Tests';
  rsRun = 'Run ';
  rsRuns = 'Runs: %s/%s';
  rsErrors = '%s    Errors: %s';
  rsFailures = '%s     Failures: %s';
  rsMessage = 'Message: %s';
  rsException = 'Exception: %s';
  rsExceptionMes = 'Exception message: %s';
  rsExceptionCla = 'Exception class: %s';
  rsUnitName = 'Unit name: %s';
  rsMethodName = 'Method name: %s';
  rsLineNumber = 'Line number: %s';
  rsRunning = 'Running %s';
  rsNumberOfExec = 'Number of executed tests: %s  Time elapsed: %s';
  // Visual components captions
  sfrmGUITest = 'FPCUnit - run unit test';
  sbtnRun = 'Run';
  sbtnRunH = 'Run highlighted test';
  sbtnClose = 'Close';
  stshTree = 'Testcase tree';
  stshResults = 'Results XML';
  sactRunAction = '&Run';
  sactRunActionH = 'Run all checked test(s)';
  sactCloseForm = 'Quit';
  sactCloseFormH = 'Quit Testting';
  sactCheckCurrentSuite = 'Check the Current Suite';
  sactUncheckCurrentSuite = 'Uncheck the Current Suite';
  sactCheckAll = 'Check all Tests';
  sactUncheckAll = 'Uncheck all tests';
  sactRunHighlightedTest = 'Run highlighted test';
  smiRunTest = '&Run all selected (checked) tests';
  smiShowfail= 'Copy message to clipboard';
  smiCopy = '&Copy';
  smiCut = 'C&ut';
  smiCopyClipbrd = 'Copy to clipboard';

implementation

{$R *.lfm}

uses
  xmlwrite
  ;

const
  // TestTreeImageList indexes:
  imgGreenBall = 0; //success result
  imgRedBall = 2;
  imgPurpleBall = 3;
  imgWarningSign = 4; //failure result
  imgInfoSign = 11; //error result
  imgGrayBall = 12; //default
  imgBlueBall = 13; //busy

type

  TTreeNodeState=(tsUnChecked, tsChecked);

type

  { TMessageTreeNode }

  TMessageTreeNode = class(TTreeNode)
  private
    FMessage: string;
  public
    property Message: string read FMessage write FMessage;
  end;

function FirstLine(const s: string): string;
var
  NewLinePos: integer;
begin
  NewLinePos := pos(LineEnding, s);
  if NewLinePos > 0 then
    Result := copy(s, 1, NewLinePos-1)
  else
    Result := s;
end;

{ TGUITestRunner }

procedure TGUITestRunner.actCopyExecute(Sender: TObject);
begin
  Clipboard.AsText := XMLSynEdit.Lines.Text;
end;


procedure TGUITestRunner.actCutExecute(Sender: TObject);
begin
  Clipboard.AsText := XMLSynEdit.Lines.Text;
  XMLSynEdit.Lines.Clear;
end;

function TGUITestRunner.MakeTestPath(Node: TTreeNode): string;
begin
  Result := '';
  while Node <> nil do
  begin
    Result := Node.Text + '_' + Result;
    Node := Node.Parent;
  end;
end;

procedure TGUITestRunner.SaveTree;
var
  i: integer;
begin
  for i := 0 to TestTree.Items.Count - 1 do
    FINI.WriteBool('Tests', MakeTestPath(TestTree.Items[i]), TestTree.Items[i].StateIndex = Ord(tsChecked));
end;

procedure TGUITestRunner.RestoreTree;
var
  i: integer;
begin
  for i := 0 to TestTree.Items.Count - 1 do
    if FINI.ReadBool('Tests', MakeTestPath(TestTree.Items[i]), true) then
      TestTree.Items[i].StateIndex := Ord(tsChecked)
    else
      TestTree.Items[i].StateIndex := Ord(tsUnChecked);
end;

procedure TGUITestRunner.GUITestRunnerCreate(Sender: TObject);
begin
  barColor := clGreen;
  TestTree.Items.Clear;
  BuildTree(TestTree.Items.AddObject(nil, rsAllTests, GetTestRegistry),
    GetTestRegistry);
  RestoreTree;
  PageControl1.ActivePage := tsTestTree;
  //
  BtnRun.Caption:= sbtnRun;
  btnRunHighlighted.Caption := sbtnRunH;
  BtnClose.Caption:= sbtnClose;
  tsTestTree.Caption:= stshTree;
  tsResultsXML.Caption:= stshResults;
  //
  Caption:= sfrmGUITest;
  RunAction.Caption:= sactRunAction;
  RunAction.Hint:= sactRunActionH;
  ActCloseForm.Caption:= sactCloseForm;
  ActCloseForm.Hint:= sactCloseFormH;
  ActCheckCurrentSuite.Caption:= sactCheckCurrentSuite;
  ActUncheckCurrentSuite.Caption:= sactUncheckCurrentSuite;
  ActCheckAll.Caption:= sactCheckAll;
  ActUncheckAll.Caption:= sactUncheckAll;
  ActRunHighlightedTest.Caption:= sactRunHighlightedTest;
  miRunTest.Caption:= smiRunTest;
  miShowfailureMsg.Caption:= smiShowfail;
  MenuItem1.Caption:= smiCopy;
  MenuItem2.Caption:= smiCut;
  MenuItem3.Caption:= smiCopyClipbrd;
  // Select the first entry in the tree in order to immediately activate the 
  // Run All tests button:
  if TestTree.Items.Count>0 then begin
    TestTree.Items.SelectOnlyThis(TestTree.Items[0]);
    TestTree.Items[0].Expand(False);
  end;

  FINI := TINIFile.Create(ExtractFileNameOnly(ParamStr(0)) + '.fpcunit.ini'); // Prevent ini file names conflict if tests are embedded in application
end;

procedure TGUITestRunner.RunExecute(Sender: TObject);
begin
  FFirstFailure := nil;
  testSuite := GetTestRegistry;
  TestTree.Selected := TestTree.Items[0];
  RunTest(testSuite);
end;

procedure TGUITestRunner.ActCloseFormExecute(Sender: TObject);
begin
  Close;
end;

procedure TGUITestRunner.ActCheckAllExecute(Sender: TObject);
var
  i: integer;
begin
  for i := 0 to TestTree.Items.Count -1 do
    TestTree.Items[i].StateIndex := ord(tsChecked);
end;

procedure TGUITestRunner.ActCheckCurrentSuiteExecute(Sender: TObject);
var
  i: integer;
begin
  if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then
  begin
    TestTree.Selected.StateIndex := ord(tsChecked);
    for i := 0 to TestTree.Selected.Count - 1 do
      TestTree.Selected.Items[i].StateIndex := ord(tsChecked);
  end;
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);
var
  i: integer;
begin
  for i := 0 to TestTree.Items.Count -1 do
    TestTree.Items[i].StateIndex := ord(tsUnChecked);
end;


procedure TGUITestRunner.ActRunHighLightedTestUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := ((TestTree.Selected <> nil)
    and (TestTree.Selected.Data <> nil));
end;

procedure TGUITestRunner.ActUncheckCurrentSuiteExecute(Sender: TObject);
var
  i: integer;
begin
  if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then
  begin
    TestTree.Selected.StateIndex := ord(tsUnchecked);
    for i := 0 to TestTree.Selected.Count - 1 do
      TestTree.Selected.Items[i].StateIndex := ord(tsUnChecked);
  end;
end;

procedure TGUITestRunner.FormDestroy(Sender: TObject);
begin
  // store window position and size
  FINI.WriteInteger('WindowState', 'Left', Left);
  FINI.WriteInteger('WindowState', 'Top', Top);
  FINI.WriteInteger('WindowState', 'Width', Width);
  FINI.WriteInteger('WindowState', 'Height', Height);
  FINI.Free;
end;

procedure TGUITestRunner.GUITestRunnerShow(Sender: TObject);
begin
  if (ParamStrUTF8(1) = '--now') or (ParamStrUTF8(1) = '-n') then
    RunExecute(Self);
  // restore last used position and size
  Left := FINI.ReadInteger('WindowState', 'Left', Left);
  Top := FINI.ReadInteger('WindowState', 'Top', Top);
  Width := FINI.ReadInteger('WindowState', 'Width', Width);
  Height := FINI.ReadInteger('WindowState', 'Height', Height);
end;

procedure TGUITestRunner.MenuItem3Click(Sender: TObject);
begin
  Clipboard.AsText := Memo1.Lines.Text;
end;

procedure TGUITestRunner.SaveAsToolButtonClick(Sender: TObject);
begin
  if SaveDialog.Execute then
    XMLSynEdit.Lines.SaveToFile(SaveDialog.FileName);
end;

procedure TGUITestRunner.TestTreeCreateNodeClass(Sender: TCustomTreeView;
  var NodeClass: TTreeNodeClass);
begin
  NodeClass := TMessageTreeNode;
end;

procedure TGUITestRunner.TestTreeMouseDown(Sender: TOBject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

  procedure ChangeCheck(aNode: TTreeNode; aCheck: TTreeNodeState);
  var
    i: integer;
    n: TTreeNode;
  begin
    if Assigned(aNode) then
    begin
      aNode.StateIndex := ord(aCheck);
      if (TTest(aNode.Data) is TTestSuite) then
        for i := 0 to aNode.Count - 1 do
        begin
          n := aNode.Items[i];
          ChangeCheck(n, aCheck);
        end;
    end;
  end;

var
  ht: THitTests;
  lNode: TTreeNode;
begin
  ht := (Sender as TTreeview).GetHitTestInfoAt(X, Y);
  if htOnStateIcon in ht then
  begin
    lNode := (Sender as TTreeview).GetNodeAt(X, Y);
    case lNode.StateIndex of
        0: ChangeCheck(lNode, tsChecked);
        1: ChangeCheck(lNode, tsUnChecked);
      end;
   end;
end;


procedure TGUITestRunner.TestTreeSelectionChanged(Sender: TObject);
begin
  if ((Sender as TTreeView).Selected <> nil) and
    Assigned((Sender as TTreeview).Selected.Data)  then
  begin
    btnRunHighlighted.Visible := true;
    btnRunHighlighted.Caption := rsRun + (Sender as TTreeview).Selected.Text;
  end
  else
    begin
      btnRunHighlighted.Visible := false;
      btnRunHighlighted.Caption := '';
    end;
end;


procedure TGUITestRunner.actCopyErrorMsgExecute(Sender: TObject);
begin
  ClipBoard.AsText := (TestTree.Selected as TMessageTreeNode).Message;
end;


procedure TGUITestRunner.actCopyErrorMsgUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := Assigned(TestTree.selected) and
    (Copy(TestTree.Selected.Text, 1, 9) = 'Message: ');
end;


procedure TGUITestRunner.pbBarPaint(Sender: TObject);
var
  msg: string;
  alltests: integer;
  OldStyle: TBrushStyle;
begin
  with (Sender as TPaintBox) do
  begin
    Canvas.Lock;
    Canvas.Brush.Color := clSilver;
    Canvas.Rectangle(0, 0, Width, Height);
    Canvas.Font.Color := clWhite;
    if Assigned(TestSuite) then
    begin
      alltests := TestSuite.CountTestCases;
      if alltests - skipsCounter <> 0 then
      begin
        if FailureCounter + ErrorCounter = 0 then
          barColor := clGreen;
        Canvas.Brush.Color := barColor;
        Canvas.Rectangle(0, 0, round(TestsCounter / (alltests - skipsCounter) * Width), Height);
        msg := Format(rsRuns, [IntToStr(TestsCounter), IntToStr(alltests -
          skipsCounter)]);
        msg := Format(rsErrors, [msg, IntToStr(ErrorCounter)]);
        msg := Format(rsFailures, [msg, IntToStr(FailureCounter)]);
        OldStyle := Canvas.Brush.Style;
        Canvas.Brush.Style := bsClear;
        Canvas.Textout(10, 10,  msg);
        Canvas.Brush.Style := OldStyle;
      end;
    end;
    Canvas.UnLock;
  end;
end;


procedure TGUITestRunner.BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
var
  node: TTreeNode;
  i: integer;
begin
  rootNode.StateIndex := Ord(tsChecked);
  for i := 0 to ASuite.Tests.Count - 1 do
  begin
    node := TestTree.Items.AddChildObject(rootNode, ASuite.Test[i].TestName, ASuite.Test[i]);
    if ASuite.Test[i] is TTestSuite then
      BuildTree(Node, TTestSuite(ASuite.Test[i]))
    else
      if TObject(ASuite.Test[i]).InheritsFrom(TTestDecorator) then
        BuildTree(Node, TTestSuite(TTestDecorator(ASuite.Test[i]).Test));
    node.ImageIndex := imgGrayBall;
    node.SelectedIndex := imgGrayBall;
    node.StateIndex := ord(tsChecked);
  end;
  ResetNodeColors;
end;


function TGUITestRunner.FindNode(aTest: TTest): TTreeNode;
var
  i: integer;
begin
  Result := nil;
  for i := 0 to TestTree.Items.Count -1 do
    if (TTest(TestTree.Items[i].data) = aTest) then
    begin
      Result :=  TestTree.Items[i];
      Exit;
    end;
end;


procedure TGUITestRunner.ResetNodeColors;
var
  i: integer;
begin
  for i := 0 to TestTree.Items.Count - 1 do
  begin
    TestTree.Items[i].ImageIndex := imgGrayBall;
    TestTree.Items[i].SelectedIndex := imgGrayBall;
  end;
end;


procedure TGUITestRunner.PaintNodeError(aNode: TTreeNode);
begin
  while Assigned(aNode) do
  begin
    aNode.ImageIndex := imgRedBall;
    aNode.SelectedIndex := imgRedBall;
    if aNode.AbsoluteIndex<>0 then begin
      aNode.Expand(True);
    end;
    aNode := aNode.Parent;
    if Assigned(aNode) and
      ((aNode.ImageIndex in [imgGreenBall, imgPurpleBall, imgGrayBall, imgBlueBall]) or
      (ANode.ImageIndex = -1)) then
      PaintNodeError(aNode);
  end;
end;


procedure TGUITestRunner.PaintNodeFailure(aNode: TTreeNode);
begin
  while Assigned(aNode) do
  begin
    if ((aNode.ImageIndex in [imgGreenBall, imgGrayBall, imgBlueBall]) or
      (ANode.ImageIndex = -1)) then
    begin
      aNode.ImageIndex := imgPurpleBall;
      aNode.SelectedIndex := imgPurpleBall;
      if aNode.AbsoluteIndex<>0 then begin
        aNode.Expand(true);
      end;
    end;
    aNode := aNode.Parent;
    if Assigned(aNode) and ((aNode.ImageIndex in [imgGreenBall, imgGrayBall, imgBlueBall]) or
      (ANode.ImageIndex = -1)) then
      PaintNodeFailure(aNode);
  end;
end;

procedure TGUITestRunner.PaintNodeIgnore(aNode: TTreeNode);
// Test results with Ignore
var
  noFailedSibling: boolean;
  i: integer;
begin
  if Assigned(aNode) then
  begin
    if ((aNode.ImageIndex in [imgGrayBall, imgBlueBall]) or
      (ANode.ImageIndex = -1)) then
    begin
      aNode.ImageIndex := imgGreenBall;
      aNode.SelectedIndex := imgGreenBall;
    end;
  end;
  if Assigned(aNode.Parent) then
    if aNode.Index = aNode.Parent.Count -1 then
    begin
    aNode := aNode.Parent;
    noFailedSibling := true;
    for i := 0 to aNode.Count -2 do
    begin
      if aNode.Items[i].ImageIndex <> imgGreenBall then
        noFailedSibling := false;;
    end;
    if (aNode.ImageIndex = imgBlueBall) and
      noFailedSibling then
      PaintNodeIgnore(aNode);
    end;
end;


procedure TGUITestRunner.PaintNodeNonFailed(aNode: TTreeNode);
var
  noFailedSibling: boolean;
  i: integer;
begin
  if Assigned(aNode) then
  begin
    if ((aNode.ImageIndex in [imgGrayBall, imgBlueBall]) or
      (ANode.ImageIndex = -1)) then
    begin
      aNode.ImageIndex := imgGreenBall;
      aNode.SelectedIndex := imgGreenBall;
    end;
  end;
  if Assigned(aNode.Parent) then
    if aNode.Index = aNode.Parent.Count -1 then
    begin
    aNode := aNode.Parent;
    noFailedSibling := true;
    for i := 0 to aNode.Count -2 do
    begin
      if aNode.Items[i].ImageIndex <> imgGreenBall then
        noFailedSibling := false;;
    end;
    if (aNode.ImageIndex = imgBlueBall) and
      noFailedSibling then
      PaintNodeNonFailed(aNode);
    end;
end;


procedure TGUITestRunner.PaintNodeBusy(aNode: TTreeNode);
var
  BusySibling: boolean;
  i: integer;
begin
  if Assigned(aNode) then
  begin
    aNode.ImageIndex := imgBlueBall;
    aNode.SelectedIndex := imgBlueBall;
  end;
  if Assigned(aNode.Parent) then
  begin
    if aNode.Index = aNode.Parent.Count -1 then
    begin
      aNode := aNode.Parent;
      BusySibling := true;
      for i := 0 to aNode.Count -2 do
      begin
        if aNode.Items[i].ImageIndex <> imgGreenBall then
          BusySibling := false;;
      end;
      if (aNode.ImageIndex = imgBlueBall) and
        BusySibling then
        PaintNodeBusy(aNode);
    end;
  end;
end;


procedure TGUITestRunner.MemoLog(LogEntry: string);
begin
  Memo1.Lines.Add(TimeToStr(Now) + ' - ' + LogEntry);
end;

procedure TGUITestRunner.EnableRunActions(AValue: boolean);
begin
  ActRunHighlightedTest.Enabled := AValue;
  RunAction.Enabled := AValue;
end;

procedure TGUITestRunner.AddFailure(ATest: TTest; AFailure: TTestFailure);
var
  FailureNode: TTreeNode;
  node: TMessageTreeNode;
begin
  FailureNode := FindNode(ATest);
  if Assigned(FailureNode) then
  begin
    node := TestTree.Items.AddChild(FailureNode,
      Format(rsMessage, [FirstLine(AFailure.ExceptionMessage)]))
      as TMessageTreeNode;
    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;
      node := TestTree.Items.AddChild(FailureNode,
        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
    begin
      // Although reported as a failure, the test was set up
      // to be ignored so it is actually a success of sorts
      node.Message := AFailure.ExceptionMessage;
      node.ImageIndex := imgGreenBall;
      node.SelectedIndex := imgGreenBall;
      node := TestTree.Items.AddChild(FailureNode,
        Format(rsException, [AFailure.ExceptionClassName])) as TMessageTreeNode;
      node.ImageIndex := imgGreenBall;
      node.SelectedIndex := imgGreenBall;
      PaintNodeIgnore(FailureNode);
    end;
  end;

  if not(AFailure.IsIgnoredTest) then
  begin
    Inc(failureCounter);
    if errorCounter = 0 then
      barColor := clFuchsia;
  end;
end;


procedure TGUITestRunner.AddError(ATest: TTest; AError: TTestFailure);
var
  ErrorNode, node: TTreeNode;
  MessageNode: TMessageTreeNode;
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;
    MessageNode.Message := AError.ExceptionMessage;
    MessageNode.ImageIndex := imgWarningSign;
    MessageNode.SelectedIndex := imgWarningSign;
    node := TestTree.Items.AddChild(ErrorNode, Format(rsExceptionCla, [
      AError.ExceptionClassName]));
    node.ImageIndex := imgWarningSign;
    node.SelectedIndex := imgWarningSign;
    if (AError.SourceUnitName <> '') and
      (AError.FailedMethodName <> '')
    then
    begin
      node := TestTree.Items.AddChild(ErrorNode, Format(rsUnitName, [
        AError.SourceUnitName]));
      node.ImageIndex := imgInfoSign;
      node.SelectedIndex := imgInfoSign;
      node := TestTree.Items.AddChild(ErrorNode, Format(rsMethodName, [
        AError.FailedMethodName]));
      node.ImageIndex := imgInfoSign;
      node.SelectedIndex := imgInfoSign;
      node := TestTree.Items.AddChild(ErrorNode, Format(rsLineNumber, [IntToStr(
        AError.LineNumber)]));
      node.ImageIndex := imgInfoSign;
      node.SelectedIndex := imgInfoSign;
    end;
    PaintNodeError(ErrorNode);
  end;
  Inc(errorCounter);
  barColor := clRed;
end;


procedure TGUITestRunner.StartTest(ATest: TTest);
var
  Node: TTreeNode;
begin
  TestTree.BeginUpdate;
  Node := FindNode(ATest);
  Node.DeleteChildren;
  PaintNodeBusy(Node);
  if Node.Level=1 then begin
    Node.MakeVisible;
  end;
  if assigned(Node.Parent) and (Node.Parent.Level=1) then begin
    Node.Parent.MakeVisible;
  end;
  Application.ProcessMessages;
  TestTree.EndUpdate;
end;


procedure TGUITestRunner.EndTest(ATest: TTest);
var
  Node: TTreeNode;
begin
  TestTree.BeginUpdate;
  Inc(testsCounter);
  Node := FindNode(ATest);
  PaintNodeNonFailed(Node);
  pbbar.Refresh;
  Application.ProcessMessages;
  TestTree.EndUpdate;
end;

procedure TGUITestRunner.RunTest(ATest: TTest);
  procedure SkipUncheckedTests(aResult: TTestResult; aNode: TTreeNode);
  var
    i: integer;
  begin
    if (aNode.StateIndex = ord(tsUnChecked)) and (TTest(aNode.Data) is TTestCase) then
      aResult.AddToSkipList(TTest(aNode.Data) as TTestCase);
    for i := 0 to aNode.Count - 1 do
      SkipUncheckedTests(aResult, aNode.Items[i]);
  end;

var
  TestResult:TTestResult;
  w: TXMLResultsWriter;
  m: TMemoryStream;

begin
  SaveTree;
  barcolor := clGreen;
  ResetNodeColors;
  failureCounter := 0;
  errorCounter := 0;
  testsCounter := 0;
  skipsCounter := 0;
  EnableRunActions(false);
  TestResult := TTestResult.Create;
  try
    SkipUncheckedTests(TestResult, TestTree.Selected);
    skipsCounter := TestResult.NumberOfSkippedTests;
    TestResult.AddListener(self);
    pbBar.Invalidate;
    w := TXMLResultsWriter.Create(nil);
    try
      w.FileName := 'null'; // prevents output to the console
      TestResult.AddListener(w);

      MemoLog(Format(rsRunning, [TestTree.Selected.Text]));
      aTest.Run(TestResult);
      MemoLog(Format(rsNumberOfExec, [IntToStr(TestResult.RunTests),
        FormatDateTime('hh:nn:ss.zzz', Now - TestResult.StartingTime)]));

      w.WriteResult(TestResult);
      m := TMemoryStream.Create;
      try
        try
          WriteXMLFile(w.Document, m);
          m.Position := 0;
          XMLSynEdit.Lines.LoadFromStream(m);
        except
          on E: Exception do
            XMLSynEdit.Lines.Text:='WriteXMLFile exception: '+E.ClassName+'/'+E.Message;
        end;
      finally
        m.Free;
      end;
      pbBar.Invalidate;
    finally
      w.Free;
    end;
   finally
    EnableRunActions(true);

    TestResult.Free;
  end;
end;

procedure TGUITestRunner.StartTestSuite(ATestSuite: TTestSuite);
begin
  // do nothing
end;

procedure TGUITestRunner.EndTestSuite(ATestSuite: TTestSuite);
begin
  // scroll treeview to first failed test
  if Assigned(FFirstFailure) then
  begin
    TestTree.Selected := FFirstFailure;
    TestTree.MakeSelectionVisible;
  end;
end;

procedure TranslateResStrings;
var
  Lang, FallbackLang, S: String;

begin
  GetLanguageIDs(Lang,FallbackLang); // in unit gettext
  S:=AppendPathDelim(AppendPathDelim(ExtractFileDir(ParamStr(0))) + 'languages');
  if FallbackLang = 'pt' then
     Lang := 'pb';
  TranslateUnitResourceStrings('guitestrunner',S+'guitestrunner.%s.po', Lang,FallbackLang);
end;

initialization
  TranslateResStrings;

end.

guitestrunner.pas (26,511 bytes)

Serguei Tarassov

2015-04-07 15:29

reporter  

guitestrunner.lfm (109,656 bytes)

Juha Manninen

2015-04-07 17:08

developer   ~0082697

> ... so I cannot make the patch ...
Yes you can. I wrote the syntax for you earlier. Here it is again :
 $ svn diff /components/fpcunit/guitestrunner.lfm /components/fpcunit/guitestrunner.pas > guitestrunner.patch

Wiki instructions :
  http://wiki.freepascal.org/Creating_A_Patch

Serguei Tarassov

2015-04-08 14:43

reporter   ~0082713

Juha, suppose that I know to use diff :)

Is it not more simple to "replace and commit" with these 2 files instead to "apply the patch and commit" ?

Serguei Tarassov

2015-04-08 14:53

reporter   ~0082714

I precise: these 2 files are of trunk, they merged manually with my modifications of 1.2.6 and then I changed some code.
So the diff is against the 48679 version of trunk...

Serguei Tarassov

2015-04-08 14:53

reporter  

guitestrunner.pas.48679.patch (3,317 bytes)
Index: /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas
===================================================================
--- /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas	(revision 48679)
+++ /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas	(working copy)
@@ -20,6 +20,7 @@
     Graeme Geldenhuys <graemeg@gmail.com>
     Darius Blaszijk <dhkblaszyk@zeelandnet.nl>
     Reinier Olislagers <reinierolislagers@gmail.com>
+    Serguei Tarassov <serge@arbinada.com>
 }
 
 unit GuiTestRunner;
@@ -121,6 +122,7 @@
     FINI: TINIFile;
     procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
     function  FindNode(aTest: TTest): TTreeNode;
+    function MakeTestPath(Node: TTreeNode): string;
     procedure ResetNodeColors;
     procedure PaintNodeError(aNode: TTreeNode);
     procedure PaintNodeFailure(aNode: TTreeNode);
@@ -129,6 +131,8 @@
     procedure PaintNodeBusy(aNode: TTreeNode);
     procedure MemoLog(LogEntry: string);
     procedure EnableRunActions(AValue: boolean);
+    procedure RestoreTree;
+    procedure SaveTree;
   public
     procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
     procedure AddError(ATest: TTest; AError: TTestFailure);
@@ -173,7 +177,7 @@
   sactCheckAll = 'Check all Tests';
   sactUncheckAll = 'Uncheck all tests';
   sactRunHighlightedTest = 'Run highlighted test';
-  smiRunTest = '  &Run all selected (checked) tests';
+  smiRunTest = '&Run all selected (checked) tests';
   smiShowfail= 'Copy message to clipboard';
   smiCopy = '&Copy';
   smiCut = 'C&ut';
@@ -186,6 +190,7 @@
 uses
   xmlwrite
   ;
+
 const
   // TestTreeImageList indexes:
   imgGreenBall = 0; //success result
@@ -236,12 +241,42 @@
   XMLSynEdit.Lines.Clear;
 end;
 
+function TGUITestRunner.MakeTestPath(Node: TTreeNode): string;
+begin
+  Result := '';
+  while Node <> nil do
+  begin
+    Result := Node.Text + '_' + Result;
+    Node := Node.Parent;
+  end;
+end;
+
+procedure TGUITestRunner.SaveTree;
+var
+  i: integer;
+begin
+  for i := 0 to TestTree.Items.Count - 1 do
+    FINI.WriteBool('Tests', MakeTestPath(TestTree.Items[i]), TestTree.Items[i].StateIndex = Ord(tsChecked));
+end;
+
+procedure TGUITestRunner.RestoreTree;
+var
+  i: integer;
+begin
+  for i := 0 to TestTree.Items.Count - 1 do
+    if FINI.ReadBool('Tests', MakeTestPath(TestTree.Items[i]), true) then
+      TestTree.Items[i].StateIndex := Ord(tsChecked)
+    else
+      TestTree.Items[i].StateIndex := Ord(tsUnChecked);
+end;
+
 procedure TGUITestRunner.GUITestRunnerCreate(Sender: TObject);
 begin
   barColor := clGreen;
   TestTree.Items.Clear;
   BuildTree(TestTree.Items.AddObject(nil, rsAllTests, GetTestRegistry),
     GetTestRegistry);
+  RestoreTree;
   PageControl1.ActivePage := tsTestTree;
   //
   BtnRun.Caption:= sbtnRun;
@@ -272,7 +307,7 @@
     TestTree.Items[0].Expand(False);
   end;
 
-  FINI := TINIFile.Create(ExtractFileNameOnly(ParamStr(0))+ '.ini');
+  FINI := TINIFile.Create(ExtractFileNameOnly(ParamStr(0)) + '.fpcunit.ini'); // Prevent ini file names conflict if tests are embedded in application
 end;
 
 procedure TGUITestRunner.RunExecute(Sender: TObject);
@@ -820,6 +855,7 @@
   m: TMemoryStream;
 
 begin
+  SaveTree;
   barcolor := clGreen;
   ResetNodeColors;
   failureCounter := 0;

Serguei Tarassov

2015-04-08 14:53

reporter  

guitestrunner.lfm.48679.patch (1,428 bytes)
Index: /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm
===================================================================
--- /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm	(revision 48679)
+++ /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm	(working copy)
@@ -1850,16 +1850,22 @@
     top = 176
     object RunAction: TAction
       Category = 'Run'
-      Caption = '  &Run'
+      Caption = '&Run'
       Hint = 'Run all checked test(s)'
       ImageIndex = 3
       OnExecute = RunExecute
+      SecondaryShortCuts.Strings = (
+        'F9'
+      )
       ShortCut = 16466
     end
     object ActCloseForm: TAction
       Caption = 'Quit'
       Hint = 'Quit Testing'
       OnExecute = ActCloseFormExecute
+      SecondaryShortCuts.Strings = (
+        'Esc'
+      )
       ShortCut = 16451
     end
     object actCopyErrorMsg: TAction
@@ -1897,6 +1903,7 @@
       ImageIndex = 4
       OnExecute = ActRunHighlightedTestExecute
       OnUpdate = ActRunHighLightedTestUpdate
+      ShortCut = 119
     end
   end
   object PopupMenu3: TPopupMenu
@@ -1905,7 +1912,8 @@
     top = 240
     object miRunTest: TMenuItem
       Action = RunAction
-      Caption = '  &Run all selected (checked) tests'
+      Caption = '&Run all selected (checked) tests'
+      ShortCutKey2 = 120
       OnClick = RunExecute
     end
     object MenuItem4: TMenuItem

Juha Manninen

2015-04-08 21:44

developer   ~0082723

Last edited: 2015-04-08 21:45

View 2 revisions

This time I was able to apply your patches using "patch -p6".
Your code does not work at all. A new unit test application crashes immediately. I think you have not tested your code!
Does not look very good. :(

Serguei Tarassov

2015-04-09 09:40

reporter   ~0082733

Juha,
as you can read in header of this issue, I'm working with modified version every day. And you can read also that I'm working with 1.2.6 (first 2 patches are attached for it).

If you need my code working in trunk, please, do a little effort and adapt it yourself.

Juha Manninen

2015-04-09 10:09

developer   ~0082737

Dear s_tarassov, if you want to participate in Lazarus development you must use the development version (trunk) from SVN. It is not a matter of preference or matter of opinion, all development by definition happens in trunk.

Basically there are just 2 rules for contributors :
1. Use SVN trunk.
2. Create patches against it.

There are clear instructions for both :
 http://wiki.freepascal.org/Getting_Lazarus
 http://wiki.freepascal.org/Creating_A_Patch

Serguei Tarassov

2015-04-09 10:56

reporter  

guitestrunner.lfm.48684.patch (1,428 bytes)
Index: /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm
===================================================================
--- /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm	(revision 48684)
+++ /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.lfm	(working copy)
@@ -1850,16 +1850,22 @@
     top = 176
     object RunAction: TAction
       Category = 'Run'
-      Caption = '  &Run'
+      Caption = '&Run'
       Hint = 'Run all checked test(s)'
       ImageIndex = 3
       OnExecute = RunExecute
+      SecondaryShortCuts.Strings = (
+        'F9'
+      )
       ShortCut = 16466
     end
     object ActCloseForm: TAction
       Caption = 'Quit'
       Hint = 'Quit Testing'
       OnExecute = ActCloseFormExecute
+      SecondaryShortCuts.Strings = (
+        'Esc'
+      )
       ShortCut = 16451
     end
     object actCopyErrorMsg: TAction
@@ -1897,6 +1903,7 @@
       ImageIndex = 4
       OnExecute = ActRunHighlightedTestExecute
       OnUpdate = ActRunHighLightedTestUpdate
+      ShortCut = 119
     end
   end
   object PopupMenu3: TPopupMenu
@@ -1905,7 +1912,8 @@
     top = 240
     object miRunTest: TMenuItem
       Action = RunAction
-      Caption = '  &Run all selected (checked) tests'
+      Caption = '&Run all selected (checked) tests'
+      ShortCutKey2 = 120
       OnClick = RunExecute
     end
     object MenuItem4: TMenuItem

Serguei Tarassov

2015-04-09 10:56

reporter  

guitestrunner.pas.48684.patch (4,916 bytes)
Index: /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas
===================================================================
--- /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas	(revision 48684)
+++ /home/serge/Projects/lazarus/trunk/components/fpcunit/guitestrunner.pas	(working copy)
@@ -20,6 +20,7 @@
     Graeme Geldenhuys <graemeg@gmail.com>
     Darius Blaszijk <dhkblaszyk@zeelandnet.nl>
     Reinier Olislagers <reinierolislagers@gmail.com>
+    Serguei Tarassov <serge@arbinada.com>
 }
 
 unit GuiTestRunner;
@@ -118,9 +119,10 @@
     barColor: TColor;
     testSuite: TTest;
     FFirstFailure: TTreeNode; // reference to first failed test
-    FINI: TINIFile;
+    FConfStore: TIniFile;
     procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
     function  FindNode(aTest: TTest): TTreeNode;
+    function MakeTestPath(Node: TTreeNode): string;
     procedure ResetNodeColors;
     procedure PaintNodeError(aNode: TTreeNode);
     procedure PaintNodeFailure(aNode: TTreeNode);
@@ -129,6 +131,8 @@
     procedure PaintNodeBusy(aNode: TTreeNode);
     procedure MemoLog(LogEntry: string);
     procedure EnableRunActions(AValue: boolean);
+    procedure RestoreTree;
+    procedure SaveTree;
   public
     procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
     procedure AddError(ATest: TTest; AError: TTestFailure);
@@ -173,7 +177,7 @@
   sactCheckAll = 'Check all Tests';
   sactUncheckAll = 'Uncheck all tests';
   sactRunHighlightedTest = 'Run highlighted test';
-  smiRunTest = '  &Run all selected (checked) tests';
+  smiRunTest = '&Run all selected (checked) tests';
   smiShowfail= 'Copy message to clipboard';
   smiCopy = '&Copy';
   smiCut = 'C&ut';
@@ -186,6 +190,7 @@
 uses
   xmlwrite
   ;
+
 const
   // TestTreeImageList indexes:
   imgGreenBall = 0; //success result
@@ -236,12 +241,43 @@
   XMLSynEdit.Lines.Clear;
 end;
 
+function TGUITestRunner.MakeTestPath(Node: TTreeNode): string;
+begin
+  Result := '';
+  while Node <> nil do
+  begin
+    Result := Node.Text + '_' + Result;
+    Node := Node.Parent;
+  end;
+end;
+
+procedure TGUITestRunner.SaveTree;
+var
+  i: integer;
+begin
+  for i := 0 to TestTree.Items.Count - 1 do
+    FConfStore.WriteBool('Tests', MakeTestPath(TestTree.Items[i]), TestTree.Items[i].StateIndex = Ord(tsChecked));
+end;
+
+procedure TGUITestRunner.RestoreTree;
+var
+  i: integer;
+begin
+  for i := 0 to TestTree.Items.Count - 1 do
+    if FConfStore.ReadBool('Tests', MakeTestPath(TestTree.Items[i]), true) then
+      TestTree.Items[i].StateIndex := Ord(tsChecked)
+    else
+      TestTree.Items[i].StateIndex := Ord(tsUnChecked);
+end;
+
 procedure TGUITestRunner.GUITestRunnerCreate(Sender: TObject);
 begin
+  FConfStore := TIniFile.Create(ExtractFileNameOnly(ParamStr(0)) + '.fpcunit.ini'); // Prevent ini file names conflict if tests are embedded in application
   barColor := clGreen;
   TestTree.Items.Clear;
   BuildTree(TestTree.Items.AddObject(nil, rsAllTests, GetTestRegistry),
     GetTestRegistry);
+  RestoreTree;
   PageControl1.ActivePage := tsTestTree;
   //
   BtnRun.Caption:= sbtnRun;
@@ -271,8 +307,6 @@
     TestTree.Items.SelectOnlyThis(TestTree.Items[0]);
     TestTree.Items[0].Expand(False);
   end;
-
-  FINI := TINIFile.Create(ExtractFileNameOnly(ParamStr(0))+ '.ini');
 end;
 
 procedure TGUITestRunner.RunExecute(Sender: TObject);
@@ -349,11 +383,11 @@
 procedure TGUITestRunner.FormDestroy(Sender: TObject);
 begin
   // store window position and size
-  FINI.WriteInteger('WindowState', 'Left', Left);
-  FINI.WriteInteger('WindowState', 'Top', Top);
-  FINI.WriteInteger('WindowState', 'Width', Width);
-  FINI.WriteInteger('WindowState', 'Height', Height);
-  FINI.Free;
+  FConfStore.WriteInteger('WindowState', 'Left', Left);
+  FConfStore.WriteInteger('WindowState', 'Top', Top);
+  FConfStore.WriteInteger('WindowState', 'Width', Width);
+  FConfStore.WriteInteger('WindowState', 'Height', Height);
+  FConfStore.Free;
 end;
 
 procedure TGUITestRunner.GUITestRunnerShow(Sender: TObject);
@@ -361,10 +395,10 @@
   if (ParamStrUTF8(1) = '--now') or (ParamStrUTF8(1) = '-n') then
     RunExecute(Self);
   // restore last used position and size
-  Left := FINI.ReadInteger('WindowState', 'Left', Left);
-  Top := FINI.ReadInteger('WindowState', 'Top', Top);
-  Width := FINI.ReadInteger('WindowState', 'Width', Width);
-  Height := FINI.ReadInteger('WindowState', 'Height', Height);
+  Left := FConfStore.ReadInteger('WindowState', 'Left', Left);
+  Top := FConfStore.ReadInteger('WindowState', 'Top', Top);
+  Width := FConfStore.ReadInteger('WindowState', 'Width', Width);
+  Height := FConfStore.ReadInteger('WindowState', 'Height', Height);
 end;
 
 procedure TGUITestRunner.MenuItem3Click(Sender: TObject);
@@ -820,6 +854,7 @@
   m: TMemoryStream;
 
 begin
+  SaveTree;
   barcolor := clGreen;
   ResetNodeColors;
   failureCounter := 0;

Serguei Tarassov

2015-04-09 10:57

reporter   ~0082738

Patches against 48684 added

Juha Manninen

2015-04-09 15:58

developer   ~0082752

Applied, thanks.

I still had to use "patch -p6" to apply it.
I don't know why you still made two separate patches although I explained how to make just one.

Issue History

Date Modified Username Field Change
2015-04-01 11:03 Serguei Tarassov New Issue
2015-04-01 20:12 Juha Manninen Note Added: 0082536
2015-04-03 11:02 Serguei Tarassov File Added: guitestrunner.lfm.patch
2015-04-03 11:03 Serguei Tarassov File Added: guitestrunner.pas.patch
2015-04-03 11:05 Serguei Tarassov Note Added: 0082561
2015-04-03 11:10 Juha Manninen Assigned To => Juha Manninen
2015-04-03 11:10 Juha Manninen Status new => assigned
2015-04-06 11:07 Juha Manninen LazTarget => -
2015-04-06 11:07 Juha Manninen Note Added: 0082651
2015-04-06 11:07 Juha Manninen Status assigned => feedback
2015-04-06 11:11 Juha Manninen Note Edited: 0082651 View Revisions
2015-04-06 11:13 Juha Manninen Note Edited: 0082651 View Revisions
2015-04-07 12:18 Serguei Tarassov Note Added: 0082688
2015-04-07 12:18 Serguei Tarassov Status feedback => assigned
2015-04-07 13:23 Zeljan Rikalo Note Added: 0082690
2015-04-07 13:57 Juha Manninen Note Added: 0082691
2015-04-07 15:28 Serguei Tarassov Note Added: 0082696
2015-04-07 15:29 Serguei Tarassov File Added: guitestrunner.pas
2015-04-07 15:29 Serguei Tarassov File Added: guitestrunner.lfm
2015-04-07 17:08 Juha Manninen Note Added: 0082697
2015-04-08 14:43 Serguei Tarassov Note Added: 0082713
2015-04-08 14:53 Serguei Tarassov Note Added: 0082714
2015-04-08 14:53 Serguei Tarassov File Added: guitestrunner.pas.48679.patch
2015-04-08 14:53 Serguei Tarassov File Added: guitestrunner.lfm.48679.patch
2015-04-08 21:44 Juha Manninen Note Added: 0082723
2015-04-08 21:45 Juha Manninen Note Edited: 0082723 View Revisions
2015-04-09 09:40 Serguei Tarassov Note Added: 0082733
2015-04-09 10:09 Juha Manninen Note Added: 0082737
2015-04-09 10:56 Serguei Tarassov File Added: guitestrunner.lfm.48684.patch
2015-04-09 10:56 Serguei Tarassov File Added: guitestrunner.pas.48684.patch
2015-04-09 10:57 Serguei Tarassov Note Added: 0082738
2015-04-09 15:58 Juha Manninen Fixed in Revision => r48686
2015-04-09 15:58 Juha Manninen Note Added: 0082752
2015-04-09 15:58 Juha Manninen Status assigned => resolved
2015-04-09 15:58 Juha Manninen Resolution open => fixed