* Patch from Graeme Geldenhuys

  * Added support for triggering when a TestSuite starts and ends.
  * Modified all the Test Listeners to support the StartTestSuite and
  EndTestSuite interface methods, but only the XML Listener actually
  uses it at the moment.
  * Created a new directory called 'example_xslt' which contains a
  sample XSLT and CSS file. This shows how I convert the generated XML
  data into a HTML page.  (Grouping of the Tests in TestSuites in the
  Test Listing section will follow shortly.)

git-svn-id: trunk@5430 -

fcl/fpcunit/DUnitCompatibleInterface.inc

@@ -2,11 +2,6 @@
 
 {$IFDEF read_interface}
 
-{
-    function  GetName: string; virtual;
-    property  Name: string read GetName;
-}
-
     class procedure Check(pValue: boolean; pMessage: string = '');
     class procedure CheckEquals(expected, actual: extended; msg: string = ''); overload;
     class procedure CheckEquals(expected, actual: string; msg: string = ''); overload;
@@ -15,26 +10,24 @@
     class procedure CheckEquals(expected, actual: boolean; msg: string = ''); overload;
     class procedure CheckEquals(expected, actual: TClass; msg: string = ''); overload;
     class procedure CheckNotEquals(expected, actual: string; msg: string = ''); overload;
+    class procedure CheckNotEquals(expected, actual: integer; msg: string = ''); overload; virtual;
+    class procedure CheckNotEquals(expected, actual: boolean; msg: string = ''); overload; virtual;
+    class procedure CheckNotEquals(expected: extended; actual: extended; delta: extended = 0; msg: string = ''); overload; virtual;
     class procedure CheckNull(obj: IUnknown; msg: string = ''); overload;
     class procedure CheckNull(obj: TObject; msg: string = ''); overload;
     class procedure CheckNotNull(obj: TObject; msg: string = ''); overload;
     class procedure CheckIs(obj :TObject; pClass: TClass; msg: string = ''); overload;
     class procedure CheckSame(expected, actual: TObject; msg: string = ''); overload;
+    class procedure FailNotEquals(expected, actual: string; msg: string = ''; errorAddr: Pointer = nil); virtual;
+
     {
     *** TODO  ***
     procedure CheckEqualsBin(expected, actual: longword; msg: string = ''; digits: integer=32); virtual;
     procedure CheckEqualsHex(expected, actual: longword; msg: string = ''; digits: integer=8); virtual;
-
-    procedure CheckNotEquals(expected, actual: integer; msg: string = ''); overload; virtual;
-    procedure CheckNotEquals(expected: extended; actual: extended; delta: extended = 0; msg: string = ''); overload; virtual;
-    procedure CheckNotEquals(expected, actual: boolean; msg: string = ''); overload; virtual;
     procedure CheckNotEqualsBin(expected, actual: longword; msg: string = ''; digits: integer=32); virtual;
     procedure CheckNotEqualsHex(expected, actual: longword; msg: string = ''; digits: integer=8); virtual;
-
     procedure CheckNotNull(obj :IUnknown; msg :string = ''); overload; virtual;
     procedure CheckSame(expected, actual: IUnknown; msg: string = ''); overload; virtual;
-
-
     procedure CheckException(AMethod: TTestMethod; AExceptionClass: TClass; msg :string = '');
     procedure CheckInherits(expected, actual: TClass; msg: string = ''); overload; virtual;
     }
@@ -44,81 +37,82 @@
 
 {$IFDEF read_implementation}
 
-{
-function TAssert.GetName: string;
-begin
-  Result := TestName;
-end;
-}
-
 class procedure TAssert.Check(pValue: boolean; pMessage: string);
 begin
   AssertTrue(pMessage, pValue);
 end;
 
-
 class procedure TAssert.CheckEquals(expected, actual: extended; msg: string);
 begin
   AssertEquals(msg, expected, actual);
 end;
 
-
 class procedure TAssert.CheckEquals(expected, actual: string; msg: string);
 begin
   AssertEquals(msg, expected, actual);
 end;
 
-
 class procedure TAssert.CheckEquals(expected, actual: extended;
   delta: extended; msg: string);
 begin
   AssertEquals(msg, expected, actual, delta);
 end;
 
