* Rework test tree construction, finding tests (bug ID 30384)

git-svn-id: trunk@34473 -

packages/fcl-fpcunit/src/consoletestrunner.pas

@@ -314,60 +314,11 @@ end;
 procedure TTestRunner.DoRun;
 
 
-  procedure CheckTestRegistry (test:TTest; ATestName:string; res : TTestSuite);
-  var s, c : string;
-      I, p : integer;
-      ds : TTestSuite;
-      D : TTestDecorator;
-
-  begin
-    if (test is TTestSuite) or (test is TTestDecorator) then
-      begin
-      p := pos ('.', ATestName);
-      if p > 0 then
-        begin
-        s := copy (ATestName, 1, p-1);
-        c := copy (ATestName, p+1, maxint);
-        end
-      else
-        begin
-        s := '';
-        c := ATestName;
-        end;
-      if comparetext(c, test.TestName) = 0 then
-        res.AddTest(test)
-      else if (CompareText( s, Test.TestName) = 0) or (s = '') then
-        begin
-        if (test is ttestsuite) then
-          begin
-          for I := 0 to TTestSuite(test).ChildTestCount - 1 do
-             CheckTestRegistry ((test as TTestSuite).Test[I], c, res)
-          end
-        else if (test is TTestDecorator) then
-          begin
-          DS:=TDecoratorTestSuite.Create;
-          CheckTestRegistry(TTest((test as TTestDecorator).Test), c, ds);
-          if (ds.CountTestCases>0) then
-            begin
-            D:=TTestDecoratorClass(Test.ClassType).Create(DS);
-            Res.AddTest(D);
-            end
-          else
-            DS.free;
-          end;
-        end;
-      end
-    else // if test is TTestCase then
-      begin
-      if comparetext(test.TestName, ATestName) = 0 then
-        res.AddTest(test);
-      end;
-  end;
-
 var
   I,P : integer;
-  S : string;
+  S,TN : string;
   TS : TDecoratorTestSuite;
+  T : TTest;
   
 begin
   S := CheckOptions(GetShortOpts, LongOpts);
@@ -383,7 +334,7 @@ begin
       fPlain:         Write(GetSuiteAsPlain(GetTestRegistry));
       fPlainNoTiming: Write(GetSuiteAsPlain(GetTestRegistry));
     else
-      Write(GetSuiteAsXml(GetTestRegistry));;
+      Write(GetSuiteAsXml(GetTestRegistry));
     end;
 
   //run the tests
@@ -400,19 +351,17 @@ begin
         try
         while Not(S = '') Do
           begin
-            P:=Pos(',',S);
-            if P = 0 Then
-              begin
-                for I := 0 to GetTestRegistry.ChildTestCount-1 do
-                  CheckTestRegistry (GetTestregistry[I], S, TS);
-                S := '';
-              end
-            else
-              begin
-                for I := 0 to GetTestRegistry.ChildTestCount-1 do
-                  CheckTestRegistry (GetTestregistry[I],Copy(S, 1,P - 1), TS);
-                Delete(S, 1, P);
-              end;
+          P:=Pos(',',S);
+          If P=0 then
+            P:=Length(S)+1;
+          TN:=Copy(S,1,P-1);
+          Delete(S,1,P);
+          if (TN<>'') then
+            begin
+            T:=GetTestRegistry.FindTest(TN);
+            if Assigned(T) then
+              TS.AddTest(T);
+            end;
           end;
           if (TS.CountTestCases>1) then
             DoTestRun(TS)

packages/fcl-fpcunit/src/fpcunit.pp

@@ -54,7 +54,11 @@ type
   TTestSuite = class;
 
   {$M+}
+
+  { TTest }
+
   TTest = class(TObject)
+  private
   protected
     FLastStep: TTestStep;
     function GetTestName: string; virtual;
@@ -64,6 +68,10 @@ type
     procedure SetEnableIgnores(Value: boolean); virtual; abstract;
   public
     function CountTestCases: integer; virtual;
