fpc unit console runner:

* fixed memleak with long options + added stylesheet parameter + added example stylesheet * renamed App to Appliction, so Lazarus can set the Application.Title git-svn-id: trunk@10183 -
2025-10-20 21:46:00 +02:00 · 2006-11-10 06:52:18 +00:00 · 2006-11-10 06:52:18 +00:00 · 8a29f2f36c
commit 8a29f2f36c
parent 45523c4fd1
7 changed files with 281 additions and 30 deletions
--- a/.gitattributes
+++ b/.gitattributes
@ -145,6 +145,7 @@ components/fpcunit/Makefile svneol=native#text/plain
 components/fpcunit/Makefile.fpc svneol=native#text/plain
 components/fpcunit/blueball.xpm svneol=native#text/plain
 components/fpcunit/console/consoletestrunner.pas svneol=native#text/plain
+components/fpcunit/console/fpcunit.xsl svneol=native#text/plain
 components/fpcunit/console/fpcunitconsolerunner.lpk svneol=native#text/plain
 components/fpcunit/console/fpcunitconsolerunner.pas svneol=native#text/plain
 components/fpcunit/fpcunittestrunner.lpk svneol=native#text/pascal
--- a/components/fpcunit/console/consoletestrunner.pas
+++ b/components/fpcunit/console/consoletestrunner.pas
@ -25,7 +25,7 @@ interface

 uses
  custapp, Classes, SysUtils, fpcunit, testregistry, testreport, testutils,
-  xmlreporter, xmlwrite;
+  dom, xmlreporter, xmlwrite;

 const
  Version = '0.2';
@ -39,25 +39,31 @@ type
  private
     FShowProgress: boolean;
     FFileName: string;
+     FStyleSheet: string;
+     FLongOpts: TStrings;
  protected
    property FileName: string read FFileName write FFileName;
+    property LongOpts: TStrings read FLongOpts write FLongOpts;
    property ShowProgress: boolean read FShowProgress write FShowProgress;
+    property StyleSheet: string read FStyleSheet write FStyleSheet;
    procedure DoRun; override;
    procedure doTestRun(aTest: TTest); virtual;
    function GetShortOpts: string; virtual;
-    function GetLongOpts: TStrings; virtual;
+    procedure AppendLongOpts; virtual;
    procedure WriteCustomHelp; virtual;
    procedure ParseOptions; virtual;
  public
+    constructor Create(AOwner: TComponent); override;
+    destructor Destroy; override;
  end;

 implementation

 const
  ShortOpts = 'alhp';
-  LongOpts: array[1..7] of string =
+  DefaultLongOpts: array[1..8] of string =
     ('all', 'list', 'progress', 'help',
-      'suite:', 'format:', 'file:');
+      'suite:', 'format:', 'file:', 'stylesheet:');

  { TProgressWriter }
 type
@ -115,14 +121,27 @@ var
  procedure doXMLTestRun(aTest: TTest);
  var
    XMLResultsWriter: TXMLResultsWriter;
+    
+    procedure ExtendDocument(Doc: TXMLDocument);
+    var
+      n: TDOMElement;
+    begin
+      if StyleSheet<>'' then begin
+        Doc.StylesheetType := 'text/xsl';
+        Doc.StylesheetHRef := StyleSheet;
+      end;
+      n := Doc.CreateElement('Title');
+      n.AppendChild(Doc.CreateTextNode(Title));
+      Doc.FirstChild.AppendChild(n);
+    end;
+    
  begin
    try
      XMLResultsWriter := TXMLResultsWriter.Create;
      testResult.AddListener(XMLResultsWriter);
      aTest.Run(testResult);
      XMLResultsWriter.WriteResult(testResult);
-      XMLResultsWriter.Document.StylesheetType := 'text/xsl';
-      XMLResultsWriter.Document.StylesheetHRef := 'results.xsl';
+      ExtendDocument(XMLResultsWriter.Document);
      if FileName<>'' then
        WriteXMLFile(XMLResultsWriter.Document, FileName)
      else
@ -133,6 +152,7 @@ var
    end;
  end;

+  {$IFNDEF VER2_0}
  procedure doPlainTestRun(aTest: TTest);
  var
    PlainResultsWriter: TPlainResultsWriter;
@ -148,6 +168,7 @@ var
      testResult.Free;
    end;
  end;
+  {$ENDIF}

 begin
  testResult := TTestResult.Create;
@ -175,13 +196,12 @@ begin
  Result := ShortOpts;
 end;

-function TTestRunner.GetLongOpts: TStrings;
+procedure TTestRunner.AppendLongOpts;
 var
  i: Integer;
 begin