-
 class procedure TAssert.CheckEquals(expected, actual: integer; msg: string);
 begin
   AssertEquals(msg, expected, actual);
 end;
 
-
 class procedure TAssert.CheckEquals(expected, actual: boolean; msg: string);
 begin
   AssertEquals(msg, expected, actual);
 end;
 
-
 class procedure TAssert.CheckEquals(expected, actual: TClass; msg: string);
 begin
   AssertEquals(msg, expected, actual);
 end;
 
-
 class procedure TAssert.CheckNotEquals(expected, actual: string; msg: string);
 begin
   if AnsiCompareStr(Expected, Actual) = 0 then
     Fail(msg + ComparisonMsg(Expected, Actual));
 end;
 
+class procedure TAssert.CheckNotEquals(expected, actual: integer; msg: string);
+begin
+  if (expected = actual) then
+    Fail(msg + ComparisonMsg(IntToStr(expected), IntToStr(actual)));
+end;
+
+class procedure TAssert.CheckNotEquals(expected, actual: boolean; msg: string);
+begin
+  if (expected = actual) then
+    Fail(msg + ComparisonMsg(BoolToStr(expected), BoolToStr(actual)));
+end;
+
+class procedure TAssert.CheckNotEquals(expected: extended; actual: extended;
+  delta: extended; msg: string);
+begin
+  if (abs(expected-actual) <= delta) then
+      FailNotEquals(FloatToStr(expected), FloatToStr(actual), msg, nil);
+end;
 
 class procedure TAssert.CheckNull(obj: IUnknown; msg: string);
 begin
   AssertNullIntf(msg, obj);
 end;
 
-
 class procedure TAssert.CheckNull(obj: TObject; msg: string);
 begin
   AssertNull(msg, obj);
 end;
 
-
 class procedure TAssert.CheckNotNull(obj: TObject; msg: string);
 begin
   AssertNotNull(msg, obj);
 end;
 
-
 class procedure TAssert.CheckIs(obj: TObject; pClass: TClass; msg: string);
 begin
   Assert(pClass <> nil);
@@ -128,11 +122,16 @@ begin
     Fail(ComparisonMsg(pClass.ClassName, obj.ClassName));
 end;
 
-
 class procedure TAssert.CheckSame(expected, actual: TObject; msg: string);
 begin
    AssertSame(msg, expected, actual);
 end;
 
+class procedure TAssert.FailNotEquals(expected, actual: string; msg: string;
+  errorAddr: Pointer);
+begin
+  Fail(msg + ComparisonMsg(Expected, Actual));
+end;
+
 {$ENDIF read_implementation}
 

fcl/fpcunit/fpcunit.pp

@@ -57,6 +57,7 @@ type
   TRunMethod = procedure of object;
 
   TTestResult = class;
+  TTestSuite = class;
 
   {$M+}
   TTest = class(TObject)
@@ -80,6 +81,8 @@ type
   {$M-}
 
 
+  { TAssert }
+
   TAssert = class(TTest)
   public
     class procedure Fail(const AMessage: string);
@@ -170,6 +173,8 @@ type
     procedure AddError(ATest: TTest; AError: TTestFailure);
     procedure StartTest(ATest: TTest);
     procedure EndTest(ATest: TTest);
+    procedure StartTestSuite(ATestSuite: TTestSuite);
+    procedure EndTestSuite(ATestSuite: TTestSuite);
   end;
 
   TTestCase = class(TAssert)
@@ -271,6 +276,8 @@ type
     function SkipTest(ATestCase: TTestCase): boolean;
     procedure AddToSkipList(ATestCase: TTestCase);
     procedure RemoveFromSkipList(ATestCase: TTestCase);
+    procedure StartTestSuite(ATestSuite: TTestSuite);
+    procedure EndTestSuite(ATestSuite: TTestSuite);
   published
     property Listeners: TFPList read FListeners;
     property Failures: TFPList read FFailures;
@@ -1005,8 +1012,14 @@ procedure TTestSuite.Run(AResult: TTestResult);
 var
   i: integer;
 begin
+  if FTests.Count > 0 then
+    AResult.StartTestSuite(self);
+    
   for i := 0 to FTests.Count - 1 do
     RunTest(TTest(FTests[i]), AResult);
+    
+  if FTests.Count > 0 then
+    AResult.EndTestSuite(self);
 end;
 
 
