paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 23:21:57 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Rework test tree construction, finding tests (bug ID 30384)

Browse Source 
git-svn-id: trunk@34473 -
This commit is contained in:
michael 2016-09-10 10:17:20 +00:00
parent 627e30f47f
commit 1e36144e87
6 changed files with 155 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
packages/fcl-fpcunit/src/consoletestrunner.pas
View File

@ -314,60 +314,11 @@ end;
procedure TTestRunner.DoRun;
procedure CheckTestRegistry (test:TTest; ATestName:string; res : TTestSuite);
var s, c : string;
I, p : integer;
ds : TTestSuite;
D : TTestDecorator;
begin
if (test is TTestSuite) or (test is TTestDecorator) 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
res.AddTest(test)
else if (CompareText( s, Test.TestName) = 0) or (s = '') then
begin
if (test is ttestsuite) then
begin
for I := 0 to TTestSuite(test).ChildTestCount - 1 do
CheckTestRegistry ((test as TTestSuite).Test[I], c, res)
end
else if (test is TTestDecorator) then
begin
DS:=TDecoratorTestSuite.Create;
CheckTestRegistry(TTest((test as TTestDecorator).Test), c, ds);
if (ds.CountTestCases>0) then
begin
D:=TTestDecoratorClass(Test.ClassType).Create(DS);
Res.AddTest(D);
end
else
DS.free;
end;
end;
end
else // if test is TTestCase then
begin
if comparetext(test.TestName, ATestName) = 0 then
res.AddTest(test);
end;
end;
var
I,P : integer;
S : string;
S,TN : string;
TS : TDecoratorTestSuite;
T : TTest;
begin
S := CheckOptions(GetShortOpts, LongOpts);
@ -383,7 +334,7 @@ begin
fPlain: Write(GetSuiteAsPlain(GetTestRegistry));
fPlainNoTiming: Write(GetSuiteAsPlain(GetTestRegistry));
else
Write(GetSuiteAsXml(GetTestRegistry));;
Write(GetSuiteAsXml(GetTestRegistry));
end;
//run the tests
@ -400,19 +351,17 @@ begin
try
while Not(S = '') Do
begin
P:=Pos(',',S);
if P = 0 Then
begin
for I := 0 to GetTestRegistry.ChildTestCount-1 do
CheckTestRegistry (GetTestregistry[I], S, TS);
S := '';
end
else
begin
for I := 0 to GetTestRegistry.ChildTestCount-1 do
CheckTestRegistry (GetTestregistry[I],Copy(S, 1,P - 1), TS);
Delete(S, 1, P);
end;
P:=Pos(',',S);
If P=0 then
P:=Length(S)+1;
TN:=Copy(S,1,P-1);
Delete(S,1,P);
if (TN<>'') then
begin
T:=GetTestRegistry.FindTest(TN);
if Assigned(T) then
TS.AddTest(T);
end;
end;
if (TS.CountTestCases>1) then
DoTestRun(TS)

83
packages/fcl-fpcunit/src/fpcunit.pp
View File

