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

* Hopefully fix bug #29722 (wrong handling of TTestItem list)

Browse Source 
git-svn-id: trunk@33206 -
This commit is contained in:
michael 2016-03-08 10:04:15 +00:00
parent cad30aaee9
commit caec08e795
7 changed files with 71 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -295,8 +295,8 @@ Var
I : Integer;
begin
If (T is TTestSuite) then
for I:=0 to TTestSuite(t).Tests.Count-1 do
FreeDecorators(TTest(TTestSuite(t).Tests[i]));
for I:=0 to TTestSuite(t).ChildTestCount-1 do
FreeDecorators(TTest(TTestSuite(t).Test[i]));
if (T is TTestDecorator) and (TTestDecorator(T).Test is TDecoratorTestSuite) then
T.free;
end;
@ -339,7 +339,7 @@ procedure TTestRunner.DoRun;
begin
if (test is ttestsuite) then
begin
for I := 0 to TTestSuite(test).Tests.Count - 1 do
for I := 0 to TTestSuite(test).ChildTestCount - 1 do
CheckTestRegistry ((test as TTestSuite).Test[I], c, res)
end
else if (test is TTestDecorator) then
@ -391,7 +391,7 @@ begin
S := '';
S := GetOptionValue('suite');
if S = '' then
for I := 0 to GetTestRegistry.Tests.Count - 1 do
for I := 0 to GetTestRegistry.ChildTestCount - 1 do
writeln(GetTestRegistry[i].TestName)
else
begin
@ -402,13 +402,13 @@ begin
P:=Pos(',',S);
if P = 0 Then
begin
for I := 0 to GetTestRegistry.Tests.count-1 do
for I := 0 to GetTestRegistry.ChildTestCount-1 do
CheckTestRegistry (GetTestregistry[I], S, TS);
S := '';
end
else
begin
for I := 0 to GetTestRegistry.Tests.count-1 do
for I := 0 to GetTestRegistry.ChildTestCount-1 do
CheckTestRegistry (GetTestregistry[I],Copy(S, 1,P - 1), TS);
Delete(S, 1, P);
end;

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

@ -241,6 +241,7 @@ type
FTestSuiteName: string;
FEnableIgnores: boolean;
function GetTest(Index: integer): TTest;
function GetTestCount: Integer;
protected
Function DoAddTest(ATest : TTest) : Integer;
function GetTestName: string; override;
@ -263,9 +264,11 @@ type
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 TestSuiteName: string read GetTestSuiteName write SetTestSuiteName;
property TestName: string read GetTestName write SetTestName;
property Tests: TFPList read FTests;
// Only for backwards compatibility. Use Test and ChildTestCount.
property Tests: TFPList read FTests; deprecated;
end;
TProtect = procedure(aTest: TTest; aResult: TTestResult);
@ -1199,6 +1202,11 @@ begin
Result := TTestItem(FTests[Index]).Test;
end;
function TTestSuite.GetTestCount: Integer;
begin
Result:=FTests.Count;
end;
function TTestSuite.DoAddTest(ATest: TTest): Integer;
begin
Result:=FTests.Add(TTestItem.Create(ATest));

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

@ -257,7 +257,7 @@ var
begin
Result := TLatexResultsWriter.EscapeText(aSuite.TestSuiteName) + System.sLineBreak;
Result := Result + '\begin{itemize}'+ System.sLineBreak;
for i := 0 to aSuite.CountTestCases - 1 do
for i := 0 to aSuite.ChildTestCount - 1 do
if ASuite.Test[i] is TTestSuite then
begin
Result:=Result + '\item[-] ';

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

@ -214,7 +214,7 @@ var
p : string;
begin
Result := Prefix+ASuite.TestName+System.sLineBreak;
for i := 0 to aSuite.CountTestCases - 1 do
for i := 0 to aSuite.ChildTestCount - 1 do
if aSuite.Test[i] is TTestSuite then
begin
P:=Prefix;

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

@ -63,7 +63,7 @@ var
lSuiteName: String;
lPathRemainder: String;
lDotPos: Integer;
lTests: TFPList;
begin
if APath = '' then
begin
@ -89,19 +89,15 @@ begin
// Check to see if the path already exists
lTargetSuite := nil;
lTests := ARootSuite.Tests;
for i := 0 to lTests.Count -1 do
begin
lCurrentTest := TTest(lTests[i]);
if lCurrentTest is TTestSuite then
I:=0;
While (lTargetSuite=Nil) and (I<ARootSuite.ChildTestCount) do
begin
lCurrentTest:= ARootSuite.Test[i];
if lCurrentTest is TTestSuite then
if (lCurrentTest.TestName = lSuiteName) then
begin
lTargetSuite := TTestSuite(lCurrentTest);
break;
end;
Inc(I);
end; { if }
end; { for }
if not Assigned(lTargetSuite) then
begin

