mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-20 12:19:31 +02:00
* Remove consoletestrunner, it is outdated and crashes applications. The version in FPC repository is now used, reference is marked as virtual
git-svn-id: trunk@51829 -
This commit is contained in:
michael
parent
01358aea67
commit
5c5523af89
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -1308,7 +1308,6 @@ components/fpcunit/Makefile svneol=native#text/plain
|
||||
components/fpcunit/Makefile.compiled svneol=native#text/plain
|
||||
components/fpcunit/Makefile.fpc svneol=native#text/plain
|
||||
components/fpcunit/blueball.xpm svneol=native#text/plain
|
||||
components/fpcunit/console/consoletestrunner.pas svneol=native#text/plain
|
||||
components/fpcunit/console/fpcunit.xsl svneol=native#text/plain
|
||||
components/fpcunit/console/fpcunitconsolerunner.lpk svneol=native#text/plain
|
||||
components/fpcunit/console/fpcunitconsolerunner.pas svneol=native#text/plain
|
||||
|
||||
@ -1,341 +0,0 @@
|
||||
{ This unit contains the TTestRunner class, a base class for the console test
|
||||
runner for fpcunit.
|
||||
|
||||
Copyright (C) 2006 Vincent Snijders
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the terms of the GNU Library General Public License as published by
|
||||
the Free Software Foundation; either version 2 of the License, or (at your
|
||||
option) any later version.
|
||||
|
||||
This program 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 Library General Public License
|
||||
for more details.
|
||||
|
||||
You should have received a copy of the GNU Library General Public License
|
||||
along with this library; if not, write to the Free Software Foundation,
|
||||
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
}
|
||||
unit consoletestrunner;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
custapp, Classes, SysUtils, LazUTF8,
|
||||
fpcunit, testregistry, testutils,
|
||||
fpcunitreport, latextestreport, xmltestreport, plaintestreport,
|
||||
dom;
|
||||
|
||||
const
|
||||
Version = '0.2';
|
||||
|
||||
type
|
||||
TFormat = (fPlain, fLatex, fXML);
|
||||
|
||||
var
|
||||
DefaultFormat : TFormat = fXML;
|
||||
DefaultRunAllTests : Boolean = False;
|
||||
|
||||
type
|
||||
{ TTestRunner }
|
||||
|
||||
TTestRunner = class(TCustomApplication)
|
||||
private
|
||||
FShowProgress: boolean;
|
||||
FFileName: string;
|
||||
FStyleSheet: string;
|
||||
FLongOpts: TStrings;
|
||||
FFormatParam: TFormat;
|
||||
protected
|
||||
property FileName: string read FFileName write FFileName;
|
||||
property LongOpts: TStrings read FLongOpts write FLongOpts;
|
||||
property ShowProgress: boolean read FShowProgress write FShowProgress;
|
||||
property StyleSheet: string read FStyleSheet write FStyleSheet;
|
||||
property FormatParam: TFormat read FFormatParam write FFormatParam;
|
||||
procedure DoRun; override;
|
||||
procedure DoTestRun(ATest: TTest); virtual;
|
||||
function GetShortOpts: string; virtual;
|
||||
procedure AppendLongOpts; virtual;
|
||||
procedure WriteCustomHelp; virtual;
|
||||
procedure ParseOptions; virtual;
|
||||
procedure ExtendXmlDocument(Doc: TXMLDocument); virtual;
|
||||
function GetResultsWriter: TCustomResultsWriter; virtual;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
ShortOpts = 'alhp';
|
||||
DefaultLongOpts: array[1..8] of string =
|
||||
('all', 'list', 'progress', 'help',
|
||||
'suite:', 'format:', 'file:', 'stylesheet:');
|
||||
|
||||
{ TProgressWriter }
|
||||
type
|
||||
TProgressWriter= class(TNoRefCountObject, ITestListener)
|
||||
private
|
||||
FSuccess: boolean;
|
||||
procedure WriteChar(c: char);
|
||||
public
|
||||
destructor Destroy; override;
|
||||
|
||||
{ ITestListener interface requirements }
|
||||
procedure AddFailure({%H-}ATest: TTest; {%H-}AFailure: TTestFailure);
|
||||
procedure AddError({%H-}ATest: TTest; {%H-}AError: TTestFailure);
|
||||
procedure StartTest({%H-}ATest: TTest);
|
||||
procedure EndTest({%H-}ATest: TTest);
|
||||
procedure StartTestSuite({%H-}ATestSuite: TTestSuite);
|
||||
procedure EndTestSuite({%H-}ATestSuite: TTestSuite);
|
||||
end;
|
||||
|
||||
procedure TProgressWriter.WriteChar(c: char);
|
||||
begin
|
||||
write(c);
|
||||
// flush output, so that we see the char immediately, even it is written to file
|
||||
Flush(output);
|
||||
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
|
||||
FSuccess := false;
|
||||
writechar('F');
|
||||
end;
|
||||
|
||||
procedure TProgressWriter.AddError(ATest: TTest; AError: TTestFailure);
|
||||
begin
|
||||
FSuccess := false;
|
||||
writechar('E');
|
||||
end;
|
||||
|
||||
procedure TProgressWriter.StartTest(ATest: TTest);
|
||||
begin
|
||||
FSuccess := true; // assume success, until proven otherwise
|
||||
end;
|
||||
|
||||
procedure TProgressWriter.EndTest(ATest: TTest);
|
||||
begin
|
||||
if FSuccess then
|
||||
writechar('.');
|
||||
end;
|
||||
|
||||
procedure TProgressWriter.StartTestSuite(ATestSuite: TTestSuite);
|
||||
begin
|
||||
// do nothing
|
||||
end;
|
||||
|
||||
procedure TProgressWriter.EndTestSuite(ATestSuite: TTestSuite);
|
||||
begin
|
||||
// do nothing
|
||||
end;
|
||||
|
||||
function TTestRunner.GetResultsWriter: TCustomResultsWriter;
|
||||
begin
|
||||
case FormatParam of
|
||||
fLatex: Result := TLatexResultsWriter.Create(nil);
|
||||
fPlain: Result := TPlainResultsWriter.Create(nil);
|
||||
else
|
||||
begin
|
||||
Result := TXmlResultsWriter.Create(nil);
|
||||
ExtendXmlDocument(TXMLResultsWriter(Result).Document);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestRunner.DoTestRun(ATest: TTest);
|
||||
var
|
||||
ResultsWriter: TCustomResultsWriter;
|
||||
ProgressWriter: TProgressWriter;
|
||||
TestResult: TTestResult;
|
||||
begin
|
||||
ResultsWriter := GetResultsWriter;
|
||||
ResultsWriter.Filename := FileName;
|
||||
TestResult := TTestResult.Create;
|
||||
try
|
||||
if ShowProgress then
|
||||
begin
|
||||
ProgressWriter := TProgressWriter.Create;
|
||||
TestResult.AddListener(ProgressWriter);
|
||||
end
|
||||
else
|
||||
ProgressWriter := nil;
|
||||
TestResult.AddListener(ResultsWriter);
|
||||
ATest.Run(TestResult);
|
||||
ResultsWriter.WriteResult(TestResult);
|
||||
finally
|
||||
TestResult.Free;
|
||||
ResultsWriter.Free;
|
||||
ProgressWriter.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTestRunner.GetShortOpts: string;
|
||||
begin
|
||||
Result := ShortOpts;
|
||||
end;
|
||||
|
||||
procedure TTestRunner.AppendLongOpts;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
for i := low(DefaultLongOpts) to high(DefaultLongOpts) do
|
||||
LongOpts.Add(DefaultLongOpts[i]);
|
||||
end;
|
||||
|
||||
procedure TTestRunner.WriteCustomHelp;
|
||||
begin
|
||||
// no custom help options in base class;
|
||||
end;
|
||||
|
||||
procedure TTestRunner.ParseOptions;
|
||||
begin
|
||||
if HasOption('h', 'help') or ((ParamCount = 0) and not DefaultRunAllTests) then
|
||||
begin
|
||||
writeln(Title);
|
||||
writeln(Version);
|
||||
writeln;
|
||||
writeln('Usage: ');
|
||||
writeln(' --format=latex output as latex source (only list implemented)');
|
||||
writeln(' --format=plain output as plain ASCII source');
|
||||
writeln(' --format=xml output as XML source (default)');
|
||||
writeln(' --stylesheet=<reference> add stylesheet reference');
|
||||
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');
|
||||
WriteCustomHelp;
|
||||
writeln;
|
||||
writeln('The results can be redirected to an xml file,');
|
||||
writeln('for example: ', ParamStrUTF8(0),' --all > results.xml');
|
||||
end;
|
||||
|
||||
//get the format parameter
|
||||
FormatParam := DefaultFormat;
|
||||
if HasOption('format') then
|
||||
begin
|
||||
if CompareText(GetOptionValue('format'),'latex')=0 then
|
||||
FormatParam := fLatex
|
||||
else if CompareText(GetOptionValue('format'),'plain')=0 then
|
||||
FormatParam := fPlain
|
||||
else if CompareText(GetOptionValue('format'),'xml')=0 then
|
||||
FormatParam := fXML;
|
||||
end;
|
||||
|
||||
ShowProgress := HasOption('p', 'progress');
|
||||
|
||||
if HasOption('file') then
|
||||
FileName := GetOptionValue('file');
|
||||
if HasOption('stylesheet') then
|
||||
StyleSheet := GetOptionValue('stylesheet');
|
||||
end;
|
||||
|
||||
procedure TTestRunner.ExtendXmlDocument(Doc: TXMLDocument);
|
||||
var
|
||||
n: TDOMElement;
|
||||
begin
|
||||
if StyleSheet<>'' then begin
|
||||
Doc.StylesheetType := 'text/xsl';
|
||||
Doc.StylesheetHRef := UTF8Decode(StyleSheet);
|
||||
end;
|
||||
n := Doc.CreateElement('Title');
|
||||
n.AppendChild(Doc.CreateTextNode(UTF8Decode(Title)));
|
||||
Doc.FirstChild.AppendChild(n);
|
||||
end;
|
||||
|
||||
constructor TTestRunner.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FLongOpts := TStringList.Create;
|
||||
AppendLongOpts;
|
||||
end;
|
||||
|
||||
destructor TTestRunner.Destroy;
|
||||
begin
|
||||
FLongOpts.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TTestRunner.DoRun;
|
||||
|
||||
procedure CheckTestRegistry (test:TTest; ATestName:string);
|
||||
var s, c : string;
|
||||
I, p : integer;
|
||||
begin
|
||||
if test is TTestSuite 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
|
||||
DoTestRun(test)
|
||||
else if (CompareText( s, Test.TestName) = 0) or (s = '') then
|
||||
for I := 0 to TTestSuite(test).Tests.Count - 1 do
|
||||
CheckTestRegistry (TTest(TTestSuite(test).Tests[I]), c)
|
||||
end
|
||||
else // if test is TTestCase then
|
||||
begin
|
||||
if comparetext(test.TestName, ATestName) = 0 then
|
||||
DoTestRun(test);
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
I: integer;
|
||||
S: string;
|
||||
begin
|
||||
S := CheckOptions(GetShortOpts, LongOpts);
|
||||
if (S <> '') then
|
||||
Writeln(S);
|
||||
|
||||
ParseOptions;
|
||||
|
||||
//get a list of all registed tests
|
||||
if HasOption('l', 'list') then
|
||||
case FormatParam of
|
||||
fLatex: Write(GetSuiteAsLatex(GetTestRegistry));
|
||||
fPlain: Write(GetSuiteAsPlain(GetTestRegistry));
|
||||
else
|
||||
Write(GetSuiteAsLatex(GetTestRegistry));;
|
||||
end;
|
||||
|
||||
//run the tests
|
||||
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
|
||||
CheckTestRegistry (GetTestregistry[I], S);
|
||||
end
|
||||
else if HasOption('a', 'all') or (DefaultRunAllTests and Not HasOption('l','list')) then
|
||||
DoTestRun(GetTestRegistry) ;
|
||||
Terminate;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -1,16 +1,19 @@
|
||||
<?xml version="1.0"?>
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<Package Version="3">
|
||||
<Package Version="4">
|
||||
<Name Value="fpcunitconsolerunner"/>
|
||||
<AddToProjectUsesSection Value="True"/>
|
||||
<Author Value="Vincent"/>
|
||||
<CompilerOptions>
|
||||
<Version Value="8"/>
|
||||
<Version Value="11"/>
|
||||
<SearchPaths>
|
||||
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Other>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<UseAnsiStrings Value="False"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
</CompilerOptions>
|
||||
<License Value="Modified LGPL
|
||||
"/>
|
||||
@ -18,6 +21,7 @@
|
||||
<Files Count="1">
|
||||
<Item1>
|
||||
<Filename Value="consoletestrunner.pas"/>
|
||||
<Type Value="Virtual Unit"/>
|
||||
<UnitName Value="consoletestrunner"/>
|
||||
</Item1>
|
||||
</Files>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user