+ TestDecorator implementation by Dean Zobec

fcl/fpcunit/demo/consolerunner/testrunner.pp

@@ -17,7 +17,7 @@
  **********************************************************************}
 program testrunner;
 uses
-  custapp, classes, SysUtils, fpcunit, suiteconfig, testreport;
+  custapp, classes, SysUtils, fpcunit, suiteconfig, testreport, testregistry;
 
 Const
   ShortOpts = 'alh';

fcl/fpcunit/exampletests/fpcunittests.pp

@@ -20,7 +20,7 @@ unit fpcunittests;
 interface
 
 uses
-  SysUtils, Classes, fpcunit, testutils, testregistry;
+  SysUtils, Classes, fpcunit, testutils, testregistry, testdecorator;
 
 type
 
@@ -160,6 +160,39 @@ type
     procedure SayGoodbye;
   end;
 
+  { TEncapsulatedTestCase }
+
+  TEncapsulatedTestCase = class(TTestCase)
+  published
+    procedure TestOne;
+    procedure TestTwo;
+  end;
+  
+  { TMyTestSetup }
+
+  TMyTestSetup = class(TTestSetup)
+  protected
+    procedure OneTimeSetup; override;
+    procedure OneTimeTearDown; override;
+  end;
+
+
+  { TTestDecoratorTest }
+
+  TTestDecoratorTest=class(TTestCase)
+  private
+    res: TTestResult;
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+  published
+    procedure TestRun;
+    procedure TestOneTimeSetup;
+  end; 
+  
+var
+  CountSetup: integer;
+
 implementation
 
 procedure TMyIntfObj.SayGoodbye;
@@ -744,8 +777,71 @@ begin
   AssertTrue(True);
 end;
 
+procedure TTestDecoratorTest.SetUp;
+begin
+  res := TTestResult.Create;
+end;
+
+procedure TTestDecoratorTest.TearDown;
+begin
+  FreeAndNil(res);
+end;
+
+procedure TTestDecoratorTest.TestRun;
+var
+  suite: TTestSuite;
+  decorator: TTestDecorator;
+begin
+  suite := TTestSuite.Create(TEncapsulatedTestCase);
+  decorator := TTestDecorator.Create(suite);
+  decorator.Run(res);
+  AssertEquals('wrong number of executed tests', 2, res.RunTests);
+  AssertEquals('wrong number of failures', 1, res.Failures.Count);
+  decorator.Free;
+end;
+
+procedure TTestDecoratorTest.TestOneTimeSetup;
+var
+  suite: TTestSuite;
+  setupDecorator: TTestSetup;
+begin
+  CountSetup := 0;
+  suite := TTestSuite.Create(TEncapsulatedTestCase);
+  setupDecorator := TMyTestSetup.Create(suite);
+  setupDecorator.Run(res);
+  AssertEquals('wrong number of executed tests', 2, res.RunTests);
+  AssertEquals('wrong number of failures', 1, res.Failures.Count);
+  AssertEquals('One-time Setup not executed', 1, CountSetup);
+  setupDecorator.Free;
+end;
+
+{ TEncapsulatedTestCase }
+
+procedure TEncapsulatedTestCase.TestOne;
+begin
+  AssertTrue(True);
+end;
+
+procedure TEncapsulatedTestCase.TestTwo;
+begin
+  AssertTrue(False);
+end;
+
+{ TMyTestSetup }
+
+procedure TMyTestSetup.OneTimeSetup;
+begin
+  Inc(CountSetup)
+end;
+
+procedure TMyTestSetup.OneTimeTearDown;
+begin
+
+end;
+
+
 initialization
 
-  RegisterTests([TTestCaseTest, TTestSuiteTest, TAssertTest, TListenerTest]);
+  RegisterTests([TTestCaseTest, TTestSuiteTest, TAssertTest, TListenerTest, TTestDecoratorTest]);
 
 end.

fcl/fpcunit/exampletests/money.pp

@@ -62,7 +62,7 @@ type
 
   TMoneyBag = class(TInterfacedObject, IMoney)
   private
-    FMonies: TList;
+    FMonies: TFPList;
     function AddToMoniesList(const Item: IInterface): Integer;
     function RemoveFromMoniesList(const Item: IInterface): Integer;
     function FindMoney(aCurrencyUnit: string): ISingleCurrencyMoney;
@@ -162,7 +162,7 @@ end;
 
 constructor TMoneyBag.Create;
 begin
