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';
+  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;
+  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;
@@ -68,9 +136,13 @@ var
     end;
   {$ENDIF}
 
-  begin
+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,13 +151,17 @@ var
       else
         doXMLTestRun(aTest);
     end;
+  finally
+    if ShowProgress then
+      progressWriter.Free;
   end;
+end;
 
-  procedure TTestRunner.DoRun;
+procedure TTestRunner.DoRun;
-  var
+var
   I: integer;
   S: string;
-  begin
+begin
   S := CheckOptions(ShortOpts, LongOpts);
   if (S <> '') then
     Writeln(S);
@@ -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
@@ -154,7 +237,7 @@ var
           doTestRun(GetTestRegistry[i]);
   end;
   Terminate;
-  end;
+end;
 
 var
   App: TTestRunner;
@@ -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,
+  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;