fpcunit gui testrunner: added checkboxes to create adhoc test suites from Dean Zobec

git-svn-id: trunk@9957 -

components/fpcunit/guitestrunner.pas

@@ -52,7 +52,19 @@ type
     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;
@@ -65,8 +77,6 @@ type
     BtnClose: TBitBtn;
     ImageList1: TImageList;
     ImageList2: TImageList;
-    Label1: TLabel;
-    lblSelectedTest: TLabel;
     MenuItem1: TMenuItem;
     MenuItem2: TMenuItem;
     MenuItem3: TMenuItem;
@@ -83,12 +93,19 @@ type
     tsTestTree: TTabSheet;
     tsResultsXML: TTabSheet;
     XMLSynEdit: TSynEdit;
+    procedure ActCheckAllExecute(Sender: TObject);
+    procedure ActCheckCurrentSuiteExecute(Sender: TObject);
     procedure ActCloseFormExecute(Sender: TObject);
-    procedure RunActionUpdate(Sender: TObject);
+    procedure ActRunHighlightedTestExecute(Sender: TObject);
+    procedure ActUncheckAllExecute(Sender: TObject);
+    procedure ActRunHighLightedTestUpdate(Sender: TObject);
+    procedure ActUncheckCurrentSuiteExecute(Sender: TObject);
     procedure RunExecute(Sender: TObject);
     procedure GUITestRunnerCreate(Sender: TObject);
     procedure GUITestRunnerShow(Sender: TObject);
     procedure MenuItem3Click(Sender: TObject);
+    procedure TestTreeMouseDown(Sender: TOBject; Button: TMouseButton;
+      Shift: TShiftState; X, Y: Integer);
     procedure TestTreeSelectionChanged(Sender: TObject);
     procedure actCopyErrorMsgExecute(Sender: TObject);
     procedure actCopyErrorMsgUpdate(Sender: TObject);
@@ -99,6 +116,7 @@ type
     failureCounter: Integer;
     errorCounter: Integer;
     testsCounter: Integer;
+    skipsCounter: Integer;
     barColor: TColor;
     testSuite: TTest;
     procedure BuildTree(rootNode: TTreeNode; aSuite: TTestSuite);
@@ -114,6 +132,7 @@ type
     procedure AddError(ATest: TTest; AError: TTestFailure);
     procedure StartTest(ATest: TTest);
     procedure EndTest(ATest: TTest);
+    procedure RunTest(ATest: TTest);
   end;
 
 var
@@ -128,6 +147,10 @@ uses
   ;
 {$ENDIF}
 
+type
+
+  TTreeNodeState=(tsUnChecked, tsChecked);
+
 { TGUITestRunner }
 
 procedure TGUITestRunner.actCopyExecute(Sender: TObject);
@@ -153,67 +176,10 @@ end;
 
 
 procedure TGUITestRunner.RunExecute(Sender: TObject);
-var
-  testResult:TTestResult;
-  FStopCrono: TDateTime;
-  FStartCrono: TDateTime;
-  {$IFNDEF UseOldXML}
-    w: TXMLResultsWriter;
-    m: TMemoryStream;
-  {$ENDIF}
 begin
-  barcolor := clGreen;
-  ResetNodeColors;
-
-  if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then
-  begin
-    testSuite := TTest(TestTree.Selected.Data);
-    TestTree.Selected.Expand(false);
-  end
-  else
-    begin
-      testSuite := GetTestRegistry;
-      TestTree.Selected := TestTree.Items[0];
-    end;
-  failureCounter := 0;
-  errorCounter := 0;
-  testsCounter := 0;
-  testResult := TTestResult.Create;
-  try
-    testResult.AddListener(self);
-    {$IFNDEF UseOldXML}
-    w := TXMLResultsWriter.Create;
-    TestResult.AddListener(w);
-    {$ENDIF}
-    MemoLog('Running ' + TestTree.Selected.Text);
-    FStartCrono := Now;
-    testSuite.Run(testResult);
-    FStopCrono := Now;
-    // In the next fpc (post 2.0.4) we can pull the time from the TestResult
-    MemoLog('Number of executed tests: ' + IntToStr(testResult.RunTests)
-        + '  Time elapsed: '
-        + FormatDateTime('hh:nn:ss.zzz', FStopCrono - FStartCrono));
-    
-    {$IFNDEF UseOldXML}
-      w.WriteResult(testResult);
-      m := TMemoryStream.Create;
-      WriteXMLFile(w.Document, m);
-      m.Position := 0;
-      XMLSynEdit.Lines.LoadFromStream(m);
-    {$ELSE}
-      XMLSynEdit.lines.text :=  '<TestResults>' + system.sLineBreak +
-      TestResultAsXML(testResult) + system.sLineBreak + '</TestResults>';
-    {$ENDIF}
-
-    pbBar.Invalidate;
-    pbBar1.Invalidate;
-   finally
-    {$IFNDEF UseOldXML}
-      m.free;
-      w.Free;
-    {$ENDIF}
-    testResult.Free;
-  end;
+  testSuite := GetTestRegistry;
+  TestTree.Selected := TestTree.Items[0];
+  RunTest(testSuite);
 end;
 
 