-  FMonies := TList.Create;
+  FMonies := TFPList.Create;
 end;
 
 destructor TMoneyBag.Destroy;

fcl/fpcunit/exampletests/moneytest.pp

@@ -98,8 +98,11 @@ end;
 procedure TMoneyTest.testBagSimpleAdd;
 var
   expected: IMoney;
+  a, b: IMoney;
 begin
-  expected := TMoneyBag.CreateWith(TMoney.Create(26, 'CHF'), TMoney.Create(7, 'USD'));
+  a := TMoney.Create(26, 'CHF');
+  b := TMoney.Create(7, 'USD');
+  expected := TMoneyBag.CreateWith(a, b);
   AssertTrue('expected ' + expected.toString + ' but was ' + FMB1.add(F14CHF).toString, expected.equals(FMB1.add(F14CHF)));
 end;
 

fcl/fpcunit/fpcunit.pp

@@ -111,7 +111,7 @@ type
     FTestName: string;
     FTestSuiteName: string;
     FLineNumber: longint;
-    FMethodName: string;
+    FFailedMethodName: string;
     FRaisedExceptionClass: TClass;
     FRaisedExceptionMessage: string;
     FSourceUnitName: string;
@@ -131,7 +131,7 @@ type
     property ExceptionClassName: string read GetExceptionClassName;
     property SourceUnitName: string read FSourceUnitName write FSourceUnitName;
     property LineNumber: longint read FLineNumber write FLineNumber;
-    property MethodName: string read FMethodName write FMethodName;
+    property FailedMethodName: string read FFailedMethodName write FFailedMethodName;
     property TestLastStep: TTestStep read FTestLastStep write SetTestLastStep;
   end;
 
@@ -170,11 +170,11 @@ type
     property TestName: string read GetTestName write SetTestName;
   end;
 
-  TTestClass = Class of TTestCase;
+  TTestCaseClass = class of TTestCase;
 
   TTestSuite = class(TTest)
   private
-    FTests: TList;
+    FTests: TFPList;
     FName: string;
     FTestSuiteName: string;
     function GetTest(Index: integer): TTest;
@@ -199,36 +199,40 @@ type
     property Test[Index: integer]: TTest read GetTest; default;
     property TestSuiteName: string read GetTestSuiteName write SetTestSuiteName;
     property TestName: string read GetTestName write SetTestName;
-    property Tests: TList read FTests;
+    property Tests: TFPList read FTests;
   end;
+  
+  TProtect = procedure(aTest: TTest; aResult: TTestResult);
+
+  { TTestResult }
 
   TTestResult = class(TObject)
   private
   protected
     FRunTests: integer;
-    FFailures: TList;
-    FErrors: TList;
-    FListeners: TList;
+    FFailures: TFPList;
+    FErrors: TFPList;
+    FListeners: TFPList;
     function GetNumErrors: integer;
     function GetNumFailures: integer;
   public
     constructor Create; virtual;
     destructor Destroy; override;
-    property Listeners: TList read FListeners;
+    property Listeners: TFPList read FListeners;
     procedure ClearErrorLists;
     procedure StartTest(ATest: TTest);
     procedure AddFailure(ATest: TTest; E: EAssertionFailedError);
     procedure AddError(ATest: TTest; E: Exception; AUnitName: string;
-      AMethodName: string; ALineNumber: longint);
+      AFailedMethodName: string; ALineNumber: longint);
     procedure EndTest(ATest: TTest);
     procedure AddListener(AListener: ITestListener);
     procedure RemoveListener(AListener: ITestListener);
     procedure Run(ATestCase: TTestCase);
-    procedure RunProtected(ATestCase: TTestCase);
+    procedure RunProtected(ATestCase: TTest; protect: TProtect);
     function WasSuccessful: boolean;
   published
-    property Failures: TList read FFailures;
-    property Errors: TList read FErrors;
+    property Failures: TFPList read FFailures;
+    property Errors: TFPList read FErrors;
     property RunTests: integer read FRunTests;
     property NumberOfErrors: integer read GetNumErrors;
     property NumberOfFailures: integer read GetNumFailures;
@@ -717,12 +721,12 @@ constructor TTestSuite.Create(AClass: TClass);
 var
   ml: TStringList;
   i: integer;
-  tc: TTestClass;
+  tc: TTestCaseClass;
 begin
   Create(AClass.ClassName);
   if AClass.InheritsFrom(TTestCase) then
   begin
