* Patch from Graeme Geldenhuys to easily add testsuites

git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@7449 3ad0048d-3df7-0310-abae-a5850022a9f2

2 files changed, 83 insertions, 2 deletions

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