test runner: added writing results to file and showing simple progress

git-svn-id: trunk@9940 -

test/runtests.lpr

@@ -1,168 +1,251 @@
+{ $ID: $}
+{ Copyright (C) <2006> <Vincent Snijders>
+
+  This source is free software; you can redistribute it and/or modify it under
+  the terms of the GNU General Public License as published by the Free
+  Software Foundation; either version 2 of the License, or (at your option)
+  any later version.
+
+  This code is distributed in the hope that it will be useful, but WITHOUT ANY
+  WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+  FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
+  details.
+
+  A copy of the GNU General Public License is available on the World Wide Web
+  at <http://www.gnu.org/copyleft/gpl.html>. You can also obtain it by writing
+  to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+  MA 02111-1307, USA.
+}
 program runtests;
 
 {$mode objfpc}{$H+}
 
 uses
-  custapp, Classes, SysUtils, fpcunit, testregistry, testreport,
+  custapp, Classes, SysUtils, fpcunit, testregistry, testreport, testutils,
   xmlreporter, xmlwrite,
   TestLpi;
 
 const
-  ShortOpts = 'alh';
+  ShortOpts = 'alhp';
-  Longopts: array[1..6] of string =
+  Longopts: array[1..8] of string =
-     ('all', 'list', 'format:', 'suite:', 'compiler:', 'help');
+     ('all', 'list', 'progress', 'help',
-  Version = 'Version 0.1';
+      'suite:', 'format:', 'file:', 'compiler:');
+  Version = '0.2';
 
 type
   TFormat = (fPlain, fLatex, fXML);
 
+  { TTestRunner }
+
   TTestRunner = class(TCustomApplication)
   private
-
+     FShowProgress: boolean;
+     FFileName: string;
   protected
+    property FileName: string read FFileName write FFileName;
+    property ShowProgress: boolean read FShowProgress write FShowProgress;
     procedure DoRun; override;
     procedure doTestRun(aTest: TTest); virtual;
   public
   end;
+  
+  { TProgressWriter }
+
+  TProgressWriter= class(TNoRefCountObject, ITestListener)
+  public
+    destructor Destroy; override;
+
+    { ITestListener interface requirements }
+    procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
+    procedure AddError(ATest: TTest; AError: TTestFailure);
+    procedure StartTest(ATest: TTest);
+    procedure EndTest(ATest: TTest);
+  end;
+
+destructor TProgressWriter.Destroy;
+begin
+  // on descruction, just write the missing line ending
+  writeln;
+  inherited Destroy;
+end;
+
+procedure TProgressWriter.AddFailure(ATest: TTest; AFailure: TTestFailure);
+begin
+  write('F');
+end;
+
+procedure TProgressWriter.AddError(ATest: TTest; AError: TTestFailure);
+begin
+  write('E');
+end;
+
+procedure TProgressWriter.StartTest(ATest: TTest);
+begin
+  // nothing to do
+end;
+
+procedure TProgressWriter.EndTest(ATest: TTest);
+begin
+  write('.');
+end;
 
 var
   FormatParam: TFormat;
 
-  procedure TTestRunner.doTestRun(aTest: TTest);
+procedure TTestRunner.doTestRun(aTest: TTest);
-  var
+var
-    testResult: TTestResult;
+  testResult: TTestResult;
+  progressWriter: TProgressWriter;
 
-    procedure doXMLTestRun(aTest: TTest);
+  procedure doXMLTestRun(aTest: TTest);
+  var
+    XMLResultsWriter: TXMLResultsWriter;
+  begin
+    try
+      XMLResultsWriter := TXMLResultsWriter.Create;
+      testResult.AddListener(XMLResultsWriter);
+      aTest.Run(testResult);
+      XMLResultsWriter.WriteResult(testResult);
+      XMLResultsWriter.Document.StylesheetType := 'text/xsl';
+      XMLResultsWriter.Document.StylesheetHRef := 'results.xsl';
+      if FileName<>'' then
+        WriteXMLFile(XMLResultsWriter.Document, FileName)
+      else
+        WriteXMLFile(XMLResultsWriter.Document, output);
+    finally
+      XMLResultsWriter.Free;
+      testResult.Free;
+    end;
+  end;
+
+  {$IFNDEF VER2_0}
+    procedure doPlainTestRun(aTest: TTest);
     var