-    tc := TTestClass(AClass);
+    tc := TTestCaseClass(AClass);
     ml := TStringList.Create;
     try
       GetMethodList(AClass, ml);
@@ -759,7 +763,7 @@ end;
 constructor TTestSuite.Create;
 begin
   inherited Create;
-  FTests := TList.Create;
+  FTests := TFPList.Create;
 end;
 
 destructor TTestSuite.Destroy;
@@ -843,9 +847,9 @@ end;
 constructor TTestResult.Create;
 begin
   inherited Create;
-  FFailures := TList.Create;
-  FErrors := TList.Create;
-  FListeners := TList.Create;
+  FFailures := TFPList.Create;
+  FErrors := TFPList.Create;
+  FListeners := TFPList.Create;
 end;
 
 destructor TTestResult.Destroy;
@@ -899,7 +903,7 @@ begin
 end;
 
 procedure TTestResult.AddError(ATest: TTest; E: Exception;
-  AUnitName: string; AMethodName: string; ALineNumber: longint);
+  AUnitName: string; AFailedMethodName: string; ALineNumber: longint);
 var
   i: integer;
   f: TTestFailure;
@@ -907,7 +911,7 @@ begin
   //lock mutex
   f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep);
   f.SourceUnitName := AUnitName;
-  f.MethodName := AMethodName;
+  f.FailedMethodName := AFailedMethodName;
   f.LineNumber := ALineNumber;
   FErrors.Add(f);
   for i := 0 to FListeners.Count - 1 do
@@ -923,15 +927,19 @@ begin
     ITestListener(FListeners[i]).EndTest(ATest);
 end;
 
+procedure ProtectTest(aTest: TTest; aResult: TTestResult);
+begin
+  TTestCase(aTest).RunBare;
+end;
 
 procedure TTestResult.Run(ATestCase: TTestCase);
 begin
   StartTest(ATestCase);
-  RunProtected(ATestCase);
+  RunProtected(ATestCase, @ProtectTest);
   EndTest(ATestCase);
 end;
 
-procedure TTestResult.RunProtected(ATestCase: TTestCase);
+procedure TTestResult.RunProtected(ATestCase: TTest; protect: TProtect);
 var
   func, source: shortstring;
   line: longint;
@@ -940,7 +948,7 @@ begin
   source := '';
   line := 0;
   try
-    ATestCase.RunBare;
+    protect(ATestCase, Self);
   except
     on E: EAssertionFailedError do
       AddFailure(ATestCase, E);

fcl/fpcunit/testdecorator.pp

@@ -0,0 +1,119 @@
+{$mode objfpc}
+{$h+}
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2005 by Dean Zobec
+
+    Decorators for fpcunit tests and one-time TTestSetup implementation
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+unit testdecorator; 
+
+interface
+
+uses
+  Classes, SysUtils, fpcunit;
+  
+type
+
+  { TTestDecorator }
+
+  TTestDecorator = class(TAssert)
+  private
+    FTest: TTest;
+    function GetTestName: string; override;
+    function GetTestSuiteName: string; override;
+    procedure SetTestSuiteName(const aName: string); override;
+  public
+    function CountTestCases: integer; override;
+    constructor Create(aTest: TTest); reintroduce; overload;
+    destructor Destroy; override;
+    procedure BasicRun(AResult: TTestResult); virtual;
+    procedure Run(AResult: TTestResult); override;
+    property Test: TTest read FTest;
+  end;
+  
+  { TTestSetup }
+
+  TTestSetup = class(TTestDecorator)
+  protected
+    procedure OneTimeSetup; virtual; abstract;
+    procedure OneTimeTearDown; virtual; abstract;
+  public
+    procedure Run(AResult: TTestResult); override;
+  end;
+
+implementation
+
+{ TTestDecorator }
+
+function TTestDecorator.GetTestName: string;
+begin
+  Result := FTest.TestName;
+end;
+
+function TTestDecorator.GetTestSuiteName: string;
+begin
+  Result := FTest.TestSuiteName;
+end;
+
+procedure TTestDecorator.SetTestSuiteName(const aName: string);
+begin
+  FTest.TestSuiteName := aName;
+end;
+
+function TTestDecorator.CountTestCases: integer;
+begin
+  Result := FTest.CountTestCases;
+end;
+
+constructor TTestDecorator.Create(aTest: TTest);
+begin
+  inherited Create;
+  FTest := aTest;
+end;
+
+destructor TTestDecorator.Destroy;
+begin
+  FTest.Free;
+  inherited Destroy;
+end;
+
+procedure TTestDecorator.BasicRun(AResult: TTestResult);
+begin
+  FTest.Run(AResult);
+end;
+
+procedure TTestDecorator.Run(AResult: TTestResult);
+begin
+  BasicRun(AResult);
+end;
+
+procedure OneTimeProtect(aTest: TTest; aResult: TTestResult);
+begin
+  if aTest is TTestSetup then
+  begin
+    TTestSetup(aTest).OneTimeSetup;
+    TTestSetup(aTest).BasicRun(aResult);
+    TTestSetup(aTest).OneTimeTearDown;
+  end;
+end;
+
+{ TTestSetup }
+
+procedure TTestSetup.Run(AResult: TTestResult);
+begin
+  AResult.RunProtected(Self, @OneTimeProtect);
+end;
+
+end.
+