+    Function GetChildTestCount : Integer; virtual;
+    Function GetChildTest(AIndex : Integer) : TTest; virtual;
+    function FindChildTest(const AName: String): TTest;
+    Function FindTest(Const AName : String) : TTest;
     procedure Run(AResult: TTestResult); virtual;
     procedure Ignore(const AMessage: string);
   published
@@ -240,8 +248,6 @@ type
     FName: string;
     FTestSuiteName: string;
     FEnableIgnores: boolean;
-    function GetTest(Index: integer): TTest;
-    function GetTestCount: Integer;
   protected
     Function DoAddTest(ATest : TTest) : Integer;
     function GetTestName: string; override;
@@ -258,13 +264,15 @@ type
     constructor Create; reintroduce; overload; virtual;
     destructor Destroy; override;
     function CountTestCases: integer; override;
+    Function GetChildTestCount : Integer; override;
+    Function GetChildTest(AIndex : Integer) : TTest; override;
     procedure Run(AResult: TTestResult); override;
     procedure RunTest(ATest: TTest; AResult: TTestResult); virtual;
     procedure AddTest(ATest: TTest); overload; virtual;
     procedure AddTestSuiteFromClass(ATestClass: TClass); virtual;
     class function Warning(const aMessage: string): TTestCase;
-    property Test[Index: integer]: TTest read GetTest; default;
-    Property ChildTestCount : Integer Read GetTestCount;
+    property Test[Index: integer]: TTest read GetChildTest; default;
+    Property ChildTestCount : Integer Read GetChildTestCount;
     property TestSuiteName: string read GetTestSuiteName write SetTestSuiteName;
     property TestName: string read GetTestName write SetTestName;
     // Only for backwards compatibility. Use Test and ChildTestCount.
@@ -538,6 +546,65 @@ begin
   Result := 0;
 end;
 
+function TTest.GetChildTestCount: Integer;
+begin
+  Result:=0;
+end;
+
+function TTest.GetChildTest(AIndex: Integer): TTest;
+begin
+  Result:=Nil;
+end;
+
+function TTest.FindChildTest(const AName: String): TTest;
+
+Var
+  I : Integer;
+
+begin
+  Result:=Nil;
+  I:=GetChildTestCount-1;
+  While (Result=Nil) and (I>=0) do
+    begin
+    Result:=GetChildTest(I);
+    if CompareText(Result.TestName,AName)<>0 then
+      Result:=Nil;
+    Dec(I);
+    end;
+end;
+
+function TTest.FindTest(const AName: String): TTest;
+
+Var
+  S : String;
+  I,P : Integer;
+
+begin
+  Result:=Nil;
+  S:=AName;
+  if S='' then exit;
+  P:=Pos('.',S);
+  If (P=0) then
+    P:=Length(S)+1;
+  Result:=FindChildTest(Copy(S,1,P-1));
+  if (Result<>Nil) then
+    begin
+    Delete(S,1,P);
+    If (S<>'') then
+      Result:=Result.FindTest(S);
+    end
+  else
+    begin
+    P:=GetChildTestCount;
+    I:=0;
+    While (Result=Nil) and (I<P) do
+      begin
+      Result:=GetChildTest(I).FindTest(Aname);
+      Inc(I);
+      end;
+    end;
+end;
+
 function TTest.GetEnableIgnores: boolean;
 begin
   Result := True;
@@ -548,7 +615,7 @@ begin
   { do nothing }
 end;
 
-procedure TTest.Ignore(const AMessage: String);
+procedure TTest.Ignore(const AMessage: string);
 begin
   if EnableIgnores then raise EIgnoredTest.Create(AMessage);
 end;
@@ -1197,12 +1264,12 @@ begin
 end;
 
 
-function TTestSuite.GetTest(Index: integer): TTest;
+function TTestSuite.GetChildTest(AIndex: integer): TTest;
 begin
-  Result := TTestItem(FTests[Index]).Test;
+  Result := TTestItem(FTests[AIndex]).Test;
 end;
 
-function TTestSuite.GetTestCount: Integer;
+function TTestSuite.GetChildTestCount: Integer;
 begin
   Result:=FTests.Count;
 end;