68
packages/fcl-fpcunit/src/testreport.pp
View File

@ -186,33 +186,59 @@ var
begin
Result := StringOfChar(' ',Indent) + '<TestSuite name="' + ASuite.TestName + '">' + System.sLineBreak;
Inc(Indent, 2);
for i := 0 to aSuite.Tests.Count - 1 do
if TTest(aSuite.Tests.Items[i]) is TTestSuite then
Result := Result + TestSuiteAsXML(TTestSuite(aSuite.Tests.Items[i]),Indent)
for i := 0 to aSuite.ChildTestCount - 1 do
if TTest(aSuite.Test[i]) is TTestSuite then
Result := Result + TestSuiteAsXML(TTestSuite(aSuite.Test[i]),Indent)
else
if TTest(aSuite.Tests.Items[i]) is TTestCase then
Result := Result + StringOfChar(' ',Indent) + '<test>' + TTestcase(aSuite.Tests.Items[i]).TestName + '</test>' + System.sLineBreak;
if TTest(aSuite.Test[i]) is TTestCase then
Result := Result + StringOfChar(' ',Indent) + '<test>' + TTestcase(aSuite.Test[i]).TestName + '</test>' + System.sLineBreak;
Dec(Indent, 2);
Result := Result + StringOfChar(' ',Indent) + '</TestSuite>' + System.sLineBreak;
end;
function EscapeText(const S: string): String;
var
i: integer;
begin
SetLength(Result, 0);
for i := 1 to Length(S) do
case S[i] of
'&','{','}','#','_','$','%': // Escape these characters
Result := Result + '\' + S[i];
'~','^':
Result := Result + '\'+S[i]+' ';
'\':
Result := Result + '$\backslash$';
'<':
Result := Result + '$<$';
'>':
Result := Result + '$>$'
else
Result := Result + S[i];
end;
end;
function TestSuiteAsLatex(aSuite:TTestSuite): string;
var
i,j: integer;
s: TTestSuite;
begin
Result := '\flushleft' + System.sLineBreak;
for i := 0 to aSuite.Tests.Count - 1 do
begin
s := TTestSuite(ASuite.Tests.Items[i]);
Result := Result + s.TestSuiteName + System.sLineBreak;
Result := Result + '\begin{itemize}'+ System.sLineBreak;
for j := 0 to s.Tests.Count - 1 do
if TTest(s.Tests.Items[j]) is TTestCase then
Result := Result + '\item[-] ' + TTestcase(s.Tests.Items[j]).TestName + System.sLineBreak;
Result := Result +'\end{itemize}' + System.sLineBreak;
end;
Result := 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[-] ' +
EscapeText(TTestcase(aSuite.Test[i]).TestName)
+ System.sLineBreak;
end;
Result := Result +'\end{itemize}' + System.sLineBreak;
end;
function TestSuiteAsPlain(aSuite:TTestSuite): string;
@ -220,12 +246,12 @@ var
i,j: integer;
s: TTestSuite;
begin
for i := 0 to aSuite.Tests.Count - 1 do
if TTest(aSuite.Tests.Items[i]) is TTestSuite then
Result := Result + TestSuiteAsPlain(TTestSuite(aSuite.Tests.Items[i]))
for i := 0 to aSuite.ChildTestCount - 1 do
if TTest(aSuite.Test[i]) is TTestSuite then
Result := Result + TestSuiteAsPlain(TTestSuite(aSuite.Test[i]))
else
if TTest(aSuite.Tests.Items[i]) is TTestCase then
Result := Result + ' ' + ASuite.TestName+'.' + TTestcase(aSuite.Tests.Items[i]).TestName + System.sLineBreak;
if TTest(aSuite.Test[i]) is TTestCase then
Result := Result + ' ' + ASuite.TestName+'.' + TTestcase(aSuite.Test[i]).TestName + System.sLineBreak;
end;
function GetSuiteAsXML(aSuite: TTestSuite): string;

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

@ -112,7 +112,7 @@ begin
end
else
E:=N;
for i:=0 to Pred(aSuite.CountTestCases) do
for i:=0 to Pred(aSuite.ChildTestCount) do
if TTest(aSuite.Test[i]) is TTestSuite then
TestSuiteAsXML(E, FDoc, TTestSuite(aSuite.Test[i]))
else