@@ -1247,5 +1260,21 @@ begin
   FSkippedTests.Remove(ATestCase);
 end;
 
+procedure TTestResult.StartTestSuite(ATestSuite: TTestSuite);
+var
+  i: integer;
+begin
+  for i := 0 to FListeners.Count - 1 do
+    ITestListener(FListeners[i]).StartTestSuite(ATestSuite);
+end;
+
+procedure TTestResult.EndTestSuite(ATestSuite: TTestSuite);
+var
+  i: integer;
+begin
+  for i := 0 to FListeners.Count - 1 do
+    ITestListener(FListeners[i]).EndTestSuite(ATestSuite);
+end;
+
 end.
 

fcl/fpcunit/testreport.pp

@@ -22,6 +22,9 @@ uses
   classes, SysUtils, fpcunit, testutils;
 
 type
+
+  { TXMLResultsWriter }
+
   TXMLResultsWriter = class(TNoRefCountObject, ITestListener)
   public
     procedure WriteHeader;
@@ -31,8 +34,12 @@ type
     procedure AddError(ATest: TTest; AError: TTestFailure);
     procedure StartTest(ATest: TTest);
     procedure EndTest(ATest: TTest);
+    procedure StartTestSuite(ATestSuite: TTestSuite);
+    procedure EndTestSuite(ATestSuite: TTestSuite);
   end;
 
+  { TPlainResultsWriter }
+
   TPlainResultsWriter = class(TNoRefCountObject, ITestListener)
   public
     procedure WriteHeader;
@@ -42,6 +49,8 @@ type
     procedure AddError(ATest: TTest; AError: TTestFailure);
     procedure StartTest(ATest: TTest);
     procedure EndTest(ATest: TTest);
+    procedure StartTestSuite(ATestSuite: TTestSuite);
+    procedure EndTestSuite(ATestSuite: TTestSuite);
   end;
 
  {
@@ -51,6 +60,8 @@ type
     procedure AddError(ATest: TTest; AError: TTestFailure);
     procedure StartTest(ATest: TTest);
     procedure EndTest(ATest: TTest);
+    procedure StartTestSuite(ATestSuite: TTestSuite);
+    procedure EndTestSuite(ATestSuite: TTestSuite);
   end;}
 
 function TestSuiteAsXML(aSuite:TTestSuite; Indent : Integer): string;
@@ -106,6 +117,16 @@ begin
   writeln('</test>');
 end;
 
+procedure TXMLResultsWriter.StartTestSuite(ATestSuite: TTestSuite);
+begin
+
+end;
+
+procedure TXMLResultsWriter.EndTestSuite(ATestSuite: TTestSuite);
+begin
+
+end;
+
 {TPlainResultsWriter}
 procedure TPlainResultsWriter.WriteHeader;
 begin
@@ -132,7 +153,7 @@ end;
 
 procedure TPlainResultsWriter.StartTest(ATest: TTest);
 begin
-  write('Test: ' , ATest.TestSuiteName + '.' + ATest.TestName);
+  write('Test: ', ATest.TestSuiteName + '.' + ATest.TestName);
 end;
 
 procedure TPlainResultsWriter.EndTest(ATest: TTest);
@@ -140,6 +161,18 @@ begin
   writeln;
 end;
 
+procedure TPlainResultsWriter.StartTestSuite(ATestSuite: TTestSuite);
+begin
+  { example output }
+//  Writeln('TestSuite: ' + ATestSuite.TestName);
+end;
+
+procedure TPlainResultsWriter.EndTestSuite(ATestSuite: TTestSuite);
+begin
+  { example output }
+//  Writeln('TestSuite: ' + ATestSuite.TestName + ' - END ');
+end;
+
 function TestSuiteAsXML(aSuite:TTestSuite): string;
 
 begin

fcl/fpcunit/xmlreporter.pas

@@ -22,7 +22,7 @@
     framework.  It uses the XMLWrite unit, which is part of FPC, to generate
     the XML document. The benefit of using the XMLWrite unit, is that the
     data generated is valid XML, with resevered characters correctly escaped.
-    This allows the XML document to be further processed with XSTL etc without
+    This allows the XML document to be further processed with XSLT etc without
     any issues.
 
 }