packages/fcl-fpcunit/src/latextestreport.pp

@@ -51,7 +51,7 @@ type
     procedure EndTest(ATest: TTest); override;
   end;
 
-function TestSuiteAsLatex(aSuite:TTestSuite): string;
+function TestSuiteAsLatex(aSuite:TTest): string;
 function GetSuiteAsLatex(aSuite: TTestSuite): string;
 
 implementation
@@ -250,27 +250,26 @@ begin
   
 end;
 
-function TestSuiteAsLatex(aSuite:TTestSuite): string;
+function TestSuiteAsLatex(aSuite:TTest): string;
 var
   i,j: integer;
   s: TTestSuite;
 begin
-  Result := TLatexResultsWriter.EscapeText(aSuite.TestSuiteName) + System.sLineBreak;
-  Result := Result + '\begin{itemize}'+ System.sLineBreak;
-  for i := 0 to aSuite.ChildTestCount - 1 do
-    if ASuite.Test[i] is TTestSuite then
-      begin
-      Result:=Result + '\item[-] ';
-      Result := Result + '\flushleft' + System.sLineBreak;
-      Result:=Result+TestSuiteAsLatex(TTestSuite(ASuite.Test[i]))+System.sLineBreak;
-      end
-    else   
-      begin
-      Result := Result + '\item[-] ' + 
-               TLatexResultsWriter.EscapeText(TTestcase(aSuite.Test[i]).TestName)
-               + System.sLineBreak;
-      end;    
-  Result := Result +'\end{itemize}' + System.sLineBreak;
+  Result:='';
+  if (aSuite.TestName<>'') then
+    begin
+    Result:=Result + '\item[-] ';
+    Result:=Result+TLatexResultsWriter.EscapeText(ASuite.TestName)+slineBreak
+    end;
+  if aSuite.GetChildTestCount>0 then
+    begin
+    Result := Result + '\begin{itemize}'+ System.sLineBreak;
+    for i:=0 to Pred(aSuite.GetChildTestCount) do
+      Result:=Result+TestSuiteAsLatex(aSuite.GetChildTest(i));
+    if (aSuite.TestName<>'') then
+      Result := Result +'\end{itemize}' + System.sLineBreak;
+    end
+
 end;
 
 
@@ -284,7 +283,9 @@ begin
       Result := Result + '\begin{document}' + System.sLineBreak + System.sLineBreak;
       if aSuite.TestName = '' then
         aSuite.TestName := 'Test Suite';
+      Result := Result + '\begin{itemize}'+ System.sLineBreak;
       Result := Result + TestSuiteAsLatex(aSuite);
+      Result := Result +'\end{itemize}' + System.sLineBreak;
       Result := Result + '\end{document}';
     end
   else

packages/fcl-fpcunit/src/plaintestreport.pp

@@ -19,7 +19,7 @@ unit plaintestreport;
 interface
 
 uses
-  classes, SysUtils, fpcunit, fpcunitreport;
+  classes, SysUtils, fpcunit, fpcunitreport, testdecorator;
 
 type
   TTestResultOption = (ttoSkipAddress,ttoSkipExceptionMessage,ttoErrorsOnly);
@@ -208,22 +208,21 @@ begin
   FSuiteHeaderIdx.Add(Pointer(FDoc.Count - 1));
 end;
 
-function DoTestSuiteAsPlain(aSuite:TTestSuite; Prefix : String; Options : TTestResultOptions = []): string;
+function DoTestSuiteAsPlain(aSuite:TTest; Prefix : String; Options : TTestResultOptions = []): string;
+
 var
   i: integer;
-  p : string;
+
 begin
