paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-18 07:59:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ added support for PlainText result writer from Darius

Browse Source 
- removed xmlreporter unit, now part of the FCL
* console testrunner doesn't need the LCL

git-svn-id: trunk@9723 -
This commit is contained in:
vincents 2006-08-16 14:09:55 +00:00
parent 54a518888e
commit 87ef409de2
7 changed files with 184 additions and 357 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -150,12 +150,12 @@ components/fpcunit/ide/README.txt svneol=native#text/plain
components/fpcunit/ide/fpcunitide.lpk svneol=native#text/pascal
components/fpcunit/ide/fpcunitide.pas svneol=native#text/pascal
components/fpcunit/ide/fpcunitlazideintf.pas svneol=native#text/pascal
components/fpcunit/ide/fpcunitproject1.inc svneol=native#text/plain
components/fpcunit/ide/lib/README.txt svneol=native#text/plain
components/fpcunit/ide/testcaseopts.lfm svneol=native#text/plain
components/fpcunit/ide/testcaseopts.lrs svneol=native#text/pascal
components/fpcunit/ide/testcaseopts.pas svneol=native#text/pascal
components/fpcunit/lib/README.txt svneol=native#text/plain
components/fpcunit/xmlreporter.pas svneol=native#text/plain
components/h2pas/h2pasconfig.pas svneol=native#text/plain
components/h2pas/h2pasconvert.pas svneol=native#text/plain
components/h2pas/h2pasdlg.lfm svneol=native#text/plain

25
components/fpcunit/fpcunittestrunner.lpk
View File

@ -1,13 +1,15 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="2">
<PathDelim Value="\"/>
<Name Value="FPCUnitTestRunner"/>
<Author Value="Vincent Snijders"/>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="$(LazarusDir)/components/synedit/units/$(TargetCPU)-$(TargetOS)/"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
<OtherUnitFiles Value="$(LazarusDir)\components\synedit\units\$(TargetCPU)-$(TargetOS)\"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
@ -20,27 +22,23 @@
<Description Value="FPCUnit gui test runner form"/>
<License Value="LGPL"/>
<Version Minor="1"/>
<Files Count="5">
<Files Count="4">
<Item1>
<Filename Value="guitestrunner.pas"/>
<UnitName Value="GuiTestRunner"/>
</Item1>
<Item2>
<Filename Value="xmlreporter.pas"/>
<UnitName Value="xmlreporter"/>
</Item2>
<Item3>
<Filename Value="blueball.xpm"/>
<Type Value="Text"/>
</Item3>
<Item4>
</Item2>
<Item3>
<Filename Value="guitestrunner.lfm"/>
<Type Value="LFM"/>
</Item4>
<Item5>
</Item3>
<Item4>
<Filename Value="guitestrunner.lrs"/>
<Type Value="LRS"/>
</Item5>
</Item4>
</Files>
<RequiredPkgs Count="3">
<Item1>
@ -56,10 +54,11 @@
</Item3>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)/"/>
<UnitPath Value="$(PkgOutDir)\"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="$(TestDir)\publishedpackage\"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>

2
components/fpcunit/fpcunittestrunner.pas
View File

@ -7,7 +7,7 @@ unit FPCUnitTestRunner;
interface
uses
GuiTestRunner, xmlreporter;
GuiTestRunner;
implementation

12
components/fpcunit/guitestrunner.pas
View File

@ -24,11 +24,13 @@ unit GuiTestRunner;
{$mode objfpc}{$H+}
{ Uncomment this define, to use the old XML output routines. If it is left
commented out, it will use the XMLWrite unit that comes
with FPC. The benefit of using XMLWrite is that it creates valid XML data with
reserved characters escaped and allows for further processing with XSLT etc. }
{.$DEFINE UseOldXML}
{ By default the old XML unit will be used for FPC 2.0.2 and the new XML unit
for any FPC versions above 2.0.2. The benefit of using the new XML unit is
that it creates valid XML data with reserved characters escaped and allows
for further processing with XSLT etc. }
{$IFDEF VER2_0_2}
{$DEFINE UseOldXML}
{$ENDIF}
interface

