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

git-svn-id: trunk@9940 -

test/runtests.lpr

@@ -1,36 +1,101 @@
+{ $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';
-  Longopts: array[1..6] of string =
-     ('all', 'list', 'format:', 'suite:', 'compiler:', 'help');
-  Version = 'Version 0.1';
+  ShortOpts = 'alhp';
+  Longopts: array[1..8] of string =
+     ('all', 'list', 'progress', 'help',
+      '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);
 var
   testResult: TTestResult;
+  progressWriter: TProgressWriter;
 
   procedure doXMLTestRun(aTest: TTest);
   var
@@ -43,6 +108,9 @@ var
       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;
@@ -70,7 +138,11 @@ var
 
 begin
   testResult := TTestResult.Create;
-
+  if ShowProgress then begin
+    progressWriter := TProgressWriter.Create;
+    testResult.AddListener(progressWriter);
+  end;
+  try
     case FormatParam of
       fLatex: doXMLTestRun(aTest); //no latex implemented yet
       {$IFNDEF VER2_0}
@@ -79,6 +151,10 @@ var
       else
         doXMLTestRun(aTest);
     end;
+  finally
+    if ShowProgress then
+      progressWriter.Free;
+  end;
 end;
 
 procedure TTestRunner.DoRun;
@@ -101,9 +177,11 @@ var
     writeln('  --format=plain            output as plain ASCII source');
     {$ENDIF}
     writeln('  --format=xml              output as XML source (default)');
+    writeln('  --file=<filename>         output results to file');
     writeln;
     writeln('  -l or --list              show a list of registered tests');
     writeln('  -a or --all               run all tests');
+    writeln('  -p or --progress          show progress');
     writeln('  --suite=MyTestSuiteName   run single test suite class');
     writeln('  --compiler=<ppcxxx>       use ppcxxx to build test projects');
     writeln;
@@ -123,6 +201,11 @@ var
     {$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
@@ -162,7 +245,7 @@ var
 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,
-  FileUtil;
+  Classes, SysUtils, fpcunit, testregistry, process, FileUtil;
 
 type
 
@@ -110,6 +109,8 @@ begin
   try
     {$IFDEF win32}
     LazBuild.Options := [poNewConsole];
+    {$ELSE}
+    LazBuild.Options := [poNoConsole];
     {$ENDIF}
     LazBuild.ShowWindow := swoHIDE;
     LazBuild.CommandLine := LazBuildPath;