1{$mode objfpc}
2{$h+}
3{
4    This file is part of the Free Component Library (FCL)
5    Copyright (c) 2006 by Dean Zobec
6
7    an example of plain text report for FPCUnit tests.
8
9    See the file COPYING.FPC, included in this distribution,
10    for details about the copyright.
11
12    This program is distributed in the hope that it will be useful,
13    but WITHOUT ANY WARRANTY; without even the implied warranty of
14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
15
16 **********************************************************************}
17unit plaintestreport;
18
19interface
20
21uses
22  classes, SysUtils, fpcunit, fpcunitreport, testdecorator;
23
24type
25  TTestResultOption = (ttoSkipAddress,ttoSkipExceptionMessage,ttoErrorsOnly);
26  TTestResultOptions = set of TTestResultOption;
27
28  { TPlainResultsWriter }
29
30  TPlainResultsWriter = class(TCustomResultsWriter)
31  private
32    FTestResultOptions : TTestResultOptions;
33    FDoc: TStringList;
34    FSuiteHeaderIdx: TFPList;
35    FTempFailure: TTestFailure;
36    function TimeFormat(ATiming: TDateTime): String;
37  protected
38    procedure SetSkipAddressInfo(AValue: Boolean); override;
39    procedure SetSparse(AValue: Boolean); override;
40    procedure WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer); override;
41    procedure WriteTestFooter(ATest: TTest; ALevel: integer; ATiming: TDateTime); override;
42    procedure WriteSuiteHeader(ATestSuite: TTestSuite; ALevel: integer); override;
43    procedure WriteSuiteFooter(ATestSuite: TTestSuite; ALevel: integer;
44      ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer;
45      ANumFailures: integer; ANumIgnores: integer); override;
46  public
47    constructor Create(aOwner: TComponent); override;
48    destructor  Destroy; override;
49    procedure WriteHeader; override;
50    procedure WriteResult(aResult: TTestResult); override;
51    procedure AddFailure(ATest: TTest; AFailure: TTestFailure); override;
52    procedure AddError(ATest: TTest; AError: TTestFailure); override;
53  end;
54
55
56function TestSuiteAsPlain(aSuite:TTestSuite; Options : TTestResultOptions = []): string;
57function GetSuiteAsPlain(aSuite: TTestSuite; Options : TTestResultOptions = []): string;
58function TestResultAsPlain(aTestResult: TTestResult; Options : TTestResultOptions = []): string;
59
60implementation
61
62uses dateutils;
63
64{TPlainResultsWriter}
65
66constructor TPlainResultsWriter.Create(aOwner: TComponent);
67begin
68  inherited Create(aOwner);
69  FDoc := TStringList.Create;
70  FSuiteHeaderIdx := TFPList.Create;
71  FTempFailure := nil;
72end;
73
74destructor  TPlainResultsWriter.Destroy;
75begin
76  FDoc.Free;
77  FSuiteHeaderIdx.Free;
78  inherited Destroy;
79end;
80
81procedure TPlainResultsWriter.WriteHeader;
82begin
83end;
84
85procedure TPlainResultsWriter.WriteResult(aResult: TTestResult);
86var
87  f: text;
88begin
89  system.Assign(f, FileName);
90  rewrite(f);
91  FDoc.Add('');
92  FDoc.Add(TestResultAsPlain(aResult,FTestResultOptions));
93  writeln(f, FDoc.Text);
94  close(f);
95end;
96
97procedure TPlainResultsWriter.AddFailure(ATest: TTest; AFailure: TTestFailure);
98begin
99  inherited AddFailure(ATest, AFailure);
100  FTempFailure := AFailure;
101end;
102
103procedure TPlainResultsWriter.AddError(ATest: TTest; AError: TTestFailure);
104begin
105  inherited AddError(ATest, AError);
106  FTempFailure := AError;
107end;
108
109procedure TPlainResultsWriter.WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer);
110begin
111  inherited;
112end;
113
114procedure TPlainResultsWriter.WriteTestFooter(ATest: TTest; ALevel: integer; ATiming: TDateTime);
115
116Var
117  S : String;
118
119begin
120  inherited;
121  S:='  ' + StringOfChar(' ',ALevel*2);
122  if Not SkipTiming then
123    S:=S + FormatDateTime(TimeFormat(ATiming), ATiming) + '  ';
124  S:=S + ATest.TestName;
125  if Assigned(FTempFailure) or (not Sparse) then
126  FDoc.Add(S);
127  if Assigned(FTempFailure) then
128  begin
129    //check if it's an error
130    if not FTempFailure.IsFailure then
131    begin
132      FDoc[FDoc.Count -1] := FDoc[FDoc.Count -1] + '  Error: ' + FTempFailure.ExceptionClassName;
133      FDoc.Add(StringOfChar(' ',ALevel*2) + '    Exception:   ' + FTempFailure.ExceptionMessage);
134      FDoc.Add(StringOfChar(' ',ALevel*2) + '    at ' + FTempFailure.LocationInfo);
135      // TODO: Add stack dump output info
136    end
137    else
138      if FTempFailure.IsIgnoredTest then
139      begin
140         FDoc[FDoc.Count -1] := FDoc[FDoc.Count -1] + '  Ignored test: '
141           + FTempFailure.ExceptionMessage;
142      end
143      else
144      begin
145        //is a failure
146        FDoc[FDoc.Count -1] := FDoc[FDoc.Count -1] + '  Failed: '
147          + FTempFailure.ExceptionMessage;
148        FDoc.Add(StringOfChar(' ',ALevel*2) + '    Exception:   ' + FTempFailure.ExceptionMessage);
149        FDoc.Add(StringOfChar(' ',ALevel*2) + '    at ' + FTempFailure.LocationInfo);
150      end;
151  end;
152  FTempFailure := nil;
153end;
154
155function TPlainResultsWriter.TimeFormat(ATiming: TDateTime): String;
156
157Var
158  M : Int64;
159
160begin
161  Result:='ss.zzz';
162  M:=MinutesBetween(ATiming,0);
163  if M>60 then
164    Result:='hh:mm:'+Result
165  else if M>1 then
166   Result:='mm:'+Result;
167end;
168
169procedure TPlainResultsWriter.SetSkipAddressInfo(AValue: Boolean);
170begin
171  inherited SetSkipAddressInfo(AValue);
172  if AValue then
173    Include(FTestResultOptions,ttoSkipAddress)
174  else
175    Exclude(FTestResultOptions,ttoSkipAddress);
176end;
177
178procedure TPlainResultsWriter.SetSparse(AValue: Boolean);
179begin
180  inherited SetSparse(AValue);
181  if AValue then
182    FTestResultOptions:=FTestResultOptions+[ttoSkipExceptionMessage,ttoErrorsOnly]
183  else
184    FTestResultOptions:=FTestResultOptions-[ttoSkipExceptionMessage,ttoErrorsOnly];
185end;
186
187procedure TPlainResultsWriter.WriteSuiteFooter(ATestSuite: TTestSuite; ALevel: integer;
188  ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer; ANumFailures: integer;
189  ANumIgnores: integer);
190var
191  idx: integer;
192  S: String;
193begin
194  inherited;
195  idx := Integer(FSuiteHeaderIdx[FSuiteHeaderIdx.Count -1]);
196  if Not SkipTiming then
197    S:= ' Time:'+ FormatDateTime(TimeFormat(ATiming), ATiming);
198  S:=S+ ' N:'+ IntToStr(ANumRuns)+ ' E:'+ IntToStr(ANumErrors)+ ' F:'+ IntToStr(ANumFailures)+
199    ' I:'+ IntToStr(ANumIgnores) ;
200  FDoc[idx] := FDoc[idx]+S;
201  FSuiteHeaderIdx.Delete(FSuiteHeaderIdx.Count -1);
202end;
203
204procedure TPlainResultsWriter.WriteSuiteHeader(ATestSuite: TTestSuite; ALevel: integer);
205begin
206  inherited;
207  FDoc.Add(StringOfChar(' ',ALevel*2) + ATestSuite.TestName);
208  FSuiteHeaderIdx.Add(Pointer(FDoc.Count - 1));
209end;
210
211function DoTestSuiteAsPlain(aSuite:TTest; Prefix : String; Options : TTestResultOptions = []): string;
212
213var
214  i: integer;
215
216begin
217  if (ASuite.TestSuiteName<>'') then
218    begin
219    Prefix:='  '+Prefix;
220    Prefix:=Prefix+ASuite.TestSuiteName+'.';
221    end;
222  if (ASuite.TestName<>'') then
223    Result := Prefix+ASuite.TestName+System.sLineBreak;
224  for i := 0 to aSuite.GetChildTestCount - 1 do
225    Result := Result + DoTestSuiteAsPlain(aSuite.GetChildTest(i),Prefix,Options);
226end;
227
228function TestSuiteAsPlain(aSuite:TTestSuite; Options : TTestResultOptions = []): string;
229
230begin
231  Result:=DoTestSuiteAsPLain(ASuite,'',Options);
232end;
233
234function GetSuiteAsPlain(aSuite: TTestSuite; Options : TTestResultOptions = []): string;
235begin
236  Result := '';
237  if aSuite <> nil then
238    Result := 'TestSuites: ' + System.sLineBreak + TestSuiteAsPlain(aSuite,Options);
239end;
240
241function TestResultAsPlain(aTestResult: TTestResult; Options : TTestResultOptions = []): string;
242
243  Procedure WriteFailure(F : TTestFailure; SkipAddress : Boolean = False );
244
245  begin
246    Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
247    Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
248    if not (ttoSkipExceptionMessage in options) then
249      Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
250    if not (SkipAddress or (ttoSkipAddress in options) )then
251      Result := Result + '        at ' + f.LocationInfo + System.sLineBreak;
252  end;
253
254var
255  i: longint;
256  f: TTestFailure;
257begin
258  with aTestResult do
259  begin
260    Result :=          'Number of run tests: ' + intToStr(RunTests) + System.sLineBreak;
261    Result := Result + 'Number of errors:    ' + intToStr(NumberOfErrors) + System.sLineBreak;
262    Result := Result + 'Number of failures:  ' + intToStr(NumberOfFailures);
263    if NumberOfErrors <> 0 then
264    begin
265      Result := Result + System.sLineBreak;
266      Result := Result + System.sLineBreak;
267      Result := Result + 'List of errors:';
268      for i := 0 to Errors.Count - 1 do
269      begin
270        Result := Result + System.sLineBreak;
271        Result := Result + '  Error: ' + System.sLineBreak;
272        WriteFailure(TTestFailure(Errors.Items[i]));
273      end;
274    end;
275    if NumberOfFailures <> 0 then
276    begin
277      Result := Result + System.sLineBreak;
278      Result := Result + System.sLineBreak;
279      Result := Result + 'List of failures:' + System.sLineBreak;
280      for i := 0 to Failures.Count - 1 do
281      begin
282        Result := Result + '  Failure: ' + System.sLineBreak;
283        WriteFailure(TTestFailure(Failures.Items[i]));
284      end;
285    end;
286   if NumberOfIgnoredTests <> 0 then
287    begin
288      Result := Result + System.sLineBreak;
289      Result := Result + System.sLineBreak;
290      Result := Result + 'List of ignored tests:' + System.sLineBreak;
291      for i := 0 to IgnoredTests.Count - 1 do
292      begin
293        Result := Result + '  Ignored test: ' + System.sLineBreak;
294        WriteFailure(TTestFailure(IgnoredTests.Items[i]),True);
295      end;
296    end;
297  end;
298  Result := Result + System.sLineBreak;
299end;
300
301
302end.
303