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