@ -54,7 +54,11 @@ type
TTestSuite = class;
{$M+}
{ TTest }
TTest = class(TObject)
private
protected
FLastStep: TTestStep;
function GetTestName: string; virtual;
@ -64,6 +68,10 @@ type
procedure SetEnableIgnores(Value: boolean); virtual; abstract;
public
function CountTestCases: integer; virtual;
Function GetChildTestCount : Integer; virtual;
Function GetChildTest(AIndex : Integer) : TTest; virtual;
function FindChildTest(const AName: String): TTest;
Function FindTest(Const AName : String) : TTest;
procedure Run(AResult: TTestResult); virtual;
procedure Ignore(const AMessage: string);
published
@ -240,8 +248,6 @@ type
FName: string;
FTestSuiteName: string;
FEnableIgnores: boolean;
function GetTest(Index: integer): TTest;
function GetTestCount: Integer;
protected
Function DoAddTest(ATest : TTest) : Integer;
function GetTestName: string; override;
@ -258,13 +264,15 @@ type
constructor Create; reintroduce; overload; virtual;
destructor Destroy; override;
function CountTestCases: integer; override;
Function GetChildTestCount : Integer; override;
Function GetChildTest(AIndex : Integer) : TTest; override;
procedure Run(AResult: TTestResult); override;
procedure RunTest(ATest: TTest; AResult: TTestResult); virtual;
procedure AddTest(ATest: TTest); overload; virtual;
procedure AddTestSuiteFromClass(ATestClass: TClass); virtual;
class function Warning(const aMessage: string): TTestCase;
property Test[Index: integer]: TTest read GetTest; default;
Property ChildTestCount : Integer Read GetTestCount;
property Test[Index: integer]: TTest read GetChildTest; default;
Property ChildTestCount : Integer Read GetChildTestCount;
property TestSuiteName: string read GetTestSuiteName write SetTestSuiteName;
property TestName: string read GetTestName write SetTestName;
// Only for backwards compatibility. Use Test and ChildTestCount.
@ -538,6 +546,65 @@ begin
Result := 0;
end;
function TTest.GetChildTestCount: Integer;
begin
Result:=0;
end;
function TTest.GetChildTest(AIndex: Integer): TTest;
begin
Result:=Nil;
end;
function TTest.FindChildTest(const AName: String): TTest;
Var
I : Integer;
begin
Result:=Nil;
I:=GetChildTestCount-1;
While (Result=Nil) and (I>=0) do
begin
Result:=GetChildTest(I);
if CompareText(Result.TestName,AName)<>0 then
Result:=Nil;
Dec(I);
end;
end;
function TTest.FindTest(const AName: String): TTest;
Var
S : String;
I,P : Integer;
begin
Result:=Nil;
S:=AName;
if S='' then exit;
P:=Pos('.',S);
If (P=0) then
P:=Length(S)+1;
Result:=FindChildTest(Copy(S,1,P-1));
if (Result<>Nil) then
begin
Delete(S,1,P);
If (S<>'') then
Result:=Result.FindTest(S);
end
else
begin
P:=GetChildTestCount;
I:=0;
While (Result=Nil) and (I<P) do
begin
Result:=GetChildTest(I).FindTest(Aname);
Inc(I);
end;
end;
end;
function TTest.GetEnableIgnores: boolean;
begin
Result := True;
@ -548,7 +615,7 @@ begin
{ do nothing }
end;
procedure TTest.Ignore(const AMessage: String);
procedure TTest.Ignore(const AMessage: string);
begin
if EnableIgnores then raise EIgnoredTest.Create(AMessage);
end;
@ -1197,12 +1264,12 @@ begin
end;
function TTestSuite.GetTest(Index: integer): TTest;
function TTestSuite.GetChildTest(AIndex: integer): TTest;
begin
Result := TTestItem(FTests[Index]).Test;
Result := TTestItem(FTests[AIndex]).Test;
end;
function TTestSuite.GetTestCount: Integer;
function TTestSuite.GetChildTestCount: Integer;
begin
Result:=FTests.Count;
end;

37
packages/fcl-fpcunit/src/latextestreport.pp
View File

@ -51,7 +51,7 @@ type
procedure EndTest(ATest: TTest); override;
end;
function TestSuiteAsLatex(aSuite:TTestSuite): string;
function TestSuiteAsLatex(aSuite:TTest): string;
function GetSuiteAsLatex(aSuite: TTestSuite): string;
implementation
@ -250,27 +250,26 @@ begin
end;
function TestSuiteAsLatex(aSuite:TTestSuite): string;
function TestSuiteAsLatex(aSuite:TTest): string;
var
i,j: integer;
s: TTestSuite;
begin
Result := TLatexResultsWriter.EscapeText(aSuite.TestSuiteName) + System.sLineBreak;
Result := Result + '\begin{itemize}'+ System.sLineBreak;
for i := 0 to aSuite.ChildTestCount - 1 do
if ASuite.Test[i] is TTestSuite then
begin
Result:=Result + '\item[-] ';
Result := Result + '\flushleft' + System.sLineBreak;
Result:=Result+TestSuiteAsLatex(TTestSuite(ASuite.Test[i]))+System.sLineBreak;
end
else
begin
Result := Result + '\item[-] ' +
TLatexResultsWriter.EscapeText(TTestcase(aSuite.Test[i]).TestName)
+ System.sLineBreak;
end;
Result := Result +'\end{itemize}' + System.sLineBreak;
Result:='';
if (aSuite.TestName<>'') then
begin
Result:=Result + '\item[-] ';
Result:=Result+TLatexResultsWriter.EscapeText(ASuite.TestName)+slineBreak
end;
if aSuite.GetChildTestCount>0 then
begin
Result := Result + '\begin{itemize}'+ System.sLineBreak;
for i:=0 to Pred(aSuite.GetChildTestCount) do
Result:=Result+TestSuiteAsLatex(aSuite.GetChildTest(i));
if (aSuite.TestName<>'') then
Result := Result +'\end{itemize}' + System.sLineBreak;
end
end;
@ -284,7 +283,9 @@ begin
Result := Result + '\begin{document}' + System.sLineBreak + System.sLineBreak;
if aSuite.TestName = '' then
aSuite.TestName := 'Test Suite';
Result := Result + '\begin{itemize}'+ System.sLineBreak;
Result := Result + TestSuiteAsLatex(aSuite);
Result := Result +'\end{itemize}' + System.sLineBreak;
Result := Result + '\end{document}';
end
else

27
packages/fcl-fpcunit/src/plaintestreport.pp
View File