-      XMLResultsWriter: TXMLResultsWriter;
+      PlainResultsWriter: TPlainResultsWriter;
     begin
       try
-        XMLResultsWriter := TXMLResultsWriter.Create;
+        PlainResultsWriter := TPlainResultsWriter.Create;
-        testResult.AddListener(XMLResultsWriter);
+        testResult.AddListener(PlainResultsWriter);
+        PlainResultsWriter.WriteHeader;
         aTest.Run(testResult);
-        XMLResultsWriter.WriteResult(testResult);
+        PlainResultsWriter.WriteResult(testResult);
-        XMLResultsWriter.Document.StylesheetType := 'text/xsl';
-        XMLResultsWriter.Document.StylesheetHRef := 'results.xsl';
-        WriteXMLFile(XMLResultsWriter.Document, output);
       finally
-        XMLResultsWriter.Free;
+        PlainResultsWriter.Free;
         testResult.Free;
       end;
     end;
+  {$ENDIF}
 
-    {$IFNDEF VER2_0}
+begin
-      procedure doPlainTestRun(aTest: TTest);
+  testResult := TTestResult.Create;
-      var
+  if ShowProgress then begin
-        PlainResultsWriter: TPlainResultsWriter;
+    progressWriter := TProgressWriter.Create;
-      begin
+    testResult.AddListener(progressWriter);
-        try
+  end;
-          PlainResultsWriter := TPlainResultsWriter.Create;
+  try
-          testResult.AddListener(PlainResultsWriter);
-          PlainResultsWriter.WriteHeader;
-          aTest.Run(testResult);
-          PlainResultsWriter.WriteResult(testResult);
-        finally
-          PlainResultsWriter.Free;
-          testResult.Free;
-        end;
-      end;
-    {$ENDIF}
-
-  begin
-    testResult := TTestResult.Create;
-
     case FormatParam of
       fLatex: doXMLTestRun(aTest); //no latex implemented yet
       {$IFNDEF VER2_0}
-        fPlain: doPlainTestRun(aTest);
+      fPlain: doPlainTestRun(aTest);
       {$ENDIF}
       else
         doXMLTestRun(aTest);
     end;
+  finally
+    if ShowProgress then
+      progressWriter.Free;
   end;
+end;
 
-  procedure TTestRunner.DoRun;
+procedure TTestRunner.DoRun;
-  var
+var
-    I: integer;
+  I: integer;
-    S: string;
+  S: string;
+begin
+  S := CheckOptions(ShortOpts, LongOpts);
+  if (S <> '') then
+    Writeln(S);
+
+  if HasOption('h', 'help') or (ParamCount = 0) then
   begin
