paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 06:19:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Graeme Geldenhuys

Browse Source 
* 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 -
This commit is contained in:
michael 2006-11-20 08:23:55 +00:00
parent 2b7fb31a9e
commit dee22e8b4a
4 changed files with 137 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
fcl/fpcunit/DUnitCompatibleInterface.inc
View File

@ -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}

29
fcl/fpcunit/fpcunit.pp
View File

@ -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.

35
fcl/fpcunit/testreport.pp
View File

@ -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

68
fcl/fpcunit/xmlreporter.pas
View File

@ -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;