-  Result := TStringList.Create;
-  for i := low(LongOpts) to high(LongOpts) do
-    Result.Add(LongOpts[i]);
+  for i := low(DefaultLongOpts) to high(DefaultLongOpts) do
+    LongOpts.Add(DefaultLongOpts[i]);
 end;

 procedure TTestRunner.WriteCustomHelp;
@ -198,8 +218,11 @@ begin
    writeln;
    writeln('Usage: ');
    writeln('  --format=latex            output as latex source (only list implemented)');
+    {$IFNDEF VER2_0}
    writeln('  --format=plain            output as plain ASCII source');
+    {$ENDIF}
    writeln('  --format=xml              output as XML source (default)');
+    writeln('  --stylesheet=<reference>   add stylesheet reference');
    writeln('  --file=<filename>         output results to file');
    writeln;
    writeln('  -l or --list              show a list of registered tests');
@ -226,6 +249,21 @@ begin

  if HasOption('file') then
    FileName := GetOptionValue('file');
+  if HasOption('stylesheet') then
+    StyleSheet := GetOptionValue('stylesheet');
+end;
+
+constructor TTestRunner.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FLongOpts := TStringList.Create;
+  AppendLongOpts;
+end;
+
+destructor TTestRunner.Destroy;
+begin
+  FLongOpts.Free;
+  inherited Destroy;
 end;

 procedure TTestRunner.DoRun;
@ -233,7 +271,7 @@ var
  I: integer;
  S: string;
 begin
-  S := CheckOptions(GetShortOpts, GetLongOpts);
+  S := CheckOptions(GetShortOpts, LongOpts);
  if (S <> '') then
    Writeln(S);

@ -243,7 +281,9 @@ begin
  if HasOption('l', 'list') then
    case FormatParam of
      fLatex: Write(GetSuiteAsLatex(GetTestRegistry));
+      {$IFNDEF VER2_0}
      fPlain: Write(GetSuiteAsPlain(GetTestRegistry));
+      {$ENDIF}
      else
        Write(GetSuiteAsXML(GetTestRegistry));
    end;
