1{ 2 This file is part of the Free Component Library (FCL) 3 Copyright (c) 2006 by Dean Zobec, Graeme Geldenhuys 4 5 An example of an XML report writer for FPCUnit tests. 6 7 See the file COPYING.FPC, included in this distribution, 8 for details about the copyright. 9 10 This program is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 13 14 ********************************************************************** 15 16 17 Purpose: 18 This unit contains a XML TestListener for use with the fpcUnit testing 19 framework. It uses the XMLWrite unit (part of FPC) to generate 20 the XML document. The benefit of using XMLWrite is that the data generated 21 is valid XML, with reserved characters correctly escaped. 22 This allows the XML document to be further processed with XSLT etc without 23 any issues. 24 25 Notes: 26 Specify 'null' as the filename if you don't want to output to file (e.g. 27 used by the GUI test runner which instead reads the Document property). 28 29} 30 31unit xmltestreport; 32 33{$mode objfpc}{$H+} 34 35interface 36 37uses 38 Classes, SysUtils,fpcunit, fpcunitreport, testutils, dom, XMLWrite; 39 40 41type 42 43 { TXMLResultsWriter } 44 45 TXMLResultsWriter = class(TCustomResultsWriter) 46 private 47 FDoc: TXMLDocument; 48 FResults, FListing: TDOMNode; 49 FSuitePath: TFPList; 50 FCurrentTest: TDOMElement; 51 protected 52 function GetCurrentElement: TDOMElement; 53 procedure WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer); override; 54 procedure WriteTestFooter(ATest: TTest; ALevel: integer; ATiming: TDateTime); override; 55 procedure WriteSuiteHeader(ATestSuite: TTestSuite; ALevel: integer); override; 56 procedure WriteSuiteFooter(ATestSuite: TTestSuite; ALevel: integer; 57 ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer; 58 ANumFailures: integer; ANumIgnores: integer); override; 59 public 60 constructor Create(aOwner: TComponent); override; 61 destructor Destroy; override; 62 procedure WriteHeader; override; 63 procedure WriteFooter; override; 64 procedure AddFailure(ATest: TTest; AFailure: TTestFailure); override; 65 procedure AddError(ATest: TTest; AError: TTestFailure); override; 66 procedure StartTest(ATest: TTest); override; 67 procedure EndTest(ATest: TTest); override; 68 procedure WriteResult(aResult: TTestResult); override; 69 { A public property to the internal XML document } 70 property Document: TXMLDocument read FDoc; 71 end; 72 73function GetSuiteAsXML(aSuite: TTestSuite): string; 74function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTest): string; 75 76implementation 77 78function GetSuiteAsXML(aSuite: TTestSuite): string; 79var 80 FDoc: TXMLDocument; 81 n: TDOMElement; 82 stream : TStringStream; 83begin 84 Result := ''; 85 86 if aSuite <> nil then 87 begin 88 FDoc:= TXMLDocument.Create; 89 90 n := FDoc.CreateElement('TestSuites'); 91 FDoc.AppendChild(n); 92 93 TestSuiteAsXML(n, FDoc, aSuite); 94 95 stream := TStringStream.Create(''); 96 WriteXMLFile(FDoc, stream); 97 Result:=stream.DataString; 98 stream.Free; 99 end; 100end; 101 102function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTest): string; 103var 104 i: integer; 105 E,T : TDomElement; 106 107begin 108 Result:=''; 109 if aSuite.GetChildTestCount>0 then 110 begin 111 if (aSuite.TestName='') then 112 E:=N 113 else 114 begin 115 E:=FDoc.CreateElement('Suite'); 116 E['Name']:=aSuite.TestName; 117 N.AppendChild(E); 118 end; 119 for i:=0 to Pred(aSuite.GetChildTestCount) do 120 TestSuiteAsXML(E,FDoc,aSuite.GetChildTest(i)); 121 end 122 else 123 begin 124 T:=FDoc.CreateElement('Test'); 125 T['name']:=aSuite.TestName; 126 N.AppendChild(T); 127 end; 128end; 129 130 131{ TXMLResultsWriter } 132 133function TXMLResultsWriter.GetCurrentElement: TDOMElement; 134begin 135 if Assigned(FCurrentTest) then 136 Result := FCurrentTest 137 else if FSuitePath.Count > 0 then 138 //test is included in a suite 139 Result := TDOMElement(FSuitePath[FSuitePath.Count -1]) 140 else 141 //no suite to append so append directly to the listing node 142 FListing.LastChild; 143end; 144 145procedure TXMLResultsWriter.WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer); 146var 147 n: TDOMElement; 148begin 149 inherited; 150 n := FDoc.CreateElement('Test'); 151 n['Name'] := ATest.TestName; 152 n['Result'] := 'OK'; 153 if FSuitePath.Count > 0 then 154 //test is included in a suite 155 TDOMElement(FSuitePath[FSuitePath.Count -1]).AppendChild(n) 156 else 157 //no suite to append so append directly to the listing node 158 FListing.AppendChild(n); 159 FCurrentTest := n; 160end; 161 162procedure TXMLResultsWriter.WriteTestFooter(ATest: TTest; ALevel: integer; ATiming: TDateTime); 163begin 164 inherited; 165 if not SkipTiming then 166 FCurrentTest['ElapsedTime'] := FormatDateTime('hh:nn:ss.zzz', ATiming); 167end; 168 169 170procedure TXMLResultsWriter.WriteSuiteHeader(ATestSuite: TTestSuite; ALevel: integer); 171var 172 n: TDOMElement; 173begin 174 inherited; 175 n := FDoc.CreateElement('TestSuite'); 176 FSuitePath.Add(n); 177 n['Name'] := ATestSuite.TestName; 178 if FSuitePath.Count = 1 then 179 FListing.AppendChild(n) 180 else 181 TDOMElement(FSuitePath[FSuitePath.Count -2]).AppendChild(n); 182end; 183 184 185procedure TXMLResultsWriter.WriteSuiteFooter(ATestSuite: TTestSuite; ALevel: integer; 186 ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer; ANumFailures: integer; 187 ANumIgnores: integer); 188var 189 n: TDOMElement; 190begin 191 inherited; 192 n := TDomElement(FSuitePath[FSuitePath.Count -1]); 193 if not SkipTiming then 194 n['ElapsedTime'] := FormatDateTime('hh:nn:ss.zzz', ATiming); 195 n['NumberOfRunTests'] := IntToStr(ANumRuns); 196 n['NumberOfErrors'] := IntToStr(ANumErrors); 197 n['NumberOfFailures'] := IntToStr(ANumFailures); 198 n['NumberOfIgnoredTests'] := IntToStr(ANumIgnores); 199 FSuitePath.Delete(FSuitePath.Count -1); 200end; 201 202constructor TXMLResultsWriter.Create(aOwner: TComponent); 203begin 204 inherited Create(aOwner); 205 FDoc:= TXMLDocument.Create; 206 FSuitePath := TFPList.Create; 207 FResults := nil; 208 FListing := nil; 209end; 210 211destructor TXMLResultsWriter.Destroy; 212begin 213 FResults := nil; 214 FListing := nil; 215 FSuitePath.Free; 216 FDoc.Free; 217 inherited Destroy; 218end; 219 220 221procedure TXMLResultsWriter.WriteHeader; 222begin 223 inherited; 224 FResults := FDoc.CreateElement('TestResults'); 225 FResults.AppendChild(FDoc.CreateComment(' Generated using FPCUnit on ' 226 + FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) )); 227 FDoc.AppendChild(FResults); 228 FListing := FDoc.CreateElement('TestListing'); 229 FResults.AppendChild(FListing); 230end; 231 232 233procedure TXMLResultsWriter.WriteFooter; 234begin 235 inherited; 236end; 237 238procedure TXMLResultsWriter.AddFailure(ATest: TTest; AFailure: TTestFailure); 239var 240 CurrentElement: TDOMElement; 241begin 242 inherited; 243 CurrentElement := GetCurrentElement; 244 if AFailure.IsIgnoredTest then 245 CurrentElement['Result'] := 'Ignored' 246 else 247 CurrentElement['Result'] := 'Failed'; 248 CurrentElement.AppendChild(FDoc.CreateElement('Message')).AppendChild 249 (FDoc.CreateTextNode(AFailure.AsString)); 250 CurrentElement.AppendChild(FDoc.CreateElement('ExceptionClass')).AppendChild 251 (FDoc.CreateTextNode(AFailure.ExceptionClassName)); 252 CurrentElement.AppendChild(FDoc.CreateElement('ExceptionMessage')).AppendChild 253 (FDoc.CreateTextNode(AFailure.ExceptionMessage)); 254end; 255 256procedure TXMLResultsWriter.AddError(ATest: TTest; AError: TTestFailure); 257var 258 CurrentElement: TDOMElement; 259begin 260 inherited; 261 CurrentElement := GetCurrentElement; 262 CurrentElement['Result'] := 'Error'; 263 CurrentElement.AppendChild(FDoc.CreateElement('Message')).AppendChild 264 (FDoc.CreateTextNode(AError.AsString)); 265 CurrentElement.AppendChild(FDoc.CreateElement('ExceptionClass')).AppendChild 266 (FDoc.CreateTextNode(AError.ExceptionClassName)); 267 CurrentElement.AppendChild(FDoc.CreateElement('ExceptionMessage')).AppendChild 268 (FDoc.CreateTextNode(AError.ExceptionMessage)); 269 CurrentElement.AppendChild(FDoc.CreateElement('SourceUnitName')).AppendChild 270 (FDoc.CreateTextNode(AError.SourceUnitName)); 271 CurrentElement.AppendChild(FDoc.CreateElement('LineNumber')).AppendChild 272 (FDoc.CreateTextNode(IntToStr(AError.LineNumber))); 273 CurrentElement.AppendChild(FDoc.CreateElement('FailedMethodName')).AppendChild 274 (FDoc.CreateTextNode(AError.FailedMethodName)); 275end; 276 277 278procedure TXMLResultsWriter.StartTest(ATest: TTest); 279begin 280 inherited; 281end; 282 283 284procedure TXMLResultsWriter.EndTest(ATest: TTest); 285begin 286 inherited; 287end; 288 289procedure TXMLResultsWriter.WriteResult(aResult: TTestResult); 290var 291 n, lResults: TDOMNode; 292 f: text; 293begin 294 lResults := FDoc.FindNode('TestResults'); 295 n := FDoc.CreateElement('NumberOfRunTests'); 296 n.AppendChild(FDoc.CreateTextNode(IntToStr(aResult.RunTests))); 297 lResults.AppendChild(n); 298 299 n := FDoc.CreateElement('NumberOfErrors'); 300 n.AppendChild(FDoc.CreateTextNode(IntToStr(aResult.NumberOfErrors))); 301 lResults.AppendChild(n); 302 303 n := FDoc.CreateElement('NumberOfFailures'); 304 n.AppendChild(FDoc.CreateTextNode(IntToStr(aResult.NumberOfFailures))); 305 lResults.AppendChild(n); 306 307 n := FDoc.CreateElement('NumberOfIgnoredTests'); 308 n.AppendChild(FDoc.CreateTextNode(IntToStr(aResult.NumberOfIgnoredTests))); 309 lResults.AppendChild(n); 310 311 if not SkipTiming then 312 begin 313 n := FDoc.CreateElement('TotalElapsedTime'); 314 n.AppendChild(FDoc.CreateTextNode(FormatDateTime('hh:nn:ss.zzz', 315 Now - aResult.StartingTime))); 316 lResults.AppendChild(n); 317 end; 318 319 { Summary of ISO 8601 http://www.cl.cam.ac.uk/~mgk25/iso-time.html } 320 n := FDoc.CreateElement('DateTimeRan'); 321 n.AppendChild(FDoc.CreateTextNode(FormatDateTime('yyyy-mm-dd hh:nn:ss', Now))); 322 lResults.AppendChild(n); 323 324 // This is so that the GUI Test Runner doesn't output text as well. 325 if FileName <> 'null' then 326 begin 327 system.Assign(f, FileName); 328 rewrite(f); 329 WriteXMLFile(FDoc, f); 330 close(f); 331 end; 332end; 333 334end. 335 336 337 338