fcl/fpcunit/testregistry.pp

@@ -20,12 +20,18 @@ unit testregistry;
 interface
 
 uses
-  fpcunit;
+  fpcunit, testdecorator;
+  
+type
 
+  TTestDecoratorClass = class of TTestDecorator;
 
-procedure RegisterTest(ATestClass: TTestClass); overload;
 
-procedure RegisterTests(ATests: Array of TTestClass);
+procedure RegisterTest(ATestClass: TTestCaseClass); overload;
+
+procedure RegisterTests(ATests: Array of TTestCaseClass);
+
+procedure RegisterTestDecorator(ADecoratorClass: TTestDecoratorClass; ATestClass: TTestCaseClass);
 
 function NumberOfRegisteredTests: longint;
 
@@ -43,12 +49,17 @@ begin
   Result := FTestRegistry;
 end;
 
-procedure RegisterTest(ATestClass: TTestClass);
+procedure RegisterTest(ATestClass: TTestCaseClass);
 begin
   GetTestRegistry.AddTestSuiteFromClass(ATestClass);
 end;
 
-procedure RegisterTests(ATests: Array of TTestClass);
+procedure RegisterTestDecorator(ADecoratorClass: TTestDecoratorClass; ATestClass: TTestCaseClass);
+begin
+  GetTestRegistry.AddTest(ADecoratorClass.Create(TTestSuite.Create(ATestClass)));
+end;
+
+procedure RegisterTests(ATests: Array of TTestCaseClass);
 var
   i: integer;
 begin

fcl/fpcunit/testreport.pp

@@ -79,7 +79,7 @@ begin
 writeln('<error ExceptionClassName="', AError.ExceptionClassName, '">');
   writeln('<message>', AError.ExceptionMessage, '</message>');
   writeln('<sourceunit>', AError.SourceUnitName, '</sourceunit>');
-  writeln('<methodname>', AError.MethodName, '</methodname>');
+  writeln('<methodname>', AError.FailedMethodName, '</methodname>');
   writeln('<linenumber>', AError.LineNumber, '</linenumber>');
   writeln('</error>');
 end;
@@ -181,7 +181,7 @@ begin
         Result := Result + '  <ExceptionMessage>' + f.ExceptionMessage + '</ExceptionMessage>' + System.sLineBreak;
         Result := Result + '  <SourceUnitName>' + f.SourceUnitName + '</SourceUnitName>' + System.sLineBreak;
         Result := Result + '  <LineNumber>' + IntToStr(f.LineNumber) + '</LineNumber>' + System.sLineBreak;
-        Result := Result + '  <MethodName>' + f.MethodName + '</MethodName>' + System.sLineBreak;
+        Result := Result + '  <FailedMethodName>' + f.FailedMethodName + '</FailedMethodName>' + System.sLineBreak;
         Result := Result + '</Error>' + System.sLineBreak;
       end;
       Result := Result + '</ListOfErrors>';

fcl/fpcunit/testutils.pp

@@ -33,7 +33,7 @@ type
   end;
   {$M-}
 
-procedure FreeObjects(List: TList);
+procedure FreeObjects(List: TFPList);
 procedure GetMethodList( AObject: TObject; AList: TStrings ); overload;
 procedure GetMethodList( AClass: TClass; AList: TStrings ); overload;
 
@@ -103,7 +103,7 @@ begin
   end;
 end;
 
-procedure FreeObjects(List: TList);
+procedure FreeObjects(List: TFPList);
 var
   i: integer;
 begin