paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-11 13:09:43 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Graeme Geldenhuys to easily add testsuites

Browse Source 
git-svn-id: trunk@7449 -
This commit is contained in:
michael 2007-05-24 08:47:09 +00:00
parent cf19c0993a
commit 2207d159d7
2 changed files with 83 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
packages/fcl-fpcunit/src/DUnitCompatibleInterface.inc
View File

@ -20,6 +20,8 @@
class procedure CheckSame(expected, actual: TObject; msg: string = ''); overload;
class procedure FailNotEquals(expected, actual: string; msg: string = ''; errorAddr: Pointer = nil); virtual;
class function Suite: TTest;
{
*** TODO ***
procedure CheckEqualsBin(expected, actual: longword; msg: string = ''; digits: integer=32); virtual;
@ -133,5 +135,10 @@ begin
Fail(msg + ComparisonMsg(Expected, Actual));
end;
class function TAssert.Suite: TTest;
begin
result := TTestSuite.Create(self);
end;
{$ENDIF read_implementation}

78
packages/fcl-fpcunit/src/testregistry.pp
View File

@ -1,5 +1,3 @@
{$mode objfpc}
{$h+}
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2004 by Dean Zobec, Michael Van Canneyt
@ -16,6 +14,9 @@
**********************************************************************}
unit testregistry;
{$mode objfpc}
{$h+}
interface
uses
@ -27,6 +28,8 @@ type
procedure RegisterTest(ATestClass: TTestCaseClass); overload;
procedure RegisterTest(ASuitePath: String; ATestClass: TTestCaseClass); overload;
procedure RegisterTest(ASuitePath: String; ATest: TTest); overload;
procedure RegisterTests(ATests: Array of TTestCaseClass);
@ -37,6 +40,9 @@ function NumberOfRegisteredTests: longint;
function GetTestRegistry: TTestSuite;
implementation
uses
Classes
;
var
FTestRegistry: TTestSuite;
@ -48,11 +54,79 @@ begin
Result := FTestRegistry;
end;
procedure RegisterTestInSuite(ARootSuite: TTestSuite; APath: string; ATest: TTest);
var
i: Integer;
lTargetSuite: TTestSuite;
lCurrentTest: TTest;
lSuiteName: String;
lPathRemainder: String;
lDotPos: Integer;
lTests: TFPList;
begin
if APath = '' then
begin
// end recursion
ARootSuite.AddTest(ATest);
end
else
begin
// Split the path on the dot (.)
lDotPos := Pos('.', APath);
if (lDotPos <= 0) then lDotPos := Pos('\', APath);
if (lDotPos <= 0) then lDotPos := Pos('/', APath);
if (lDotPos > 0) then
begin
lSuiteName := Copy(APath, 1, lDotPos - 1);
lPathRemainder := Copy(APath, lDotPos + 1, length(APath) - lDotPos);
end
else
begin
lSuiteName := APath;
lPathRemainder := '';
end;
// Check to see if the path already exists
lTargetSuite := nil;
lTests := ARootSuite.Tests;
for i := 0 to lTests.Count -1 do
begin
lCurrentTest := TTest(lTests[i]);
if lCurrentTest is TTestSuite then
begin
if (lCurrentTest.TestName = lSuiteName) then
begin
lTargetSuite := TTestSuite(lCurrentTest);
break;
end;
end; { if }
end; { for }
if not Assigned(lTargetSuite) then
begin
lTargetSuite := TTestSuite.Create(lSuiteName);
ARootSuite.AddTest(lTargetSuite);
end;
RegisterTestInSuite(lTargetSuite, lPathRemainder, ATest);
end; { if/else }
end;
procedure RegisterTest(ATestClass: TTestCaseClass);
begin
GetTestRegistry.AddTestSuiteFromClass(ATestClass);
end;
procedure RegisterTest(ASuitePath: String; ATestClass: TTestCaseClass);
begin
RegisterTestInSuite(GetTestRegistry, ASuitePath, TTestSuite.Create(ATestClass));
end;
procedure RegisterTest(ASuitePath: String; ATest: TTest);
begin
RegisterTestInSuite(GetTestRegistry, ASuitePath, ATest);
end;
procedure RegisterTestDecorator(ADecoratorClass: TTestDecoratorClass; ATestClass: TTestCaseClass);
begin
GetTestRegistry.AddTest(ADecoratorClass.Create(TTestSuite.Create(ATestClass)));