From dee22e8b4aefadbdcd6790225e0ac8ec80ccdaa6 Mon Sep 17 00:00:00 2001 From: michael Date: Mon, 20 Nov 2006 08:23:55 +0000 Subject: [PATCH] * 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 | 59 ++++++++++---------- fcl/fpcunit/fpcunit.pp | 29 ++++++++++ fcl/fpcunit/testreport.pp | 35 +++++++++++- fcl/fpcunit/xmlreporter.pas | 68 ++++++++++++++++-------- 4 files changed, 137 insertions(+), 54 deletions(-) diff --git a/fcl/fpcunit/DUnitCompatibleInterface.inc b/fcl/fpcunit/DUnitCompatibleInterface.inc index b3d85110dd..6fc47f97ea 100644 --- a/fcl/fpcunit/DUnitCompatibleInterface.inc +++ b/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} diff --git a/fcl/fpcunit/fpcunit.pp b/fcl/fpcunit/fpcunit.pp index a3ea997699..5959f26c36 100644 --- a/fcl/fpcunit/fpcunit.pp +++ b/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. diff --git a/fcl/fpcunit/testreport.pp b/fcl/fpcunit/testreport.pp index 6216e2afc9..9612f00b8c 100644 --- a/fcl/fpcunit/testreport.pp +++ b/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(''); 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 diff --git a/fcl/fpcunit/xmlreporter.pas b/fcl/fpcunit/xmlreporter.pas index 8c9fb36a87..63a2ba33d2 100644 --- a/fcl/fpcunit/xmlreporter.pas +++ b/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;