@@ -44,6 +44,9 @@ uses
 
 type
   { XML Test Listner }
+
+  { TXMLResultsWriter }
+
   TXMLResultsWriter = class(TNoRefCountObject, ITestListener)
   private
     FDoc: TXMLDocument;
@@ -53,6 +56,7 @@ type
     FFailures: TDOMNode;
     FIgnores: TDOMNode;
     FErrors: TDOMNode;
+    FLastTestSuite: TDOMNode;
     FStartCrono: TDateTime;
     { Converts the actual test results into XML nodes. This gets called
       by the public method WriteResult. }
@@ -69,7 +73,9 @@ type
     procedure   AddError(ATest: TTest; AError: TTestFailure);
     procedure   StartTest(ATest: TTest);
     procedure   EndTest(ATest: TTest);
-    
+    procedure   StartTestSuite(ATestSuite: TTestSuite);
+    procedure   EndTestSuite(ATestSuite: TTestSuite);
+
     { A public property to the internal XML document }
     property    Document: TXMLDocument read FDoc;
   end;
@@ -125,18 +131,25 @@ end;
 
 constructor TXMLResultsWriter.Create;
 begin
-  FDoc        := TXMLDocument.Create;
-  FResults    := nil;
-  FFailures   := nil;
-  FIgnores    := nil;
-  FErrors     := nil;
-  FListing    := nil;
+  FDoc            := TXMLDocument.Create;
+  FResults        := nil;
+  FFailures       := nil;
+  FIgnores        := nil;
+  FErrors         := nil;
+  FListing        := nil;
+  FLastTestSuite  := nil;
   WriteHeader;
 end;
 
 
 destructor TXMLResultsWriter.Destroy;
 begin
+  FResults        := nil;
+  FFailures       := nil;
+  FIgnores        := nil;
+  FErrors         := nil;
+  FListing        := nil;
+  FLastTestSuite  := nil;
   FDoc.Free;
   inherited Destroy;
 end;
@@ -218,19 +231,9 @@ procedure TXMLResultsWriter.StartTest(ATest: TTest);
 var
   n: TDOMElement;
 begin
-  { Try and find the Listings node first }
-  if not Assigned(FListing) then
-    FListing := FDoc.FindNode('TestListing');
-  { If we couldn't find it, create it }
-  if not Assigned(FListing) then
-  begin
-    FListing := FDoc.CreateElement('TestListing');
-    FResults.AppendChild(FListing);
-  end;
-
   n := FDoc.CreateElement('Test');
   n['Name'] := ATest.TestSuiteName + '.' + ATest.TestName;
-  FListing.AppendChild(n);
+  FLastTestSuite.AppendChild(n);
   FStartCrono := Now;
 end;
 
@@ -239,6 +242,16 @@ procedure TXMLResultsWriter.EndTest(ATest: TTest);
 var
   n: TDOMNode;
   lNew: TDOMElement;
+begin
+  n := FLastTestSuite.LastChild;
+  lNew := FDoc.CreateElement('ElapsedTime');
+  lNew.AppendChild(FDoc.CreateTextNode(FormatDateTime('hh:nn:ss.zzz', Now - FStartCrono)));
+  n.AppendChild(lNew);
+end;
+
+procedure TXMLResultsWriter.StartTestSuite(ATestSuite: TTestSuite);
+var
+  n: TDOMElement;
 begin
   { Try and find the Listings node first }
   if not Assigned(FListing) then
@@ -250,10 +263,19 @@ begin
     FResults.AppendChild(FListing);
   end;
 
-  n := FListing.LastChild;
-  lNew := FDoc.CreateElement('ElapsedTime');
-  lNew.AppendChild(FDoc.CreateTextNode(FormatDateTime('hh:nn:ss.zzz', Now - FStartCrono)));
-  n.AppendChild(lNew);
+  { The first TestSuite always seem to be blank/empty }
+  if ATestSuite.TestName <> '' then
+  begin
+    n := FDoc.CreateElement('TestSuite');
+    n['Name'] := ATestSuite.TestName;
+    FListing.AppendChild(n);
+    FLastTestSuite := n;
+  end;
+end;
+
+procedure TXMLResultsWriter.EndTestSuite(ATestSuite: TTestSuite);
+begin
+  // do nothing
 end;