--- a/components/fpcunit/console/fpcunit.xsl
+++ b/components/fpcunit/console/fpcunit.xsl
@ -0,0 +1,206 @@
+<?xml version="1.0"?>
+<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
+<xsl:output method="html" encoding="UTF-8"/>
+
+<xsl:template match="/">
+  <xsl:variable name="title" select="TestResults/Title" />
+  <html>
+  <head>
+    <title><xsl:value-of select="$title"/></title>
+  	  <style type="text/css" title="fpcUnit" media="screen">
+		    @import "fpcunit.css";
+	    </style>
+  </head>
+  <body>
+
+  <a name="Summary"></a>
+  <xsl:apply-templates/>
+
+	<address>
+		<a href="http://opensoft.homeip.net">fpcUnit Report</a> 0.3.0 © 2006 by 
+		<a href="mailto:graemeg@gmail.com?subject=Comments about fpcUnit Report">Graeme Geldenhuys</a>.<br></br>
+		Licensed under the <a href="http://www.gnu.org/copyleft/gpl.html">GNU General Public License</a>.<br></br>
+		Modified by Vincent Snijders.<br></br>
+	</address>
+</body>
+</html>
+</xsl:template>
+
+
+<xsl:template match="TestResults">
+  <xsl:variable name="runnedCount" select="NumberOfRunTests" />
+  <xsl:variable name="failureCount" select="NumberOfFailures" />
+  <xsl:variable name="errorCount" select="NumberOfErrors" />
+  <xsl:variable name="elapsedTime" select="TotalElapsedTime" />
+  <xsl:variable name="dateRan" select="DateTimeRan" />
+  <xsl:variable name="title" select="Title" />
+
+  <h2><xsl:value-of select="$title"/></h2>
+  <h3>Summary</h3>
+  <!--  Summary Table -->
+	<table border="0" rules="none" width="100%">
+		<tr align="left" class="title">
+			<th width="45%" align="left">Name</th>
+			<th width="7%" align="left">Tests</th>
+			<th width="8%" align="left">Failures</th>
+			<th width="8%" align="left">Errors</th>
+			<th width="11%" align="left">Elapsed Time</th>
+			<th width="14%" align="left">Run Date</th>
+		</tr>
+  <xsl:choose>
+   <xsl:when test="$errorCount &gt; 0">
+    <tr class="error">
+      <td>Summary</td>
+      <td><xsl:value-of select="$runnedCount"/></td>
+      <td><xsl:value-of select="$failureCount"/></td>
+      <td><xsl:value-of select="$errorCount"/></td>
+      <td><xsl:value-of select="$elapsedTime"/></td>
+      <td><xsl:value-of select="$dateRan"/></td>
+    </tr>
+   </xsl:when>
+   <xsl:when test="$failureCount &gt; 0">
+    <tr class="failure">
+      <td>Summary</td>
+      <td><xsl:value-of select="$runnedCount"/></td>
+      <td><xsl:value-of select="$failureCount"/></td>
+      <td><xsl:value-of select="$errorCount"/></td>
+      <td><xsl:value-of select="$elapsedTime"/></td>
+      <td><xsl:value-of select="$dateRan"/></td>
+    </tr>
+   </xsl:when>
+   <xsl:otherwise>
+    <tr class="success">
+      <td>Summary</td>
+      <td><xsl:value-of select="$runnedCount"/></td>
+      <td><xsl:value-of select="$failureCount"/></td>
+      <td><xsl:value-of select="$errorCount"/></td>
+      <td><xsl:value-of select="$elapsedTime"/></td>
+      <td><xsl:value-of select="$dateRan"/></td>
+    </tr>
+   </xsl:otherwise>
+  </xsl:choose>
+	</table>
+
+  <p>Note: <i>Failures</i> are anticipated and checked for with assertions. <i>Errors</i> are 
+unexpected results.</p>
+	<hr></hr>
+
+  <xsl:call-template name="test_listing"/>
+  <xsl:call-template name="test_failures"/>
+  <xsl:call-template name="test_errors"/>
+</xsl:template>
+
+
+<xsl:template name="test_listing">
+  <div id="testlisting">
+  <a name="Test_Listing"></a>
+	<h3>Test Listing</h3>
+	<p>
+		[<a href="#Summary">Summary</a>]
+		[<a href="#Test_Listing">Test Listing</a>]
+		[<a href="#Failures">Failures</a>]
+		[<a href="#Errors">Errors</a>]
+	</p>
+  <!--  Test Listing Table -->
+	<table border="0" rules="none" width="100%">
+		<tr align="left" class="title">
+			<th width="89%" align="left">Name</th>
+			<th width="11%" align="left">Elapsed Time<br/>(hh:mm:ss.zzz)</th>
+		</tr>
+    <xsl:for-each select="TestListing/Test">
+    <xsl:variable name="testName" select="@Name" />
+    <xsl:variable name="elapsedTime" select="ElapsedTime" />
+    <tr class="success">
+      <td><xsl:value-of select="$testName"/></td>
+      <td><xsl:value-of select="ElapsedTime"/></td>
+    </tr>
+	  </xsl:for-each>
+  </table>
+</div>  <!-- testlisting -->
+</xsl:template>
+
+
+
+<xsl:template name="test_failures">
+  <div id="failures">
+  <a name="Failures"></a>
+  <h3>Failures:</h3>
+	<p>
+		[<a href="#Summary">Summary</a>]
+		[<a href="#Test_Listing">Test Listing</a>]
+		[<a href="#Failures">Failures</a>]
+		[<a href="#Errors">Errors</a>]
+	</p>
+<xsl:for-each select="ListOfFailures/Failure">
+	<p class="backToTop">
+		[<a href="#Failures">Back to top</a>]
+	</p>
+  <table>
+    <!--  Error Table Body  -->
+  <TR>
+     <TD valign="top" class="title" width="300">Message:</TD>
+     <TD valign="top" class="resultmessage"><xsl:value-of select="Message" /></TD>
+  </TR>
+  <TR>
+    <TD valign="top" class="title">Exception Class:</TD>
+    <TD valign="top" class="resultmessage"><xsl:value-of select="ExceptionClass" /></TD>  
+  </TR>
+  <TR>
+     <TD valign="top" class="title">Exception Message:</TD>
+     <TD valign="top" class="resultmessage"><xsl:value-of select="ExceptionMessage" /></TD>
+  </TR>
+  </table>
+</xsl:for-each>
+</div>  <!-- failures -->
+</xsl:template>
+
+
+
+<xsl:template name="test_errors">
+<div id="errors">
+  <a name="Errors"></a>
+  <h3>Errors</h3>
+	<p>
+		[<a href="#Summary">Summary</a>]
+		[<a href="#Test_Listing">Test Listing</a>]
+		[<a href="#Failures">Failures</a>]
+		[<a href="#Errors">Errors</a>]
+	</p>
+<xsl:for-each select="ListOfErrors/Error">
+	<p class="backToTop">
+		[<a href="#Errors">Back to top</a>]
+	</p>
+<table>
+  <!--  Error Table Body  -->
+<TR>
+   <TD valign="top" class="title" width="300">Message:</TD>
+   <TD valign="top" class="resultmessage"><xsl:value-of select="Message" /></TD>
+</TR>
+<TR>
+   <TD valign="top" class="title">Exception Class:</TD>
+   <TD valign="top" class="resultmessage"><xsl:value-of select="ExceptionClass" /></TD>
+</TR>
+<TR>
+   <TD valign="top" class="title">Exception Message:</TD>
+   <TD valign="top" class="resultmessage"><xsl:value-of select="ExceptionMessage" /></TD>
+</TR>
+<TR>
+   <TD valign="top" class="title">UnitName:</TD>
+   <TD valign="top" class="resultmessage"><xsl:value-of select="SourceUnitName" /></TD>
+</TR>
+<TR>
+   <TD valign="top" class="title">LineNumber:</TD>
+   <TD valign="top" class="resultmessage"><xsl:value-of select="LineNumber" /></TD>
+</TR>
+<TR>
+   <TD valign="top" class="title">Method Name:</TD>
+   <TD valign="top" class="resultmessage"><xsl:value-of select="FailedMethodName" /></TD>
+</TR>
+</table>
+</xsl:for-each>
+</div>  <!-- errors -->
+</xsl:template>
+
+
+
+</xsl:stylesheet>
--- a/components/fpcunit/ide/fpcunitproject1.inc
+++ b/components/fpcunit/ide/fpcunitproject1.inc
@ -16,13 +16,13 @@ NewSource :=
  + '  end;' + #13
  + #13
  + 'var' + #13