@ -19,7 +19,7 @@ unit plaintestreport;
interface
uses
classes, SysUtils, fpcunit, fpcunitreport;
classes, SysUtils, fpcunit, fpcunitreport, testdecorator;
type
TTestResultOption = (ttoSkipAddress,ttoSkipExceptionMessage,ttoErrorsOnly);
@ -208,22 +208,21 @@ begin
FSuiteHeaderIdx.Add(Pointer(FDoc.Count - 1));
end;
function DoTestSuiteAsPlain(aSuite:TTestSuite; Prefix : String; Options : TTestResultOptions = []): string;
function DoTestSuiteAsPlain(aSuite:TTest; Prefix : String; Options : TTestResultOptions = []): string;
var
i: integer;
p : string;
begin
Result := Prefix+ASuite.TestName+System.sLineBreak;
for i := 0 to aSuite.ChildTestCount - 1 do
if aSuite.Test[i] is TTestSuite then
begin
P:=Prefix;
if (ASuite.TestName<>'') then
P:=P+' ';
Result := Result + DoTestSuiteAsPlain(TTestSuite(aSuite.Test[i]),P,Options);
end
else if aSuite.Test[i] is TTestCase then
Result := Result + Prefix+' ' + ASuite.TestName+'.' + TTestcase(aSuite.Test[i]).TestName + System.sLineBreak;
if (ASuite.TestSuiteName<>'') then
begin
Prefix:=' '+Prefix;
Prefix:=Prefix+ASuite.TestSuiteName+'.';
end;
if (ASuite.TestName<>'') then
Result := Prefix+ASuite.TestName+System.sLineBreak;
for i := 0 to aSuite.GetChildTestCount - 1 do
Result := Result + DoTestSuiteAsPlain(aSuite.GetChildTest(i),Prefix,Options);
end;
function TestSuiteAsPlain(aSuite:TTestSuite; Options : TTestResultOptions = []): string;

16
packages/fcl-fpcunit/src/testdecorator.pp
View File

@ -27,16 +27,18 @@ type
{ TTestDecorator }
TTestDecorator = class(TAssert)
TTestDecorator = class(TTest{Assert})
private
FTest: TTest;
protected
function GetTestName: string; override;
function GetTestSuiteName: string; override;
procedure SetTestSuiteName(const aName: string); override;
protected
function GetEnableIgnores: boolean; override;
procedure SetEnableIgnores(Value: boolean); override;
public
Function GetChildTest(AIndex: Integer): TTest; override;
Function GetChildTestCount : Integer; override;
function CountTestCases: integer; override;
constructor Create(aTest: TTest); reintroduce; overload;
destructor Destroy; override;
@ -84,6 +86,16 @@ begin
FTest.EnableIgnores := Value;
end;
function TTestDecorator.GetChildTest(AIndex: Integer): TTest;
begin
Result:=FTest.GetChildTest(AIndex);
end;
function TTestDecorator.GetChildTestCount: Integer;
begin
Result:=FTest.GetChildTestCount;
end;
function TTestDecorator.CountTestCases: integer;
begin
Result := FTest.CountTestCases;

38
packages/fcl-fpcunit/src/xmltestreport.pp
View File

@ -70,7 +70,7 @@ type
end;
function GetSuiteAsXML(aSuite: TTestSuite): string;
function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTestSuite): string;
function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTest): string;
implementation
@ -93,35 +93,37 @@ begin
stream := TStringStream.Create('');
WriteXMLFile(FDoc, stream);
writeln(stream.DataString);
Result:=stream.DataString;
stream.Free;
end;
end;
function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTestSuite): string;
function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTest): string;
var
i: integer;
E,T : TDomElement;
begin
if aSuite.TestName<>'' then
Result:='';
if aSuite.GetChildTestCount>0 then
begin
E:=FDoc.CreateElement('Suite');
E['Name']:=aSuite.TestName;
N.AppendChild(E);
if (aSuite.TestName='') then
E:=N
else
begin
E:=FDoc.CreateElement('Suite');
E['Name']:=aSuite.TestName;
N.AppendChild(E);
end;
for i:=0 to Pred(aSuite.GetChildTestCount) do
TestSuiteAsXML(E,FDoc,aSuite.GetChildTest(i));
end
else
E:=N;
for i:=0 to Pred(aSuite.ChildTestCount) do
if TTest(aSuite.Test[i]) is TTestSuite then
TestSuiteAsXML(E, FDoc, TTestSuite(aSuite.Test[i]))
else
if TTest(aSuite.Test[i]) is TTestCase then
begin
T:=FDoc.CreateElement('Test');
T['name']:=TTestCase(aSuite.Test[i]).TestName;
E.AppendChild(T);
end;
begin
T:=FDoc.CreateElement('Test');
T['name']:=aSuite.TestName;
N.AppendChild(T);
end;
end;