-    S := CheckOptions(ShortOpts, LongOpts);
+    writeln(Title);
-    if (S <> '') then
+    writeln(Version);
-      Writeln(S);
+    writeln;
-
+    writeln('Usage: ');
-    if HasOption('h', 'help') or (ParamCount = 0) then
+    writeln('  --format=latex            output as latex source (only list implemented)');
-    begin
+    {$IFNDEF VER2_0}
-      writeln(Title);
+    writeln('  --format=plain            output as plain ASCII source');
-      writeln(Version);
+    {$ENDIF}
-      writeln;
+    writeln('  --format=xml              output as XML source (default)');
-      writeln('Usage: ');
+    writeln('  --file=<filename>         output results to file');
-      writeln('  --format=latex            output as latex source (only list implemented)');
+    writeln;
-      {$IFNDEF VER2_0}
+    writeln('  -l or --list              show a list of registered tests');
-      writeln('  --format=plain            output as plain ASCII source');
+    writeln('  -a or --all               run all tests');
-      {$ENDIF}
+    writeln('  -p or --progress          show progress');
-      writeln('  --format=xml              output as XML source (default)');
+    writeln('  --suite=MyTestSuiteName   run single test suite class');
-      writeln;
+    writeln('  --compiler=<ppcxxx>       use ppcxxx to build test projects');
-      writeln('  -l or --list              show a list of registered tests');
+    writeln;
-      writeln('  -a or --all               run all tests');
+    writeln('The results can be redirected to an xml file,');
-      writeln('  --suite=MyTestSuiteName   run single test suite class');
+    writeln('for example: ', ParamStr(0),' --all > results.xml');
-      writeln('  --compiler=<ppcxxx>       use ppcxxx to build test projects');
-      writeln;
-      writeln('The results can be redirected to an xml file,');
-      writeln('for example: ', ParamStr(0),' --all > results.xml');
-    end;
-
-    //get the format parameter
-    FormatParam := fXML;
-    if HasOption('format') then
-    begin
-      if GetOptionValue('format') = 'latex' then
-        FormatParam := fLatex;
-      {$IFNDEF VER2_0}
-        if GetOptionValue('format') = 'plain' then
-          FormatParam := fPlain;
-      {$ENDIF}
-    end;
-
-    //get a list of all registed tests
-    if HasOption('l', 'list') then
-      case FormatParam of
-        fLatex: Write(GetSuiteAsLatex(GetTestRegistry));
-        {$IFNDEF VER2_0}
-          fPlain: Write(GetSuiteAsPlain(GetTestRegistry));
-        {$ENDIF}
-        else
-          Write(GetSuiteAsXML(GetTestRegistry));
-      end;
-
-    if HasOption('compiler') then
-      Compiler := GetOptionValue('compiler');
-
-    //run the tests
-    if HasOption('a', 'all') then
-      doTestRun(GetTestRegistry)
-    else
-    if HasOption('suite') then
-    begin
-      S := '';
-      S := GetOptionValue('suite');
-      if S = '' then
-        for I := 0 to GetTestRegistry.Tests.Count - 1 do
-          writeln(GetTestRegistry[i].TestName)
-      else
-        for I := 0 to GetTestRegistry.Tests.Count - 1 do
-          if GetTestRegistry[i].TestName = S then
-            doTestRun(GetTestRegistry[i]);
-    end;
-    Terminate;
   end;
 
+  //get the format parameter
+  FormatParam := fXML;
+  if HasOption('format') then
+  begin
+    if GetOptionValue('format') = 'latex' then
+      FormatParam := fLatex;
+    {$IFNDEF VER2_0}
+      if GetOptionValue('format') = 'plain' then
+        FormatParam := fPlain;
+    {$ENDIF}
+  end;
+  
+  ShowProgress := HasOption('p', 'progress');
+  
+  if HasOption('file') then
+    FileName := GetOptionValue('file');
+
+  //get a list of all registed tests
+  if HasOption('l', 'list') then
+    case FormatParam of
+      fLatex: Write(GetSuiteAsLatex(GetTestRegistry));
+      {$IFNDEF VER2_0}
+        fPlain: Write(GetSuiteAsPlain(GetTestRegistry));
+      {$ENDIF}
+      else
+        Write(GetSuiteAsXML(GetTestRegistry));
+    end;
+
+  if HasOption('compiler') then
+    Compiler := GetOptionValue('compiler');
+
+  //run the tests
+  if HasOption('a', 'all') then
+    doTestRun(GetTestRegistry)
+  else
+  if HasOption('suite') then
+  begin
+    S := '';
+    S := GetOptionValue('suite');
+    if S = '' then
+      for I := 0 to GetTestRegistry.Tests.Count - 1 do
+        writeln(GetTestRegistry[i].TestName)
+    else
+      for I := 0 to GetTestRegistry.Tests.Count - 1 do
+        if GetTestRegistry[i].TestName = S then
+          doTestRun(GetTestRegistry[i]);
+  end;
+  Terminate;
+end;
+
 var
   App: TTestRunner;
 
 begin
   App := TTestRunner.Create(nil);
   App.Initialize;
-  App.Title := 'FPCUnit Console Test Case runner.';
+  App.Title := 'FPCUnit Console runner for the Lazarus Test Suite.';
   App.Run;
   App.Free;
 end.

test/testlpi.pas

@@ -5,8 +5,7 @@ unit TestLpi;
 interface
 
 uses
-  Classes, SysUtils, fpcunit, testutils, testregistry, process,
+  Classes, SysUtils, fpcunit, testregistry, process, FileUtil;
-  FileUtil;
 
 type
 
@@ -110,6 +109,8 @@ begin
   try
     {$IFDEF win32}
     LazBuild.Options := [poNewConsole];
+    {$ELSE}
+    LazBuild.Options := [poNoConsole];
     {$ENDIF}
     LazBuild.ShowWindow := swoHIDE;
     LazBuild.CommandLine := LazBuildPath;