Merged revisions 7493 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/trunk

........
r7493 | florian | 2007-05-28 11:58:11 +0200 (Mon, 28 May 2007) | 1 line

+ from Darius Blaszijk: GetSuiteAsXML and TestSuiteAsXML implementation
........

git-svn-id: branches/fixes_2_2@8034 -

packages/fcl-fpcunit/src/xmltestreport.pp

@@ -65,9 +65,47 @@ type
     property Document: TXMLDocument read FDoc;
   end;
 
+function GetSuiteAsXML(aSuite: TTestSuite): string;
+function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTestSuite): string;
 
 implementation
 
+function GetSuiteAsXML(aSuite: TTestSuite): string;
+var
+  FDoc: TXMLDocument;
+  n: TDOMElement;
+  stream : TStringStream;
+begin
+  Result := '';
+
+  if aSuite <> nil then
+  begin
+    FDoc:= TXMLDocument.Create;
+
+    n := FDoc.CreateElement('TestSuites');
+    FDoc.AppendChild(n);
+
+    TestSuiteAsXML(n, FDoc, aSuite);
+
+    stream := TStringStream.Create('');
+    WriteXMLFile(FDoc, stream);
+    writeln(stream.DataString);
+    stream.Free;
+  end;
+end;
+
+function TestSuiteAsXML(n: TDOMElement; FDoc: TXMLDocument; aSuite:TTestSuite): string;
+var
+  i: integer;
+begin
+  for i := 0 to Pred(aSuite.Tests.Count) do
+    if TTest(aSuite.Tests.Items[i]) is TTestSuite then
+      TestSuiteAsXML(n, FDoc, TTestSuite(aSuite.Tests.Items[i]))
+    else
+      if TTest(aSuite.Tests.Items[i]) is TTestCase then
+        n.AppendChild(FDoc.CreateTextNode(TTestcase(aSuite.Tests.Items[i]).TestName + ' '));
+end;
+
 
 { TXMLResultsWriter }
 
@@ -246,3 +284,5 @@ end;
 
 end.
 
+
+