-  + '  App: TMyTestRunner;' + #13
+  + '  Application: TMyTestRunner;' + #13
  + #13
  + 'begin' + #13
-  + '  App := TMyTestRunner.Create(nil);' + #13
-  + '  App.Initialize;' + #13
-  + '  App.Title := ''FPCUnit Console test runner'';' + #13
-  + '  App.Run;' + #13
-  + '  App.Free;' + #13
+  + '  Application := TMyTestRunner.Create(nil);' + #13
+  + '  Application.Initialize;' + #13
+  + '  Application.Title := ''FPCUnit Console test runner'';' + #13
+  + '  Application.Run;' + #13
+  + '  Application.Free;' + #13
  + 'end.' + #13
 ;
--- a/components/fpcunit/ide/fpcunitproject1.pas
+++ b/components/fpcunit/ide/fpcunitproject1.pas
@ -15,12 +15,12 @@ type
  end;

 var
-  App: TMyTestRunner;
+  Application: TMyTestRunner;

 begin
-  App := TMyTestRunner.Create(nil);
-  App.Initialize;
-  App.Title := 'FPCUnit Console test runner';
-  App.Run;
-  App.Free;
+  Application := TMyTestRunner.Create(nil);
+  Application.Initialize;
+  Application.Title := 'FPCUnit Console test runner';
+  Application.Run;
+  Application.Free;
 end.
--- a/test/runtests.lpi
+++ b/test/runtests.lpi
@ -23,16 +23,16 @@
    </RunParams>
    <RequiredPackages Count="3">
      <Item1>
-        <PackageName Value="fpcunitconsolerunner"/>
+        <PackageName Value="LCL"/>
      </Item1>
      <Item2>
-        <PackageName Value="LCL"/>
+        <PackageName Value="fpcunitconsolerunner"/>
      </Item2>
      <Item3>
        <PackageName Value="FCL"/>
      </Item3>
    </RequiredPackages>
-    <Units Count="2">
+    <Units Count="3">
      <Unit0>
        <Filename Value="runtests.lpr"/>
        <IsPartOfProject Value="True"/>
@ -43,6 +43,11 @@
        <IsPartOfProject Value="True"/>
        <UnitName Value="TestLpi"/>
      </Unit1>
+      <Unit2>
+        <Filename Value="..\components\fpcunit\console\fpcunitproject1.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="FPCUnitProject1"/>
+      </Unit2>
    </Units>
  </ProjectOptions>
  <CompilerOptions>
--- a/test/runtests.lpr
+++ b/test/runtests.lpr
@ -29,17 +29,16 @@ type

  TLazTestRunner = class(TTestRunner)
  protected
-    function GetLongOpts: TStrings; override;
+    procedure AppendLongOpts; override;
    procedure ParseOptions; override;
    procedure WriteCustomHelp; override;
  end;

 { TLazTestRunner }

-function TLazTestRunner.GetLongOpts: TStrings;
+procedure TLazTestRunner.AppendLongOpts;
 begin
-  Result:=inherited GetLongOpts;
-  Result.Add('compiler:');
+  LongOpts.Add('compiler:');
 end;

 procedure TLazTestRunner.ParseOptions;