123
components/fpcunit/ide/fpcunitlazideintf.pas
View File

@ -328,7 +328,6 @@ end;
function TFPCUnitConsoleApplicationDescriptor.InitProject(
AProject: TLazProject): TModalResult;
var
le: string;
NewSource: string;
MainFile: TLazProjectFile;
begin
@ -340,128 +339,12 @@ begin
AProject.MainFileID:=0;
// create program source
le:=LineEnding;
NewSource:='program FPCUnitProject1;'+le
+le
+'{$mode objfpc}{$H+}'+le
+le
+'uses'+le
+' custapp, classes, sysutils, fpcunit, testreport, testregistry;'+le
+le
+'Const'+le
+' ShortOpts = ''alh'';'+le
+' Longopts : Array[1..5] of String = ('+le
+' ''all'',''list'',''format:'',''suite:'',''help'');'+le
+' Version = ''Version 0.1'';'+le
+le
+'Type'+le
+' TTestRunner = Class(TCustomApplication)'+le
+' private'+le
+' FXMLResultsWriter: TXMLResultsWriter;'+le
+' protected'+le
+' procedure DoRun ; Override;'+le
+' procedure doTestRun(aTest: TTest); virtual;'+le
+' public'+le
+' constructor Create(AOwner: TComponent); override;'+le
+' destructor Destroy; override;'+le
+' end;'+le
+le
+'constructor TTestRunner.Create(AOwner: TComponent);'+le
+'begin'+le
+' inherited Create(AOwner);'+le
+' FXMLResultsWriter := TXMLResultsWriter.Create;'+le
+'end;'+le
+le
+'destructor TTestRunner.Destroy;'+le
+'begin'+le
+' FXMLResultsWriter.Free;'+le
+'end;'+le
+le
+'procedure TTestRunner.doTestRun(aTest: TTest);'+le
+'var'+le
+' testResult: TTestResult;'+le
+'begin'+le
+' testResult := TTestResult.Create;'+le
+' try'+le
+' testResult.AddListener(FXMLResultsWriter);'+le
+' FXMLResultsWriter.WriteHeader;'+le
+' aTest.Run(testResult);'+le
+' FXMLResultsWriter.WriteResult(testResult);'+le
+' finally'+le
+' testResult.Free;'+le
+' end;'+le
+'end;'+le
+le
+'procedure TTestRunner.DoRun;'+le
+'var'+le
+' I : Integer;'+le
+' S : String;'+le
+'begin'+le
+' S:=CheckOptions(ShortOpts,LongOpts);'+le
+' If (S<>'''') then'+le
+' Writeln(S);'+le
+' if HasOption(''h'', ''help'') or (ParamCount = 0) then'+le
+' begin'+le
+' writeln(Title);'+le
+' writeln(Version);'+le
+' writeln(''Usage: '');'+le
+' writeln(''-l or --list to show a list of registered tests'');'+le
+' writeln(''default format is xml, add --format=latex to output the list as latex source'');'+le
+' writeln(''-a or --all to run all the tests and show the results in xml format'');'+le
+' writeln(''The results can be redirected to an xml file,'');'+le
+' writeln(''for example: ./testrunner --all > results.xml'');'+le
+' writeln(''use --suite=MyTestSuiteName to run only the tests in a single test suite class'');'+le
+' end;'+le
+' if HasOption(''l'', ''list'') then'+le
+' begin'+le
+' if HasOption(''format'') then'+le
+' begin'+le
+' if GetOptionValue(''format'') = ''latex'' then'+le
+' writeln(GetSuiteAsLatex(GetTestRegistry))'+le
+' else'+le
+' writeln(GetSuiteAsXML(GetTestRegistry));'+le
+' end'+le
+' else'+le
+' writeln(GetSuiteAsXML(GetTestRegistry));'+le
+' end;'+le
+' if HasOption(''a'', ''all'') then'+le
+' begin'+le
+' doTestRun(GetTestRegistry)'+le
+' end'+le
+' else'+le
+' if HasOption(''suite'') then'+le
+' begin'+le
+' S := '''';'+le
+' S:=GetOptionValue(''suite'');'+le
+' if S = '''' then'+le
+' for I := 0 to GetTestRegistry.Tests.count - 1 do'+le
+' writeln(GetTestRegistry[i].TestName)'+le
+' else'+le
+' for I := 0 to GetTestRegistry.Tests.count - 1 do'+le
+' if GetTestRegistry[i].TestName = S then'+le
+' begin'+le
+' doTestRun(GetTestRegistry[i]);'+le
+' end;'+le
+' end;'+le
+' Terminate;'+le
+'end;'+le
+le
+'Var'+le
+' App : TTestRunner;'+le
+le
+'begin'+le
+' App:=TTestRunner.Create(Nil);'+le
+' App.Initialize;'+le
+' App.Title := ''FPCUnit Console Test Case runner.'';'+le
+' App.Run;'+le
+' App.Free;'+le
+'end.'+le
+le;
{$i fpcunitproject1.inc}
AProject.MainFile.SetSourceText(NewSource);
// add
// add FCL dependency
AProject.AddPackageDependency('FCL');
AProject.AddPackageDependency('FPCUnitTestRunner');
// compiler options
AProject.LazCompilerOptions.UseLineInfoUnit:=true;

160
components/fpcunit/ide/fpcunitproject1.inc Normal file
View File

@ -0,0 +1,160 @@
NewSource :=
'program FPCUnitProject1;' + #13
+ #13
+ '{$mode objfpc}{$H+}' + #13
+ #13
+ 'uses' + #13
+ ' custapp, Classes, SysUtils, fpcunit, testreport, testregistry;' + #13
+ #13
+ 'const' + #13
+ ' ShortOpts = ''alh'';' + #13
+ ' Longopts: array[1..5] of string = (''all'', ''list'', ''format:'', ''suite:'', ''help'');' + #13
+ ' Version = ''Version 0.1'';' + #13
+ #13
+ 'type' + #13
+ ' TFormat = (fPlain, fLatex, fXML);' + #13
+ #13
+ ' TTestRunner = class(TCustomApplication)' + #13
+ ' private' + #13
+ ' protected' + #13
+ ' procedure DoRun; override;' + #13
+ ' procedure doTestRun(aTest: TTest); virtual;' + #13
+ ' public' + #13
+ ' end;' + #13
+ #13
+ 'var' + #13
+ ' FormatParam: TFormat;' + #13
+ #13
+ ' procedure TTestRunner.doTestRun(aTest: TTest);' + #13
+ ' var' + #13
+ ' testResult: TTestResult;' + #13
+ #13
+ ' procedure doXMLTestRun(aText: TTest);' + #13
+ ' var' + #13
+ ' XMLResultsWriter: TXMLResultsWriter;' + #13
+ ' begin' + #13
+ ' try' + #13
+ ' XMLResultsWriter := TXMLResultsWriter.Create;' + #13
+ ' testResult.AddListener(XMLResultsWriter);' + #13
+ ' XMLResultsWriter.WriteHeader;' + #13
+ ' aTest.Run(testResult);' + #13
+ ' XMLResultsWriter.WriteResult(testResult);' + #13
+ ' finally' + #13
+ ' XMLResultsWriter.Free;' + #13
+ ' testResult.Free;' + #13
+ ' end;' + #13
+ ' end;' + #13
+ #13
+ ' {$IFNDEF VER2_0}' + #13
+ ' procedure doPlainTestRun(aText: TTest);' + #13
+ ' var' + #13
+ ' PlainResultsWriter: TPlainResultsWriter;' + #13
+ ' begin' + #13
+ ' try' + #13
+ ' PlainResultsWriter := TPlainResultsWriter.Create;' + #13
+ ' testResult.AddListener(PlainResultsWriter);' + #13
+ ' PlainResultsWriter.WriteHeader;' + #13
+ ' aTest.Run(testResult);' + #13
+ ' PlainResultsWriter.WriteResult(testResult);' + #13
+ ' finally' + #13
+ ' PlainResultsWriter.Free;' + #13
+ ' testResult.Free;' + #13
+ ' end;' + #13
+ ' end;' + #13
+ ' {$ENDIF}' + #13
+ #13
+ ' begin' + #13
+ ' testResult := TTestResult.Create;' + #13
+ #13
+ ' case FormatParam of' + #13
+ ' fLatex: doXMLTestRun(aTest); //no latex implemented yet' + #13
+ ' {$IFNDEF VER2_0}' + #13
+ ' fPlain: doPlainTestRun(aTest);' + #13
+ ' {$ENDIF}' + #13
+ ' else' + #13
+ ' doXMLTestRun(aTest);' + #13
+ ' end;' + #13
+ ' end;' + #13
+ #13
+ ' procedure TTestRunner.DoRun;' + #13
+ ' var' + #13
+ ' I: integer;' + #13
+ ' S: string;' + #13
+ ' begin' + #13
+ ' S := CheckOptions(ShortOpts, LongOpts);' + #13
+ ' if (S <> '''') then' + #13
+ ' Writeln(S);' + #13
+ #13
+ ' if HasOption(''h'', ''help'') or (ParamCount = 0) then' + #13
+ ' begin' + #13
+ ' writeln(Title);' + #13
+ ' writeln(Version);' + #13
+ ' writeln;' + #13
+ ' writeln(''Usage: '');' + #13
+ ' writeln('' --format=latex output as latex source (only list implemented)'');' + #13
+ ' {$IFNDEF VER2_0}' + #13
+ ' writeln('' --format=plain output as plain ASCII source'');' + #13
+ ' {$ENDIF}' + #13
+ ' writeln('' --format=xml output as XML source (default)'');' + #13
+ ' writeln;' + #13
+ ' writeln('' -l or --list show a list of registered tests'');' + #13
+ ' writeln('' -a or --all run all tests'');' + #13
+ ' writeln('' --suite=MyTestSuiteName run single test suite class'');' + #13
+ ' writeln;' + #13
+ ' writeln(''The results can be redirected to an xml file,'');' + #13
+ ' writeln(''for example: ./testrunner --all > results.xml'');' + #13
+ ' end;' + #13
+ #13
+ ' //get the format parameter' + #13
+ ' FormatParam := fXML;' + #13
+ ' if HasOption(''format'') then' + #13
+ ' begin' + #13
+ ' if GetOptionValue(''format'') = ''latex'' then' + #13
+ ' FormatParam := fLatex;' + #13
+ ' {$IFNDEF VER2_0}' + #13
+ ' if GetOptionValue(''format'') = ''plain'' then' + #13
+ ' FormatParam := fPlain;' + #13
+ ' {$ENDIF}' + #13
+ ' end;' + #13
+ #13
+ ' //get a list of all registed tests' + #13
+ ' if HasOption(''l'', ''list'') then' + #13
+ ' case FormatParam of' + #13
+ ' fLatex: Write(GetSuiteAsLatex(GetTestRegistry));' + #13
+ ' {$IFNDEF VER2_0}' + #13
+ ' fPlain: Write(GetSuiteAsPlain(GetTestRegistry));' + #13
+ ' {$ENDIF}' + #13
+ ' else' + #13
+ ' Write(GetSuiteAsXML(GetTestRegistry));' + #13
+ ' end;' + #13
+ #13
+ ' //run the tests' + #13
+ ' if HasOption(''a'', ''all'') then' + #13
+ ' doTestRun(GetTestRegistry)' + #13
+ ' else' + #13
+ ' if HasOption(''suite'') then' + #13
+ ' begin' + #13
+ ' S := '''';' + #13
+ ' S := GetOptionValue(''suite'');' + #13
+ ' if S = '''' then' + #13
+ ' for I := 0 to GetTestRegistry.Tests.Count - 1 do' + #13
+ ' writeln(GetTestRegistry[i].TestName)' + #13
+ ' else' + #13
+ ' for I := 0 to GetTestRegistry.Tests.Count - 1 do' + #13
+ ' if GetTestRegistry[i].TestName = S then' + #13
+ ' doTestRun(GetTestRegistry[i]);' + #13
+ ' end;' + #13
+ ' Terminate;' + #13
+ ' end;' + #13
+ #13
+ 'var' + #13
+ ' App: TTestRunner;' + #13
+ #13
+ 'begin' + #13
+ ' App := TTestRunner.Create(nil);' + #13
+ ' App.Initialize;' + #13
+ ' App.Title := ''FPCUnit Console Test Case runner.'';' + #13
+ ' App.Run;' + #13
+ ' App.Free;' + #13
+ 'end.' + #13
;