@@ -222,11 +188,61 @@ 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.RunActionUpdate(Sender: TObject);
+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
+  if (TestTree.Selected <> nil) and (TestTree.Selected.Data <> nil) then
+  begin
+    testSuite := TTest(TestTree.Selected.Data);
+    TestTree.Selected.Expand(false);
+  end;
+  RunTest(testSuite);
+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)) or (not TestTree.Focused);
+    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;
 
 
@@ -242,14 +258,55 @@ begin
   Clipboard.AsText := Memo1.Lines.Text;
 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
-    lblSelectedTest.Caption := (Sender as TTreeview).Selected.Text
+  begin
+    btnRunHighlighted.Visible := true;
+    btnRunHighlighted.Caption := 'Run ' + (Sender as TTreeview).Selected.Text;
+  end
   else
-    lblSelectedTest.Caption := '';
+    begin
+      btnRunHighlighted.Visible := false;
+      btnRunHighlighted.Caption := '';
+    end;
 end;
 
 
@@ -285,8 +342,8 @@ begin
       Canvas.Brush.Color := barColor;
       if TestsCounter <> 0 then
       begin
-        Canvas.Rectangle(0, 0, round(TestsCounter / alltests * Width), Height);
-        msg := 'Runs: ' + IntToStr(TestsCounter) + '/' + IntToStr(alltests);
+        Canvas.Rectangle(0, 0, round(TestsCounter / (alltests - skipsCounter) * Width), Height);
+        msg := 'Runs: ' + IntToStr(TestsCounter) + '/' + IntToStr(alltests - skipsCounter);
         msg := msg + '    Errors: ' + IntToStr(ErrorCounter);
         msg := msg + '     Failures: ' + IntToStr(FailureCounter);
         Canvas.Textout(10, 10,  msg)
@@ -302,6 +359,7 @@ 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]);
@@ -312,6 +370,7 @@ begin
         BuildTree(Node, TTestSuite(TTestDecorator(ASuite.Test[i]).Test));
     node.ImageIndex := 12;
     node.SelectedIndex := 12;
+    node.StateIndex := ord(tsChecked);
   end;
   rootNode.Expand(False);
   ResetNodeColors;
@@ -522,6 +581,72 @@ begin
   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;
+  FStopCrono: TDateTime;
+  FStartCrono: TDateTime;
+  {$IFNDEF UseOldXML}
+    w: TXMLResultsWriter;
+    m: TMemoryStream;
+  {$ENDIF}
+
+begin
+  barcolor := clGreen;
+  ResetNodeColors;
+  failureCounter := 0;
+  errorCounter := 0;
+  testsCounter := 0;
+  skipsCounter := 0;
+  testResult := TTestResult.Create;
+  try
+    SkipUncheckedTests(testResult, TestTree.Selected);
+    skipsCounter := testResult.NumberOfSkippedTests;
+    testResult.AddListener(self);
+    {$IFNDEF UseOldXML}
+    w := TXMLResultsWriter.Create;
+    testResult.AddListener(w);
+    {$ENDIF}
+    MemoLog('Running ' + TestTree.Selected.Text);
+    FStartCrono := Now;
+    aTest.Run(testResult);
+    FStopCrono := Now;
+    // In the next fpc (post 2.0.4) we can pull the time from the TestResult
+    MemoLog('Number of executed tests: ' + IntToStr(testResult.RunTests)
+      + '  Time elapsed: '
+      + FormatDateTime('hh:nn:ss.zzz', FStopCrono - FStartCrono));
+    {$IFNDEF UseOldXML}
+      w.WriteResult(testResult);
+      m := TMemoryStream.Create;
+      WriteXMLFile(w.Document, m);
+      m.Position := 0;
+      XMLSynEdit.Lines.LoadFromStream(m);
+    {$ELSE}
+      XMLSynEdit.lines.text := '<TestResults>' + system.sLineBreak +
+      TestResultAsXML(testResult) + system.sLineBreak + '</TestResults>';
+    {$ENDIF}
+
+    pbBar.Invalidate;
+    pbBar1.Invalidate;
+   finally
+    {$IFNDEF UseOldXML}
+      m.free;
+      w.Free;
+    {$ENDIF}
+    testResult.Free;
+  end;
+end;
+
 initialization
   {$I guitestrunner.lrs}