-  Result := Prefix+ASuite.TestName+System.sLineBreak;
-  for i := 0 to aSuite.ChildTestCount - 1 do
-    if aSuite.Test[i] is TTestSuite then
-      begin
-      P:=Prefix;
-      if (ASuite.TestName<>'') then
-        P:=P+'  ';
-      Result := Result + DoTestSuiteAsPlain(TTestSuite(aSuite.Test[i]),P,Options);
-      end
-    else if aSuite.Test[i] is TTestCase then
-      Result := Result + Prefix+'  ' + ASuite.TestName+'.' + TTestcase(aSuite.Test[i]).TestName + System.sLineBreak;
+  if (ASuite.TestSuiteName<>'') then
+    begin
+    Prefix:='  '+Prefix;
+    Prefix:=Prefix+ASuite.TestSuiteName+'.';
+    end;
+  if (ASuite.TestName<>'') then
+    Result := Prefix+ASuite.TestName+System.sLineBreak;
+  for i := 0 to aSuite.GetChildTestCount - 1 do
+    Result := Result + DoTestSuiteAsPlain(aSuite.GetChildTest(i),Prefix,Options);
 end;
 
 function TestSuiteAsPlain(aSuite:TTestSuite; Options : TTestResultOptions = []): string;

packages/fcl-fpcunit/src/testdecorator.pp

@@ -27,16 +27,18 @@ type
 
   { TTestDecorator }
 
-  TTestDecorator = class(TAssert)
+  TTestDecorator = class(TTest{Assert})
   private
     FTest: TTest;
+  protected
     function GetTestName: string; override;
     function GetTestSuiteName: string; override;
     procedure SetTestSuiteName(const aName: string); override;
-  protected
     function GetEnableIgnores: boolean; override;
     procedure SetEnableIgnores(Value: boolean); override;
   public
+    Function GetChildTest(AIndex: Integer): TTest; override;
+    Function GetChildTestCount : Integer; override;
     function CountTestCases: integer; override;
     constructor Create(aTest: TTest); reintroduce; overload;
     destructor Destroy; override;
@@ -84,6 +86,16 @@ begin
   FTest.EnableIgnores := Value;
 end;
 
+function TTestDecorator.GetChildTest(AIndex: Integer): TTest;
+begin
+  Result:=FTest.GetChildTest(AIndex);
+end;
+
+function TTestDecorator.GetChildTestCount: Integer;
+begin
+  Result:=FTest.GetChildTestCount;
+end;
+
 function TTestDecorator.CountTestCases: integer;
 begin
   Result := FTest.CountTestCases;

packages/fcl-fpcunit/src/xmltestreport.pp

@@ -70,7 +70,7 @@ type
   end;
 
 function GetSuiteAsXML(aSuite: TTestSuite): string;
-function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTestSuite): string;
+function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTest): string;
 
 implementation
 
@@ -93,35 +93,37 @@ begin
 
     stream := TStringStream.Create('');
     WriteXMLFile(FDoc, stream);
-    writeln(stream.DataString);
+    Result:=stream.DataString;
     stream.Free;
   end;
 end;
 
-function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTestSuite): string;
+function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTest): string;
 var
   i: integer;
   E,T : TDomElement;
   
 begin
-  if aSuite.TestName<>'' then
+  Result:='';
+  if aSuite.GetChildTestCount>0 then
     begin
-    E:=FDoc.CreateElement('Suite');
-    E['Name']:=aSuite.TestName;
-    N.AppendChild(E);
+    if (aSuite.TestName='') then
+      E:=N
+    else
+      begin
+      E:=FDoc.CreateElement('Suite');
+      E['Name']:=aSuite.TestName;
+      N.AppendChild(E);
+      end;
+    for i:=0 to Pred(aSuite.GetChildTestCount) do
+      TestSuiteAsXML(E,FDoc,aSuite.GetChildTest(i));
     end
   else
-    E:=N;
-  for i:=0 to Pred(aSuite.ChildTestCount) do
-    if TTest(aSuite.Test[i]) is TTestSuite then
-      TestSuiteAsXML(E, FDoc, TTestSuite(aSuite.Test[i]))
-    else
-      if TTest(aSuite.Test[i]) is TTestCase then
-        begin
-        T:=FDoc.CreateElement('Test');
-        T['name']:=TTestCase(aSuite.Test[i]).TestName;
-        E.AppendChild(T);
-        end;
+    begin
+    T:=FDoc.CreateElement('Test');
+    T['name']:=aSuite.TestName;
+    N.AppendChild(T);
+    end;
 end;