217
components/fpcunit/xmlreporter.pas
View File

@ -1,217 +0,0 @@
{
Copyright (C) 2006 Graeme Geldenhuys <graemeg@gmail.com>
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.
Purpose:
This unit contains a XML TestListener for use with the fpcUnit testing
framework. It uses the XMLWrite unit, which is part of FPC, to generate
the XML document. The benefit of using the XMLWrite unit, is that the
data generated is valid XML, with resevered characters correctly escaped.
This allows the XML document to be further processed with XSTL etc without
any issues.
Note:
This unit will possibly move at a later stage to the FPC repository.
It can't now (pre FPC 2.0.3) otherwise nobody will be able to use the new
XML funtionality in the GUITestRunner.
}
unit xmlreporter;
{$mode objfpc}{$H+}
interface
uses
Classes
,SysUtils
,fpcUnit
,TestUtils
,dom
,XMLWrite
;
type
{ XML Test Listner }
TXMLResultsWriter = class(TNoRefCountObject, ITestListener)
private
FDoc: TXMLDocument;
{ These TDOMNodes are for easy access and a bit of optimization }
FResults: TDOMNode;
FListing: TDOMNode;
FFailures: TDOMNode;
FErrors: TDOMNode;
{ Converts the actual test results into XML nodes. This gets called
by the public method WriteResult. }
procedure TestResultAsXML(pTestResult: TTestResult);
{ This gets called in the class constructor and sets up the starting nodes }
procedure WriteHeader;
public
constructor Create;
destructor Destroy; override;
procedure WriteResult(aResult: TTestResult);
{ ITestListener interface requirements }
procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
procedure AddError(ATest: TTest; AError: TTestFailure);
procedure StartTest(ATest: TTest);
procedure EndTest(ATest: TTest);
{ A public property to the internal XML document }
property Document: TXMLDocument read FDoc;
end;
implementation
{ TXMLResultsWriter }
procedure TXMLResultsWriter.TestResultAsXML(pTestResult: TTestResult);
var
i: longint;
n, lResults: TDOMNode;
begin
lResults := FDoc.FindNode('TestResults');
n := FDoc.CreateElement('NumberOfRunnedTests');
n.AppendChild(FDoc.CreateTextNode(IntToStr(pTestResult.RunTests)));
lResults.AppendChild(n);
n := FDoc.CreateElement('NumberOfErrors');
n.AppendChild(FDoc.CreateTextNode(IntToStr(pTestResult.NumberOfErrors)));
lResults.AppendChild(n);
n := FDoc.CreateElement('NumberOfFailures');
n.AppendChild(FDoc.CreateTextNode(IntToStr(pTestResult.NumberOfFailures)));
lResults.AppendChild(n);
if pTestResult.NumberOfErrors <> 0 then
begin
for i := 0 to pTestResult.Errors.Count - 1 do
AddError(nil, TTestFailure(pTestResult.Errors.Items[i]));
end;
if pTestResult.NumberOfFailures <> 0 then
begin
for i := 0 to pTestResult.Failures.Count - 1 do
AddFailure(nil, TTestFailure(pTestResult.Failures.Items[i]));
end;
end;
procedure TXMLResultsWriter.WriteHeader;
begin
FResults := FDoc.CreateElement('TestResults');
FResults.AppendChild(FDoc.CreateComment(' Generated using FPCUnit on '
+ FormatDateTime('yyyy-mm-dd hh:mm ', Now) ));
FDoc.AppendChild(FResults);
FListing := FDoc.CreateElement('TestListing');
FResults.AppendChild(FListing);
end;
constructor TXMLResultsWriter.Create;
begin
FDoc := TXMLDocument.Create;
FResults := nil;
FFailures := nil;
FErrors := nil;
WriteHeader;
end;
destructor TXMLResultsWriter.Destroy;
begin
FDoc.Free;
inherited Destroy;
end;
procedure TXMLResultsWriter.WriteResult(aResult: TTestResult);
begin
TestResultAsXML(aResult);
end;
procedure TXMLResultsWriter.AddFailure(ATest: TTest; AFailure: TTestFailure);
var
n: TDOMElement;
begin
{ Try and find the node first }
if not Assigned(FFailures) then
FFailures := FDoc.FindNode('ListOfFailures');
{ If we couldn't find it, create it }
if not Assigned(FFailures) then
begin
FFailures := FDoc.CreateElement('ListOfFailures');
FResults.AppendChild(FFailures);
end;
n := FDoc.CreateElement('Failure');
n.AppendChild(FDoc.CreateElement('Message') ).AppendChild(FDoc.CreateTextNode(AFailure.AsString));
n.AppendChild(FDoc.CreateElement('ExceptionClass') ).AppendChild(FDoc.CreateTextNode(AFailure.ExceptionClassName));
n.AppendChild(FDoc.CreateElement('ExceptionMessage')).AppendChild(FDoc.CreateTextNode(AFailure.ExceptionMessage));
FFailures.AppendChild(n);
end;
procedure TXMLResultsWriter.AddError(ATest: TTest; AError: TTestFailure);
var
n: TDOMElement;
begin
{ Try and find the node first }
if not Assigned(FErrors) then
FErrors := FDoc.FindNode('ListOfErrors');
{ If we couldn't find it, create it }
if not Assigned(FErrors) then
begin
FErrors := FDoc.CreateElement('ListOfErrors');
FResults.AppendChild(FErrors);
end;
n := FDoc.CreateElement('Error');
n.AppendChild(FDoc.CreateElement('Message') ).AppendChild(FDoc.CreateTextNode(AError.AsString));
n.AppendChild(FDoc.CreateElement('ExceptionClass') ).AppendChild(FDoc.CreateTextNode(AError.ExceptionClassName));
n.AppendChild(FDoc.CreateElement('ExceptionMessage')).AppendChild(FDoc.CreateTextNode(AError.ExceptionMessage));
n.AppendChild(FDoc.CreateElement('SourceUnitName') ).AppendChild(FDoc.CreateTextNode(AError.SourceUnitName));
n.AppendChild(FDoc.CreateElement('LineNumber') ).AppendChild(FDoc.CreateTextNode(IntToStr(AError.LineNumber)));
n.AppendChild(FDoc.CreateElement('FailedMethodName')).AppendChild(FDoc.CreateTextNode(AError.FailedMethodName));
FErrors.AppendChild(n);
end;
procedure TXMLResultsWriter.StartTest(ATest: TTest);
var
n: TDOMElement;
begin
if not Assigned(FListing) then
exit;
n := FDoc.CreateElement('Test');
n['Name'] := ATest.TestSuiteName + '.' + ATest.TestName;
FListing.AppendChild(n);
end;
procedure TXMLResultsWriter.EndTest(ATest: TTest);
begin
{ do nothing }
end;
end.