diff --git a/packages/fcl-fpcunit/src/DUnitCompatibleInterface.inc b/packages/fcl-fpcunit/src/DUnitCompatibleInterface.inc index 6fc47f97ea..09e5bfb600 100644 --- a/packages/fcl-fpcunit/src/DUnitCompatibleInterface.inc +++ b/packages/fcl-fpcunit/src/DUnitCompatibleInterface.inc @@ -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} diff --git a/packages/fcl-fpcunit/src/testregistry.pp b/packages/fcl-fpcunit/src/testregistry.pp index 512bb31506..f5780ca65d 100644 --- a/packages/fcl-fpcunit/src/testregistry.pp +++ b/packages/fcl-fpcunit/src/testregistry.pp @@ -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)));