mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-22 11:49:23 +02:00
+ Initial import
This commit is contained in:
michael
parent
a263b1d40e
commit
04167f8385
71
fcl/fpcunit/README.txt
Normal file
71
fcl/fpcunit/README.txt
Normal file
@ -0,0 +1,71 @@
|
||||
FPCUnit
|
||||
|
||||
This is a port to Free Pascal of the JUnit core framework.
|
||||
see http://www.junit.org
|
||||
A great thank you goes to Kent Beck and Erich Gamma:
|
||||
"Never in the field of software development was so much owed by so many to
|
||||
so few lines of code." (M.Fowler)
|
||||
|
||||
I've tried to follow as closely as possible the original JUnit code base,
|
||||
so, as a side effect, developers already familiar with JUnit will find themselves
|
||||
at home with this port to Free Pascal. If you are new to unit testing and test driven
|
||||
development, you can find a huge reference to articles and
|
||||
howto's on the JUnit home page:
|
||||
http://junit.sourceforge.net/#Documentation
|
||||
http://www.junit.org/news/article/index.htm.
|
||||
|
||||
A simple example of a console test runner application that was used to write FPCUnit itself
|
||||
is included in the demo directory. The tests are located in fpcunitests.pp, they can be used as
|
||||
examples to see how to construct the tests and the test suites.
|
||||
|
||||
To be able to trace the line numbers of the
|
||||
test errors (unhandled exceptions) it is required to use the -gl option
|
||||
to compile the project:.
|
||||
eg. $ fpc -Sd -gl testrunner.pp
|
||||
If you don't like this additional feature you can disable the {$SHOWLINEINFO} directive
|
||||
in the testresults.pp unit.
|
||||
|
||||
Usage:
|
||||
-l or --list to show a list of registered tests
|
||||
default format is xml, add --format=latex to output the list as latex source
|
||||
-a or --all to run all the tests and show the results in xml format
|
||||
The results can be redirected to an xml file,
|
||||
for example: ./testrunner --all > results.xml
|
||||
use --suite=MyTestSuiteName to run only the tests in a single test suite class
|
||||
|
||||
To use the simple console test runner in your own project, you can just edit the
|
||||
suiteconfig.pp unit to include your own units containing your tests instead of the unit
|
||||
fpcunittests and register your tests in the RegisterUnitTests procedure like this:
|
||||
|
||||
unit suiteconfig;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
>>> Add the unit(s) containing your tests here;
|
||||
|
||||
procedure RegisterUnitTests;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
testregistry;
|
||||
|
||||
procedure RegisterUnitTests;
|
||||
begin
|
||||
//register your tests here
|
||||
>>> RegisterTests([TYourFirstTest, TYourSecondTest, TYourThirdTest,... ]);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
|
||||
|
||||
Happy coding,
|
||||
Dean Zobec
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
34
fcl/fpcunit/demo/consolerunner/suiteconfig.pp
Normal file
34
fcl/fpcunit/demo/consolerunner/suiteconfig.pp
Normal file
@ -0,0 +1,34 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec, Michael Van Canneyt
|
||||
|
||||
a unit to register the tests to be runned.
|
||||
|
||||
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 suiteconfig;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
fpcunittests, testregistry;
|
||||
|
||||
procedure RegisterUnitTests;
|
||||
|
||||
implementation
|
||||
|
||||
procedure RegisterUnitTests;
|
||||
begin
|
||||
RegisterTests([TTestCaseTest, TTestSuiteTest, TAssertTest, TListenerTest]);
|
||||
end;
|
||||
|
||||
end.
|
||||
134
fcl/fpcunit/demo/consolerunner/testrunner.pp
Normal file
134
fcl/fpcunit/demo/consolerunner/testrunner.pp
Normal file
@ -0,0 +1,134 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec, Michael Van Canneyt
|
||||
|
||||
an example of a console test runner of FPCUnit tests.
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
program testrunner;
|
||||
|
||||
uses
|
||||
custapp, classes, SysUtils, fpcunit, suiteconfig, testreport, testregistry;
|
||||
|
||||
Const
|
||||
ShortOpts = 'alh';
|
||||
Longopts : Array[1..5] of String = (
|
||||
'all','list','format:','suite:','help');
|
||||
Version = 'Version 0.1';
|
||||
|
||||
Type
|
||||
TTestRunner = Class(TCustomApplication)
|
||||
private
|
||||
FXMLResultsWriter: TXMLResultsWriter;
|
||||
protected
|
||||
procedure DoRun ; Override;
|
||||
procedure doTestRun(aTest: TTest); virtual;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
|
||||
constructor TTestRunner.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FXMLResultsWriter := TXMLResultsWriter.Create;
|
||||
end;
|
||||
|
||||
destructor TTestRunner.Destroy;
|
||||
begin
|
||||
FXMLResultsWriter.Free;
|
||||
end;
|
||||
|
||||
procedure TTestRunner.doTestRun(aTest: TTest);
|
||||
var
|
||||
testResult: TTestResult;
|
||||
begin
|
||||
testResult := TTestResult.Create;
|
||||
try
|
||||
testResult.AddListener(FXMLResultsWriter);
|
||||
FXMLResultsWriter.WriteHeader;
|
||||
aTest.Run(testResult);
|
||||
FXMLResultsWriter.WriteResult(testResult);
|
||||
finally
|
||||
testResult.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestRunner.DoRun;
|
||||
var
|
||||
I : Integer;
|
||||
S : String;
|
||||
begin
|
||||
S:=CheckOptions(ShortOpts,LongOpts);
|
||||
If (S<>'') then
|
||||
Writeln(S);
|
||||
if HasOption('h', 'help') or (ParamCount = 0) then
|
||||
begin
|
||||
writeln(Title);
|
||||
writeln(Version);
|
||||
writeln('Usage: ');
|
||||
writeln('-l or --list to show a list of registered tests');
|
||||
writeln('default format is xml, add --format=latex to output the list as latex source');
|
||||
writeln('-a or --all to run all the tests and show the results in xml format');
|
||||
writeln('The results can be redirected to an xml file,');
|
||||
writeln('for example: ./testrunner --all > results.xml');
|
||||
writeln('use --suite=MyTestSuiteName to run only the tests in a single test suite class');
|
||||
end
|
||||
else;
|
||||
if HasOption('l', 'list') then
|
||||
begin
|
||||
if HasOption('format') then
|
||||
begin
|
||||
if GetOptionValue('format') = 'latex' then
|
||||
writeln(GetSuiteAsLatex(GetTestRegistry))
|
||||
else
|
||||
writeln(GetSuiteAsXML(GetTestRegistry));
|
||||
end
|
||||
else
|
||||
writeln(GetSuiteAsXML(GetTestRegistry));
|
||||
end;
|
||||
if HasOption('a', 'all') then
|
||||
begin
|
||||
doTestRun(GetTestRegistry)
|
||||
end
|
||||
else
|
||||
if HasOption('suite') then
|
||||
begin
|
||||
S := '';
|
||||
S:=GetOptionValue('suite');
|
||||
if S = '' then
|
||||
for I := 0 to GetTestRegistry.Tests.count - 1 do
|
||||
writeln(GetTestRegistry[i].TestName)
|
||||
else
|
||||
for I := 0 to GetTestRegistry.Tests.count - 1 do
|
||||
if GetTestRegistry[i].TestName = S then
|
||||
begin
|
||||
doTestRun(GetTestRegistry[i]);
|
||||
end;
|
||||
end;
|
||||
Terminate;
|
||||
end;
|
||||
|
||||
|
||||
Var
|
||||
App : TTestRunner;
|
||||
|
||||
begin
|
||||
RegisterUnitTests;
|
||||
App:=TTestRunner.Create(Nil);
|
||||
App.Initialize;
|
||||
App.Title := 'FPCUnit Console Test Case runner.';
|
||||
App.Run;
|
||||
App.Free;
|
||||
end.
|
||||
14
fcl/fpcunit/demo/lazarusguiunner/guirunner.lpr
Normal file
14
fcl/fpcunit/demo/lazarusguiunner/guirunner.lpr
Normal file
@ -0,0 +1,14 @@
|
||||
program guirunner;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
Interfaces,
|
||||
Forms, main;
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TGuiTestRunner, GuiTestRunner);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
2165
fcl/fpcunit/demo/lazarusguiunner/main.lfm
Normal file
2165
fcl/fpcunit/demo/lazarusguiunner/main.lfm
Normal file
File diff suppressed because it is too large
Load Diff
1169
fcl/fpcunit/demo/lazarusguiunner/main.lrs
Normal file
1169
fcl/fpcunit/demo/lazarusguiunner/main.lrs
Normal file
File diff suppressed because it is too large
Load Diff
335
fcl/fpcunit/demo/lazarusguiunner/main.pas
Normal file
335
fcl/fpcunit/demo/lazarusguiunner/main.pas
Normal file
@ -0,0 +1,335 @@
|
||||
unit main;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, ExtCtrls,
|
||||
Buttons, ComCtrls, ActnList, Menus, Clipbrd, StdCtrls,
|
||||
testreport, fpcunit, testregistry;
|
||||
|
||||
const
|
||||
S_OK = 0; {$EXTERNALSYM S_OK}
|
||||
S_FALSE = $00000001; {$EXTERNALSYM S_FALSE}
|
||||
E_NOINTERFACE = HRESULT($80004002); {$EXTERNALSYM E_NOINTERFACE}
|
||||
|
||||
type
|
||||
|
||||
TGUITestRunner = class(TForm, ITestListener)
|
||||
actCopy: TAction;
|
||||
actCut: TAction;
|
||||
ActionList1: TActionList;
|
||||
BitBtn1: TBitBtn;
|
||||
btnRun: TBitBtn;
|
||||
ComboBox1: TComboBox;
|
||||
ImageList1: TImageList;
|
||||
ImageList2: TImageList;
|
||||
Label1: TLabel;
|
||||
Memo1: TMemo;
|
||||
MenuItem1: TMenuItem;
|
||||
MenuItem2: TMenuItem;
|
||||
MenuItem3: TMenuItem;
|
||||
PopupMenu1: TPopupMenu;
|
||||
PopupMenu2: TPopupMenu;
|
||||
SpeedButton1: TSpeedButton;
|
||||
SpeedButton2: TSpeedButton;
|
||||
XMLMemo: TMemo;
|
||||
PaintBox1: TPaintBox;
|
||||
Panel4: TPanel;
|
||||
Panel5: TPanel;
|
||||
Splitter1: TSplitter;
|
||||
PageControl1: TPageControl;
|
||||
Panel1: TPanel;
|
||||
Panel2: TPanel;
|
||||
Panel3: TPanel;
|
||||
tsTestTree: TTabSheet;
|
||||
tsResultsXML: TTabSheet;
|
||||
TreeView1: TTreeView;
|
||||
procedure BitBtn1Click(Sender: TObject);
|
||||
procedure GUITestRunnerCreate(Sender: TObject);
|
||||
procedure GUITestRunnerDestroy(Sender: TObject);
|
||||
procedure MenuItem3Click(Sender: TObject);
|
||||
procedure PaintBox1Click(Sender: TObject);
|
||||
procedure PaintBox1Paint(Sender: TObject);
|
||||
procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
|
||||
procedure TreeView1Click(Sender: TObject);
|
||||
procedure XMLMemoChange(Sender: TObject);
|
||||
procedure actCopyExecute(Sender: TObject);
|
||||
procedure actCutExecute(Sender: TObject);
|
||||
procedure btnRunClick(Sender: TObject);
|
||||
private
|
||||
{ private declarations }
|
||||
suiteList: TStringList;
|
||||
currentTestNode: TTreeNode;
|
||||
failureCounter: Longint;
|
||||
errorCounter: Longint;
|
||||
testsCounter: Longint;
|
||||
barColor: TColor;
|
||||
protected
|
||||
{ IInterface }
|
||||
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
|
||||
function _AddRef: Integer; stdcall;
|
||||
function _Release: Integer; stdcall;
|
||||
public
|
||||
class procedure RunUnitTests;
|
||||
procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
|
||||
procedure AddError(ATest: TTest; AError: TTestFailure);
|
||||
procedure StartTest(ATest: TTest);
|
||||
procedure EndTest(ATest: TTest);
|
||||
procedure DrawBar;
|
||||
end;
|
||||
|
||||
var
|
||||
GUITestRunner: TGUITestRunner;
|
||||
|
||||
implementation
|
||||
uses
|
||||
suiteconfig;
|
||||
|
||||
{ TGUITestRunner }
|
||||
|
||||
class procedure TGUITestRunner.RunUnitTests;
|
||||
begin
|
||||
with TGUITestRunner.Create(nil) do
|
||||
begin
|
||||
try
|
||||
ShowModal;
|
||||
finally
|
||||
Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.TreeView1Change(Sender: TObject; Node: TTreeNode);
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.TreeView1Click(Sender: TObject);
|
||||
var
|
||||
Node: TTreeNode;
|
||||
begin
|
||||
if TreeView1.Selected <> nil then
|
||||
begin
|
||||
Memo1.Lines.Clear;
|
||||
Node := TreeView1.Selected;
|
||||
if (Node.Level = 2) then
|
||||
if (TObject(Node.Data) is TTestFailure) then
|
||||
begin
|
||||
Memo1.Lines.Add('Exception Message: ' + TTestFailure(Node.Data).ExceptionMessage);
|
||||
Memo1.Lines.Add('Exception Class Name: ' + TTestFailure(Node.Data).ExceptionClassName);
|
||||
if TTestFailure(Node.Data).SourceUnitName <> '' then
|
||||
begin
|
||||
Memo1.Lines.Add('Unit Name: ' + TTestFailure(Node.Data).SourceUnitName);
|
||||
Memo1.Lines.Add('Method Name: ' + TTestFailure(Node.Data).MethodName);
|
||||
Memo1.Lines.Add('Line Number: ' + IntToStr(TTestFailure(Node.Data).LineNumber));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.XMLMemoChange(Sender: TObject);
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.actCopyExecute(Sender: TObject);
|
||||
begin
|
||||
Clipboard.AsText := XMLMemo.Lines.Text;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.actCutExecute(Sender: TObject);
|
||||
begin
|
||||
Clipboard.AsText := XMLMemo.Lines.Text;
|
||||
XMLMemo.Lines.Clear;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.GUITestRunnerCreate(Sender: TObject);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
suiteList := TStringList.Create;
|
||||
RegisterUnitTests;
|
||||
barColor := clGray;
|
||||
for i := 0 to GetTestRegistry.Tests.Count - 1 do
|
||||
ComboBox1.Items.Add(GetTestRegistry.Test[i].TestName);
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.BitBtn1Click(Sender: TObject);
|
||||
begin
|
||||
Close;
|
||||
end;
|
||||
|
||||
|
||||
procedure TGUITestRunner.GUITestRunnerDestroy(Sender: TObject);
|
||||
begin
|
||||
suiteList.Free;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.MenuItem3Click(Sender: TObject);
|
||||
begin
|
||||
Clipboard.AsText := Memo1.Lines.Text;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.PaintBox1Click(Sender: TObject);
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.PaintBox1Paint(Sender: TObject);
|
||||
var
|
||||
msg: string;
|
||||
begin
|
||||
with PaintBox1 do
|
||||
begin
|
||||
Canvas.Brush.Color := clGray;
|
||||
Canvas.Rectangle(0, 0, Width, Height);
|
||||
if (FailureCounter = 0) and (ErrorCounter = 0) then
|
||||
barColor := clGreen;
|
||||
Canvas.Brush.Color := barColor;
|
||||
if TestsCounter <> 0 then
|
||||
begin
|
||||
Canvas.Rectangle(0, 0, round((TestsCounter- FailureCounter- ErrorCounter)/TestsCounter*
|
||||
Width), Height);
|
||||
Canvas.Font.Color := clWhite;
|
||||
msg := 'Runs: ' + IntToStr(TestsCounter);
|
||||
if ErrorCounter <> 0 then
|
||||
msg := msg + ' Number of test errors: ' + IntToStr(ErrorCounter);
|
||||
if (FailureCounter <> 0) then
|
||||
msg := msg + ' Number of test failures: ' + IntToStr(FailureCounter);
|
||||
Canvas.Textout(10, 10, msg)
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.btnRunClick(Sender: TObject);
|
||||
var
|
||||
testResult: TTestResult;
|
||||
begin
|
||||
TreeView1.items.Clear;
|
||||
suiteList.Clear;
|
||||
currentTestNode := nil;
|
||||
failureCounter := 0;
|
||||
errorCounter := 0;
|
||||
testsCounter := 0;
|
||||
testResult := TTestResult.Create;
|
||||
try
|
||||
testResult.AddListener(self);
|
||||
if ComboBox1.ItemIndex = 0 then
|
||||
GetTestRegistry.Run(testResult)
|
||||
else
|
||||
(GetTestRegistry[ComboBox1.itemindex - 1]).Run(testResult);
|
||||
XMLMemo.lines.text:= TestResultAsXML(testResult);
|
||||
finally
|
||||
testResult.Free;
|
||||
end;
|
||||
PaintBox1.invalidate;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.AddFailure(ATest: TTest; AFailure: TTestFailure);
|
||||
var
|
||||
node: TTreeNode;
|
||||
begin
|
||||
node := TreeView1.Items.AddChildObject(currentTestNode, 'Message: ' + AFailure.ExceptionMessage, AFailure);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
node := TreeView1.Items.AddChildObject(currentTestNode, 'Exception: ' + AFailure.ExceptionClassName, AFailure);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
currentTestNode.ImageIndex := 3;
|
||||
currentTestNode.SelectedIndex := 3;
|
||||
node := TTreeNode(suiteList.Objects[suiteList.IndexOf(ATest.TestSuiteName)]);
|
||||
node.ImageIndex := 3;
|
||||
node.SelectedIndex := 3;
|
||||
Inc(failureCounter);
|
||||
Application.ProcessMessages;
|
||||
if BarColor <> clRed then
|
||||
barColor := clFuchsia;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.AddError(ATest: TTest; AError: TTestFailure);
|
||||
var
|
||||
node: TTreeNode;
|
||||
begin
|
||||
node := TreeView1.Items.AddChildObject(currentTestNode, 'Exception message: ' + AError.ExceptionMessage, AError);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
node := TreeView1.Items.AddChildObject(currentTestNode, 'Exception class: ' + AError.ExceptionClassName, AError);
|
||||
node.ImageIndex := 4;
|
||||
node.SelectedIndex := 4;
|
||||
node := TreeView1.Items.AddChildObject(currentTestNode, 'Unit name: ' + AError.SourceUnitName, AError);
|
||||
node.ImageIndex := 11;
|
||||
node.SelectedIndex := 11;
|
||||
node := TreeView1.Items.AddChildObject(currentTestNode, 'Method name: ' + AError.MethodName, AError);
|
||||
node.ImageIndex := 11;
|
||||
node.SelectedIndex := 11;
|
||||
node := TreeView1.Items.AddChildObject(currentTestNode, 'Line number: ' + IntToStr(AError.LineNumber), AError);
|
||||
node.ImageIndex := 11;
|
||||
node.SelectedIndex := 11;
|
||||
currentTestNode.ImageIndex := 2;
|
||||
currentTestNode.SelectedIndex := 2;
|
||||
node := TTreeNode(suiteList.Objects[suiteList.IndexOf(ATest.TestSuiteName)]);
|
||||
node.ImageIndex := 2;
|
||||
node.SelectedIndex := 2;
|
||||
Inc(errorCounter);
|
||||
Application.ProcessMessages;
|
||||
barColor := clRed;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.StartTest(ATest: TTest);
|
||||
var
|
||||
parentNode: TTreeNode;
|
||||
begin
|
||||
if suiteList.IndexOf(ATest.TestSuiteName) <> -1 then
|
||||
begin
|
||||
parentNode := TTreeNode(suiteList.Objects[suiteList.IndexOf(ATest.TestSuiteName)]);
|
||||
end
|
||||
else
|
||||
begin
|
||||
if TreeView1.Items.Count = 0 then
|
||||
begin
|
||||
parentNode := TreeView1.Items.AddFirst(nil, ATest.TestSuiteName);
|
||||
end
|
||||
else
|
||||
parentNode := TreeView1.Items.Add(TTreeNode(suiteList.Objects[SuiteList.Count - 1]), ATest.TestSuiteName);
|
||||
suiteList.AddObject(ATest.TestSuiteName, parentNode);
|
||||
end;
|
||||
currentTestNode := TreeView1.Items.AddChildObject(parentNode, ATest.TestName, ATest);
|
||||
Application.ProcessMessages;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.EndTest(ATest: TTest);
|
||||
begin
|
||||
Inc(testsCounter);
|
||||
PaintBox1.invalidate;
|
||||
end;
|
||||
|
||||
procedure TGUITestRunner.DrawBar;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
{ TGUITestRunner.IInterface }
|
||||
|
||||
function TGUITestRunner.QueryInterface(const IID: TGUID; out Obj): HResult; StdCall;
|
||||
begin
|
||||
if GetInterface(IID, Obj) then Result := S_OK
|
||||
else Result := E_NOINTERFACE
|
||||
end;
|
||||
|
||||
function TGUITestRunner._AddRef: Integer; StdCall;
|
||||
begin
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
function TGUITestRunner._Release: Integer; StdCall;
|
||||
begin
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
initialization
|
||||
{$I main.lrs}
|
||||
|
||||
end.
|
||||
|
||||
36
fcl/fpcunit/demo/lazarusguiunner/suiteconfig.pp
Normal file
36
fcl/fpcunit/demo/lazarusguiunner/suiteconfig.pp
Normal file
@ -0,0 +1,36 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec, Michael Van Canneyt
|
||||
|
||||
a unit to register the tests to be runned.
|
||||
|
||||
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 suiteconfig;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
fpcunittests;
|
||||
|
||||
procedure RegisterUnitTests;
|
||||
|
||||
implementation
|
||||
uses
|
||||
testregistry;
|
||||
|
||||
procedure RegisterUnitTests;
|
||||
begin
|
||||
RegisterTests([TTestCaseTest, TTestSuiteTest, TAssertTest, TListenerTest]);
|
||||
end;
|
||||
|
||||
end.
|
||||
570
fcl/fpcunit/exampletests/fpcunittests.pp
Normal file
570
fcl/fpcunit/exampletests/fpcunittests.pp
Normal file
@ -0,0 +1,570 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec, Michael Van Canneyt
|
||||
|
||||
unit tests of the FPCUnit framework.
|
||||
|
||||
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 fpcunittests;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes, fpcunit, testutils;
|
||||
|
||||
type
|
||||
|
||||
EMyException = class(Exception);
|
||||
|
||||
TTestCaseTest = class(TTestCase)
|
||||
private
|
||||
FFlag: integer;
|
||||
protected
|
||||
procedure SetUp; override;
|
||||
procedure TearDown; override;
|
||||
published
|
||||
procedure TestSetUp;
|
||||
procedure TestAsString;
|
||||
end;
|
||||
|
||||
TTestSuiteTest = class(TTestCase)
|
||||
private
|
||||
FSuite: TTestSuite;
|
||||
protected
|
||||
procedure SetUp; override;
|
||||
procedure TearDown; override;
|
||||
published
|
||||
procedure TestCountTestCases;
|
||||
procedure TestExtractMethods;
|
||||
end;
|
||||
|
||||
TAssertTest = class(TTestCase)
|
||||
private
|
||||
Fa,
|
||||
Fb: TObject;
|
||||
procedure FailEqualsInt;
|
||||
procedure FailEqualsInt64;
|
||||
procedure FailEqualsCurrency;
|
||||
procedure FailEqualsDouble;
|
||||
procedure FailEqualsBoolean;
|
||||
procedure FailEqualsChar;
|
||||
procedure FailEqualsTClass;
|
||||
procedure FailEqualsTObject;
|
||||
procedure FailAssertNull;
|
||||
procedure FailAssertNotNull;
|
||||
procedure RaiseMyException;
|
||||
procedure InterceptFailure(AMethod: TRunMethod; const ExpectedMessage: string);
|
||||
published
|
||||
procedure TestEqualsInt;
|
||||
procedure TestEqualsInt64;
|
||||
procedure TestEqualsCurrency;
|
||||
procedure TestEqualsDouble;
|
||||
procedure TestEqualsBoolean;
|
||||
procedure TestEqualsChar;
|
||||
procedure TestEqualsTClass;
|
||||
procedure TestEqualsTObject;
|
||||
procedure TestNull;
|
||||
procedure TestNotNull;
|
||||
procedure TestFailEqualsInt;
|
||||
procedure TestFailEqualsInt64;
|
||||
procedure TestFailEqualsCurrency;
|
||||
procedure TestFailEqualsDouble;
|
||||
procedure TestFailEqualsBoolean;
|
||||
procedure TestFailEqualsChar;
|
||||
procedure TestFailEqualsTClass;
|
||||
procedure TestFailEqualsTObject;
|
||||
procedure TestFailNull;
|
||||
procedure TestFailNotNull;
|
||||
procedure TestAssertException;
|
||||
end;
|
||||
|
||||
TMockListener = class(TNoRefCountObject, ITestListener)
|
||||
private
|
||||
FList: TStringList;
|
||||
FFailureList: TStringList;
|
||||
FErrorList: TStringList;
|
||||
FExpectedList: TStringList;
|
||||
public
|
||||
constructor Create; virtual;
|
||||
destructor Destroy; override;
|
||||
procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
|
||||
procedure AddError(ATest: TTest; AError: TTestFailure);
|
||||
procedure StartTest(ATest: TTest);
|
||||
procedure EndTest(ATest: TTest);
|
||||
procedure AddExpectedLine(ALine: string);
|
||||
procedure Verify(ActualList: TStrings);
|
||||
end;
|
||||
|
||||
TExampleTest = class(TTestCase)
|
||||
published
|
||||
procedure TestOne;
|
||||
procedure TestWithError;
|
||||
procedure TestWithFailure;
|
||||
end;
|
||||
|
||||
TListenerTest = class(TTestCase)
|
||||
private
|
||||
FMockListener: TMockListener;
|
||||
FResult: TTestResult;
|
||||
protected
|
||||
procedure SetUp; override;
|
||||
procedure TearDown; override;
|
||||
published
|
||||
procedure TestStartAndEndTest;
|
||||
procedure TestAddError;
|
||||
procedure TestAddFailure;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
procedure TTestCaseTest.SetUp;
|
||||
begin
|
||||
FFlag := 1
|
||||
end;
|
||||
|
||||
procedure TTestCaseTest.TearDown;
|
||||
begin
|
||||
FFlag := 0;
|
||||
end;
|
||||
|
||||
procedure TTestCaseTest.TestSetUp;
|
||||
begin
|
||||
AssertTrue( 'TTestCaseTest: wrong SetUp', FFlag = 1);
|
||||
end;
|
||||
|
||||
procedure TTestCaseTest.TestAsString;
|
||||
begin
|
||||
AssertEquals( 'TTestCaseTest: wrong AsString output', 'TESTASSTRING(TTestCaseTest)', AsString);
|
||||
end;
|
||||
|
||||
procedure TTestSuiteTest.SetUp;
|
||||
begin
|
||||
FSuite := TTestSuite.Create(TTestSuiteTest);
|
||||
end;
|
||||
|
||||
procedure TTestSuiteTest.TearDown;
|
||||
begin
|
||||
FSuite.Free;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
procedure TTestSuiteTest.TestCountTestCases;
|
||||
begin
|
||||
AssertTrue(FSuite.CountTestCases = 2);
|
||||
end;
|
||||
|
||||
procedure TTestSuiteTest.TestExtractMethods;
|
||||
var
|
||||
i: integer;
|
||||
s: string;
|
||||
begin
|
||||
s := '';
|
||||
for i := 0 to FSuite.CountTestCases - 1 do
|
||||
s := s + UpperCase(FSuite[i].TestName) + ' ';
|
||||
AssertEquals('Failure in extracting methods:', 'TESTCOUNTTESTCASES TESTEXTRACTMETHODS ', s );
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestEqualsInt;
|
||||
var
|
||||
i, j: integer;
|
||||
begin
|
||||
AssertEquals(33,33);
|
||||
i := 33;
|
||||
j := 33;
|
||||
AssertEquals(i, j);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestEqualsInt64;
|
||||
var
|
||||
i, j: int64;
|
||||
begin
|
||||
AssertEquals(1234567891234,1234567891234);
|
||||
i := 1234567891234;
|
||||
j := 1234567891234;
|
||||
AssertEquals(i, j);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestEqualsCurrency;
|
||||
var
|
||||
i, j: currency;
|
||||
begin
|
||||
AssertEquals(12345678912345.6789, 12345678912345.6789);
|
||||
i := 12345678912345.6789;
|
||||
j := 12345678912345.6789;
|
||||
AssertEquals(i, j);
|
||||
end;
|
||||
|
||||
|
||||
procedure TAssertTest.TestEqualsDouble;
|
||||
var
|
||||
i, j, delta: double;
|
||||
begin
|
||||
i := 0.123456;
|
||||
j := 0.123456;
|
||||
delta := 0.0000001;
|
||||
AssertEquals(i,j, delta);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestEqualsBoolean;
|
||||
var
|
||||
a, b: boolean;
|
||||
begin
|
||||
a := true;
|
||||
b := true;
|
||||
AssertEquals(a, b);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestEqualsChar;
|
||||
var
|
||||
a, b: char;
|
||||
begin
|
||||
a := 'a';
|
||||
b := 'a';
|
||||
AssertEquals(a, b);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestEqualsTClass;
|
||||
var
|
||||
a, b: TClass;
|
||||
begin
|
||||
a := TAssertTest;
|
||||
b := TAssertTest;
|
||||
AssertEquals(a, b);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestEqualsTObject;
|
||||
var
|
||||
a, b: TObject;
|
||||
begin
|
||||
a := TMockListener.Create;
|
||||
b := a;
|
||||
AssertSame(a, b);
|
||||
a.Free;
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestNull;
|
||||
begin
|
||||
AssertNull(nil);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestNotNull;
|
||||
var
|
||||
obj: TTestCase;
|
||||
begin
|
||||
obj := TTestCase.Create;
|
||||
AssertNotNull(obj);
|
||||
obj.Free;
|
||||
end;
|
||||
|
||||
procedure TAssertTest.InterceptFailure(AMethod: TRunMethod; const ExpectedMessage: string);
|
||||
var
|
||||
failureIntercepted: boolean;
|
||||
begin
|
||||
failureIntercepted := False;
|
||||
try
|
||||
AMethod;
|
||||
except
|
||||
on E: EAssertionFailedError do
|
||||
begin
|
||||
failureIntercepted := True;
|
||||
if (E.Message <> ExpectedMessage) then
|
||||
raise EAssertionFailedError.Create('Wrong failure message: expected <'+ ExpectedMessage + '>'
|
||||
+ 'but was <' + E.Message +'>');
|
||||
end
|
||||
else
|
||||
raise;
|
||||
end;
|
||||
if not failureIntercepted then
|
||||
raise EAssertionFailedError.Create('Expected an EAssertionFailedError');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.FailEqualsInt;
|
||||
var
|
||||
i, j: integer;
|
||||
begin
|
||||
i := 33;
|
||||
j := 34;
|
||||
AssertEquals(i, j);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.FailEqualsInt64;
|
||||
var
|
||||
i, j: int64;
|
||||
begin
|
||||
i := 33;
|
||||
j := 34;
|
||||
AssertEquals(i,j);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.FailEqualsCurrency;
|
||||
var
|
||||
i, j: Currency;
|
||||
begin
|
||||
i := 12345678912.6789;
|
||||
j := 12345678912.6788;
|
||||
AssertEquals(i,j);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.FailEqualsDouble;
|
||||
var
|
||||
i, j, delta: double;
|
||||
begin
|
||||
i := 33.00;
|
||||
j := 34.00;
|
||||
delta := 0.0000001;
|
||||
AssertEquals(i, j, delta);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.FailEqualsBoolean;
|
||||
var
|
||||
a, b: boolean;
|
||||
begin
|
||||
a := true;
|
||||
b := false;
|
||||
AssertEquals(a, b);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.FailEqualsChar;
|
||||
var
|
||||
a, b: char;
|
||||
begin
|
||||
a := 'a';
|
||||
b := 'b';
|
||||
AssertEquals(a, b);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.FailEqualsTClass;
|
||||
var
|
||||
a, b: TClass;
|
||||
begin
|
||||
a := TAssertTest;
|
||||
b := TTestSuiteTest;
|
||||
AssertEquals(a, b);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.FailEqualsTObject;
|
||||
begin
|
||||
AssertSame(Fa,Fb);
|
||||
FA.Free;
|
||||
FB.Free;
|
||||
end;
|
||||
|
||||
procedure TAssertTest.FailAssertNull;
|
||||
var
|
||||
obj: TTestCase;
|
||||
begin
|
||||
obj := TTestCase.Create;
|
||||
try
|
||||
AssertNull(obj);
|
||||
finally
|
||||
obj.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAssertTest.FailAssertNotNull;
|
||||
var
|
||||
obj: TObject;
|
||||
begin
|
||||
obj := nil;
|
||||
AssertNotNull(obj);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestFailEqualsInt;
|
||||
begin
|
||||
InterceptFailure(@FailEqualsInt, ' expected: <33> but was: <34>');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestFailEqualsInt64;
|
||||
begin
|
||||
InterceptFailure(@FailEqualsInt64, ' expected: <33> but was: <34>');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestFailEqualsCurrency;
|
||||
begin
|
||||
InterceptFailure(@FailEqualsCurrency, ' expected: <'+FloatToStr(12345678912.6789)+'> but was: <'+FloatToStr(12345678912.6788)+'>');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestFailEqualsDouble;
|
||||
begin
|
||||
InterceptFailure(@FailEqualsDouble, ' expected: <33> but was: <34>')
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestFailEqualsBoolean;
|
||||
begin
|
||||
InterceptFailure(@FailEqualsBoolean, ' expected: <TRUE> but was: <FALSE>');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestFailEqualsChar;
|
||||
begin
|
||||
InterceptFailure(@FailEqualsChar, ' expected: <a> but was: <b>');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestFailEqualsTClass;
|
||||
begin
|
||||
InterceptFailure(@FailEqualsTClass, ' expected: <TAssertTest> but was: <TTestSuiteTest>');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestFailEqualsTObject;
|
||||
begin
|
||||
FA := TAssertTest.Create;
|
||||
FB := TAssertTest.Create;
|
||||
InterceptFailure(@FailEqualsTObject, ' expected: <'+ IntToStr(PtrInt(FA)) +
|
||||
'> but was: <' + IntToStr(PtrInt(FB))+ '>');
|
||||
FA.Free;
|
||||
FB.Free;
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestFailNull;
|
||||
begin
|
||||
InterceptFailure(@FailAssertNull, '');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestFailNotNull;
|
||||
begin
|
||||
InterceptFailure(@FailAssertNotNull, '');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.RaiseMyException;
|
||||
begin
|
||||
raise EMyException.Create('EMyException raised');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestAssertException;
|
||||
begin
|
||||
AssertException(EMyException, @RaiseMyException);
|
||||
end;
|
||||
|
||||
constructor TMockListener.Create;
|
||||
begin
|
||||
FList := TStringList.Create;
|
||||
FFailureList := TStringList.Create;
|
||||
FErrorList := TStringList.Create;
|
||||
FExpectedList := TStringList.Create;
|
||||
end;
|
||||
|
||||
destructor TMockListener.Destroy;
|
||||
begin
|
||||
FList.Free;
|
||||
FFailureList.Free;
|
||||
FErrorList.Free;
|
||||
FExpectedList.Free;
|
||||
end;
|
||||
|
||||
procedure TMockListener.AddFailure(ATest: TTest; AFailure: TTestFailure);
|
||||
begin
|
||||
FFailureList.Add(ATest.TestName + ': ' + AFailure.ExceptionMessage);
|
||||
end;
|
||||
|
||||
procedure TMockListener.AddError(ATest: TTest; AError: TTestFailure);
|
||||
begin
|
||||
FErrorList.Add(ATest.TestName + ': ' + AError.ExceptionMessage);
|
||||
end;
|
||||
|
||||
procedure TMockListener.StartTest(ATest: TTest);
|
||||
begin
|
||||
FList.Add('Started: ' + ATest.TestName)
|
||||
end;
|
||||
|
||||
procedure TMockListener.EndTest(ATest: TTest);
|
||||
begin
|
||||
FList.Add('Ended: ' + ATest.TestName)
|
||||
end;
|
||||
|
||||
|
||||
procedure TMockListener.AddExpectedLine(ALine: string);
|
||||
begin
|
||||
FExpectedList.Add(ALine)
|
||||
end;
|
||||
|
||||
procedure TMockListener.Verify(ActualList: TStrings);
|
||||
begin
|
||||
TAssert.AssertEquals('Error in comparing text', FExpectedList.Text, ActualList.Text);
|
||||
end;
|
||||
|
||||
procedure TExampleTest.TestOne;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
i := 1;
|
||||
AssertEquals(1, i);
|
||||
end;
|
||||
|
||||
procedure TExampleTest.TestWithError;
|
||||
begin
|
||||
raise Exception.Create('Error Raised');
|
||||
end;
|
||||
|
||||
procedure TExampleTest.TestWithFailure;
|
||||
begin
|
||||
Fail('Failure Raised');
|
||||
end;
|
||||
|
||||
procedure TListenerTest.SetUp;
|
||||
begin
|
||||
FMockListener := TMockListener.Create;
|
||||
FResult := TTestResult.Create;
|
||||
FResult.AddListener(FMockListener);
|
||||
end;
|
||||
|
||||
procedure TListenerTest.TearDown;
|
||||
begin
|
||||
FMockListener.Free;
|
||||
FResult.Free;
|
||||
end;
|
||||
|
||||
procedure TListenerTest.TestStartAndEndTest;
|
||||
var
|
||||
t: TTestCase;
|
||||
begin
|
||||
t := TExampleTest.CreateWith('TestOne','TExampleTest');
|
||||
try
|
||||
t.Run(FResult);
|
||||
FMockListener.AddExpectedLine('Started: TestOne');
|
||||
FMockListener.AddExpectedLine('Ended: TestOne');
|
||||
FMockListener.Verify(FMockListener.FList);
|
||||
finally
|
||||
t.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TListenerTest.TestAddError;
|
||||
var
|
||||
t: TTestCase;
|
||||
begin
|
||||
t := TExampleTest.CreateWith('TestWithError', 'TExampleTest');
|
||||
try
|
||||
t.Run(FResult);
|
||||
FMockListener.AddExpectedLine('TestWithError: Error Raised');
|
||||
FMockListener.Verify(FMockListener.FErrorList);
|
||||
finally
|
||||
t.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TListenerTest.TestAddFailure;
|
||||
var
|
||||
t: TTestCase;
|
||||
begin
|
||||
t := TExampleTest.CreateWith('TestWithFailure', 'TExampleTest');
|
||||
try
|
||||
t.Run(FResult);
|
||||
FMockListener.AddExpectedLine('TestWithFailure: Failure Raised');
|
||||
FMockListener.Verify(FMockListener.FFailureList);
|
||||
finally
|
||||
t.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
415
fcl/fpcunit/exampletests/money.pp
Normal file
415
fcl/fpcunit/exampletests/money.pp
Normal file
@ -0,0 +1,415 @@
|
||||
unit money;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
type
|
||||
|
||||
TMoney = class;
|
||||
TMoneyBag = class;
|
||||
|
||||
IMoney = interface
|
||||
['{2E0160F6-312C-D911-8DE5-DD8AC3E7C6F4}']
|
||||
function add(m: IMoney): IMoney;
|
||||
function addMoney(m: TMoney): IMoney;
|
||||
function addMoneyBag(mb: TMoneyBag): IMoney;
|
||||
function isZero: boolean;
|
||||
function multiply(factor: integer): IMoney;
|
||||
function negate: IMoney;
|
||||
function subtract(m: IMoney): IMoney;
|
||||
procedure appendTo(m: TMoneyBag);
|
||||
function toString: String;
|
||||
function equals(m: IMoney): boolean;
|
||||
function Count: integer;
|
||||
function _Self: TObject;
|
||||
end;
|
||||
|
||||
ISingleCurrencyMoney = interface(IMoney)
|
||||
['{D6D97717-E52D-D911-83C4-8233402A6B6C}']
|
||||
function GetCurrencyUnit: string;
|
||||
function GetAmount: int64;
|
||||
property Amount: int64 read GetAmount;
|
||||
property CurrencyUnit: string read GetCurrencyUnit;
|
||||
end;
|
||||
|
||||
TMoney = class(TInterfacedObject, IMoney, ISingleCurrencyMoney)
|
||||
private
|
||||
FAmount: int64;
|
||||
FCurrencyUnit: String;
|
||||
function GetAmount: int64;
|
||||
function GetCurrencyUnit: string;
|
||||
public
|
||||
constructor Create(aAmount: int64; aCurrencyUnit: String);
|
||||
function add(m: IMoney): IMoney;
|
||||
function addMoney(m: TMoney): IMoney;
|
||||
function addMoneyBag(mb: TMoneyBag): IMoney;
|
||||
function isZero: Boolean;
|
||||
function multiply(factor: Integer): IMoney;
|
||||
function negate: IMoney;
|
||||
function subtract(m: IMoney): IMoney;
|
||||
procedure appendTo(m: TMoneyBag);
|
||||
function toString: String;
|
||||
function equals(m: IMoney): boolean;
|
||||
property Amount: int64 read GetAmount;
|
||||
property CurrencyUnit: string read GetCurrencyUnit;
|
||||
function Count: integer;
|
||||
function _Self: TObject;
|
||||
end;
|
||||
|
||||
TMoneyBag = class(TInterfacedObject, IMoney)
|
||||
private
|
||||
FMonies: TList;
|
||||
function AddToMoniesList(const Item: IInterface): Integer;
|
||||
function RemoveFromMoniesList(const Item: IInterface): Integer;
|
||||
function FindMoney(aCurrencyUnit: string): ISingleCurrencyMoney;
|
||||
function Contains(m: ISingleCurrencyMoney): boolean;
|
||||
public
|
||||
constructor Create;
|
||||
class function CreateWith(m1: IMoney; m2: IMoney): IMoney;
|
||||
destructor Destroy; override;
|
||||
function Simplify: IMoney;
|
||||
function add(m: IMoney): IMoney;
|
||||
function addMoney(m: TMoney): IMoney;
|
||||
function addMoneyBag(mb: TMoneyBag): IMoney;
|
||||
procedure appendBag(aBag: TMoneyBag);
|
||||
procedure appendMoney(aMoney: ISingleCurrencyMoney);
|
||||
function isZero: boolean;
|
||||
function multiply(factor: integer): IMoney;
|
||||
function negate: IMoney;
|
||||
function subtract(m: IMoney): IMoney;
|
||||
procedure appendTo(m: TMoneyBag);
|
||||
function toString: String;
|
||||
function equals(m: IMoney): boolean;
|
||||
function Count: integer;
|
||||
function _Self: TObject;
|
||||
end;
|
||||
|
||||
Operator + (c: IMoney; c1: IMoney) c2: IMoney;
|
||||
Operator - (c: IMoney; c1: IMoney) c2: IMoney;
|
||||
Operator * (c: IMoney; i: integer) c2: IMoney;
|
||||
|
||||
implementation
|
||||
|
||||
Operator + (c: IMoney; c1: IMoney) c2: IMoney;
|
||||
begin
|
||||
c2 := c.add(c1);
|
||||
end;
|
||||
|
||||
Operator - (c: IMoney; c1: IMoney) c2: IMoney;
|
||||
begin
|
||||
c2 := c.subtract(c1);
|
||||
end;
|
||||
|
||||
Operator * (c: IMoney; i: integer) c2: IMoney;
|
||||
begin
|
||||
c2 := c.multiply(i);
|
||||
end;
|
||||
|
||||
function TMoneyBag.AddToMoniesList(const Item: IInterface): Integer;
|
||||
begin
|
||||
Result := FMonies.Add(nil);
|
||||
IInterface(FMonies.List^[Result]) := Item;
|
||||
end;
|
||||
|
||||
function TMoneyBag.RemoveFromMoniesList(const Item: IInterface): Integer;
|
||||
begin
|
||||
Result := FMonies.IndexOf(Pointer(Item));
|
||||
if Result > -1 then
|
||||
begin
|
||||
IInterface(FMonies.List^[Result]) := nil;
|
||||
FMonies.Delete(Result);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMoneyBag.FindMoney(aCurrencyUnit: string): ISingleCurrencyMoney;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
for i := 0 to FMonies.Count - 1 do
|
||||
if ISingleCurrencyMoney(FMonies.items[i]).CurrencyUnit = aCurrencyUnit then
|
||||
begin
|
||||
Result := ISingleCurrencyMoney(FMonies.items[i]);
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMoneyBag.Contains(m: ISingleCurrencyMoney): boolean;
|
||||
var
|
||||
found: ISingleCurrencyMoney;
|
||||
begin
|
||||
found := FindMoney(m.CurrencyUnit);
|
||||
if found = nil then
|
||||
begin
|
||||
Result := false;
|
||||
Exit;
|
||||
end;
|
||||
Result := (found.Amount = m.amount);
|
||||
end;
|
||||
|
||||
class function TMoneyBag.CreateWith(m1: IMoney; m2: IMoney): IMoney;
|
||||
var
|
||||
mb: TMoneyBag;
|
||||
begin
|
||||
mb := TMoneyBag.Create;
|
||||
m1.AppendTo(mb);
|
||||
m2.AppendTo(mb);
|
||||
Result := mb.Simplify;
|
||||
end;
|
||||
|
||||
constructor TMoneyBag.Create;
|
||||
begin
|
||||
FMonies := TList.Create;
|
||||
end;
|
||||
|
||||
destructor TMoneyBag.Destroy;
|
||||
begin
|
||||
FMonies.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TMoneyBag.Simplify: IMoney;
|
||||
begin
|
||||
if FMonies.Count = 1 then
|
||||
Result := IInterface(FMonies.items[0]) as IMoney
|
||||
else
|
||||
Result := Self;
|
||||
end;
|
||||
|
||||
function TMoneyBag.add(m: IMoney): IMoney;
|
||||
begin
|
||||
Result := m.AddMoneyBag(Self);
|
||||
end;
|
||||
|
||||
function TMoneyBag.addMoney(m: TMoney): IMoney;
|
||||
begin
|
||||
Result := TMoneyBag.CreateWith(m, Self);
|
||||
end;
|
||||
|
||||
function TMoneyBag.addMoneyBag(mb: TMoneyBag): IMoney;
|
||||
begin
|
||||
Result := TMoneyBag.CreateWith(mb, Self);
|
||||
end;
|
||||
|
||||
procedure TMoneyBag.appendBag(aBag: TMoneyBag);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i := 0 to aBag.FMonies.Count - 1 do
|
||||
appendMoney(IUnknown(aBag.FMonies.Items[i]) as ISingleCurrencyMoney);
|
||||
end;
|
||||
|
||||
procedure TMoneyBag.appendMoney(aMoney: ISingleCurrencyMoney);
|
||||
var
|
||||
old: IMoney;
|
||||
sum: IMoney;
|
||||
begin
|
||||
if aMoney.isZero then Exit;
|
||||
old := findMoney(aMoney.CurrencyUnit);
|
||||
if old = nil then
|
||||
begin
|
||||
AddToMoniesList(aMoney);
|
||||
Exit;
|
||||
end;
|
||||
sum := old.Add(aMoney);
|
||||
RemoveFromMoniesList(old);
|
||||
if sum.isZero then Exit;
|
||||
AddToMoniesList(sum);
|
||||
end;
|
||||
|
||||
function TMoneyBag.isZero: boolean;
|
||||
begin
|
||||
Result := FMonies.Count = 0;
|
||||
end;
|
||||
|
||||
function TMoneyBag.multiply(factor: integer): IMoney;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
Result := TMoneyBag.Create;
|
||||
if factor <> 0 then
|
||||
for i := 0 to FMonies.Count - 1 do
|
||||
begin
|
||||
TMoneyBag(Result._Self).appendMoney((IInterface(FMonies.items[i])
|
||||
as ISingleCurrencyMoney).Multiply(factor) as ISingleCurrencyMoney);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMoneyBag.negate: IMoney;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
Result := TMoneyBag.Create;
|
||||
for i := 0 to FMonies.Count - 1 do
|
||||
begin
|
||||
TMoneyBag(Result._Self).appendMoney((IInterface(FMonies.items[i])
|
||||
as ISingleCurrencyMoney).negate as ISingleCurrencyMoney);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TMoneyBag.subtract(m: IMoney): IMoney;
|
||||
begin
|
||||
Result := Add(m.negate);
|
||||
end;
|
||||
|
||||
procedure TMoneyBag.appendTo(m: TMoneyBag);
|
||||
begin
|
||||
m.AppendBag(Self);
|
||||
end;
|
||||
|
||||
function TMoneyBag.toString: String;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
Result := '{';
|
||||
for i := 0 to FMonies.Count - 1 do
|
||||
Result := Result + (IInterface(FMonies.items[i]) as ISingleCurrencyMoney).ToString;
|
||||
Result := Result + '}';
|
||||
end;
|
||||
|
||||
function TMoneyBag.equals(m: IMoney): boolean;
|
||||
var
|
||||
aMoneyBag: TMoneyBag;
|
||||
i: integer;
|
||||
begin
|
||||
if m = nil then
|
||||
begin
|
||||
Result := false;
|
||||
Exit;
|
||||
end;
|
||||
if isZero then
|
||||
begin
|
||||
Result := m.isZero;
|
||||
Exit;
|
||||
end;
|
||||
if m._Self.ClassType = TMoneyBag then
|
||||
begin
|
||||
aMoneyBag := TMoneyBag(m._Self);
|
||||
if aMoneyBag.FMonies.count <> FMonies.Count then
|
||||
begin
|
||||
Result := false;
|
||||
Exit;
|
||||
end;
|
||||
for i := 0 to FMonies.Count - 1 do
|
||||
begin
|
||||
if not aMoneyBag.Contains(IInterface(FMonies.items[i]) as ISingleCurrencyMoney) then
|
||||
begin
|
||||
Result := false;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
Result := true;
|
||||
Exit;
|
||||
end;
|
||||
Result := false;
|
||||
end;
|
||||
|
||||
function TMoneyBag.Count: integer;
|
||||
begin
|
||||
Result := FMonies.Count;
|
||||
end;
|
||||
|
||||
function TMoneyBag._Self: TObject;
|
||||
begin
|
||||
Result := Self;
|
||||
end;
|
||||
|
||||
|
||||
{ TMoney }
|
||||
|
||||
function TMoney.GetCurrencyUnit: string;
|
||||
begin
|
||||
Result := FCurrencyUnit;
|
||||
end;
|
||||
|
||||
function TMoney.GetAmount: int64;
|
||||
begin
|
||||
Result := FAmount;
|
||||
end;
|
||||
|
||||
constructor TMoney.Create(aAmount: int64; aCurrencyUnit: string);
|
||||
begin
|
||||
FAmount := aAmount;
|
||||
FCurrencyUnit := aCurrencyUnit;
|
||||
end;
|
||||
|
||||
function TMoney.add(m: IMoney): IMoney;
|
||||
begin
|
||||
Result := m.AddMoney(Self);
|
||||
end;
|
||||
|
||||
function TMoney.addMoney(m: TMoney): IMoney;
|
||||
begin
|
||||
if (m.CurrencyUnit = Self.CurrencyUnit) then
|
||||
Result := TMoney.Create(Self.Amount + m.Amount, Self.CurrencyUnit)
|
||||
else
|
||||
Result := TMoneyBag.CreateWith(Self, M);
|
||||
end;
|
||||
|
||||
function TMoney.addMoneyBag(mb: TMoneyBag): IMoney;
|
||||
begin
|
||||
Result := mb.AddMoney(Self);
|
||||
end;
|
||||
|
||||
function TMoney.isZero: Boolean;
|
||||
begin
|
||||
Result := Amount = 0;
|
||||
end;
|
||||
|
||||
function TMoney.multiply(factor: Integer): IMoney;
|
||||
begin
|
||||
Result := TMoney.Create(Amount * factor, CurrencyUnit);
|
||||
end;
|
||||
|
||||
function TMoney.negate: IMoney;
|
||||
begin
|
||||
Result := TMoney.Create(- Amount, CurrencyUnit);
|
||||
end;
|
||||
|
||||
function TMoney.subtract(m: IMoney): IMoney;
|
||||
begin
|
||||
Result := Add(m.negate);
|
||||
end;
|
||||
|
||||
procedure TMoney.appendTo(m: TMoneyBag);
|
||||
begin
|
||||
m.AppendMoney(Self);
|
||||
end;
|
||||
|
||||
function TMoney.toString: String;
|
||||
begin
|
||||
Result := '[' + IntToStr(FAmount) + ' '+ FCurrencyUnit + ']';
|
||||
end;
|
||||
|
||||
function TMoney.equals(m: IMoney): boolean;
|
||||
begin
|
||||
if Assigned(m) then
|
||||
begin
|
||||
if isZero then
|
||||
if Assigned(m as IMoney) then
|
||||
Result := (m as IMoney).isZero;
|
||||
if m._Self.ClassType = TMoney then
|
||||
Result := ((m as ISingleCurrencyMoney).Amount = Amount) and
|
||||
((m as ISingleCurrencyMoney).CurrencyUnit = CurrencyUnit)
|
||||
else
|
||||
Result := false;
|
||||
end
|
||||
else
|
||||
Result := false;
|
||||
end;
|
||||
|
||||
function TMoney.Count: integer;
|
||||
begin
|
||||
Result := 1;
|
||||
end;
|
||||
|
||||
function TMoney._Self: TObject;
|
||||
begin
|
||||
Result := Self;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
284
fcl/fpcunit/exampletests/moneytest.pp
Normal file
284
fcl/fpcunit/exampletests/moneytest.pp
Normal file
@ -0,0 +1,284 @@
|
||||
unit moneytest;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, fpcunit, money;
|
||||
|
||||
type
|
||||
|
||||
TMoneyTest = class(TTestCase)
|
||||
private
|
||||
F12CHF: IMoney;
|
||||
F14CHF: IMoney;
|
||||
F7USD: IMoney;
|
||||
F21USD: IMoney;
|
||||
FMB1: IMoney;
|
||||
FMB2: IMoney;
|
||||
protected
|
||||
procedure SetUp; override;
|
||||
procedure TearDown; override;
|
||||
published
|
||||
procedure testBagCreate;
|
||||
procedure testBagMultiply;
|
||||
procedure testBagNegate;
|
||||
procedure testBagSimpleAdd;
|
||||
procedure testBagSubtract;
|
||||
procedure testBagSumAdd;
|
||||
procedure testIsZero;
|
||||
procedure testMixedSimpleAdd;
|
||||
procedure testBagNotEquals;
|
||||
procedure testMoneyBagEquals;
|
||||
procedure testMoneyEquals;
|
||||
procedure testSimplify;
|
||||
procedure testNormalize2;
|
||||
procedure testNormalize3;
|
||||
procedure testNormalize4;
|
||||
procedure testPrint;
|
||||
procedure testMoneyBagPrint;
|
||||
procedure testSimpleAdd;
|
||||
procedure testSimpleBagAdd;
|
||||
procedure testSimpleMultiply;
|
||||
procedure testSimpleNegate;
|
||||
procedure testSimpleSubtract;
|
||||
procedure testOperators;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{ TMoneyTest }
|
||||
|
||||
procedure TMoneyTest.SetUp;
|
||||
begin
|
||||
F12CHF := TMoney.Create(12, 'CHF');
|
||||
F14CHF := TMoney.Create(14, 'CHF');
|
||||
F7USD := TMoney.Create(7, 'USD');
|
||||
F21USD := TMoney.Create(21, 'USD');
|
||||
FMB1 := TMoneyBag.CreateWith(F12CHF, F7USD);
|
||||
FMB2 := TMoneyBag.CreateWith(F14CHF, F21USD);
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.TearDown;
|
||||
begin
|
||||
F12CHF := nil;
|
||||
F14CHF := nil;
|
||||
F7USD := nil;
|
||||
F21USD := nil;
|
||||
FMB1 := nil;
|
||||
FMB2 := nil;
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testBagCreate;
|
||||
begin
|
||||
AssertEquals('Wrong number of moneys in bag', 2, FMB1.Count);
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testBagMultiply;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoneyBag.CreateWith(TMoney.Create(24, 'CHF'), TMoney.Create(14, 'USD'));
|
||||
AssertTrue(expected.equals(FMB1.multiply(2)));
|
||||
AssertTrue(FMB1.equals(FMB1.multiply(1)));
|
||||
AssertTrue('multiplication by zero failed', FMB1.multiply(0).isZero);
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testBagNegate;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoneyBag.CreateWith(TMoney.Create(-12, 'CHF'), TMoney.Create(-7, 'USD'));
|
||||
AssertTrue('expected '+ expected.toString + ' but was ' + FMB1.negate.toString, expected.equals(FMB1.negate));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testBagSimpleAdd;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoneyBag.CreateWith(TMoney.Create(26, 'CHF'), TMoney.Create(7, 'USD'));
|
||||
AssertTrue('expected ' + expected.toString + ' but was ' + FMB1.add(F14CHF).toString, expected.equals(FMB1.add(F14CHF)));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testBagSubtract;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoneyBag.CreateWith(TMoney.Create(-2, 'CHF'), TMoney.Create(-14, 'USD'));
|
||||
AssertTrue('expected ' + expected.toString + ' but was ' + FMB1.subtract(FMB2).toString, expected.equals(FMB1.Subtract(FMB2)));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testBagSumAdd;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoneyBag.CreateWith(TMoney.Create(26, 'CHF'), TMoney.Create(28, 'USD'));
|
||||
AssertTrue('expected ' + expected.toString + ' but was ' + FMB1.add(FMB2).toString, expected.equals(FMB1.add(FMB2)));
|
||||
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testIsZero;
|
||||
begin
|
||||
AssertTrue('error: [0 CHF] is to be considered zero!', TMoney.Create(0, 'CHF').IsZero);
|
||||
AssertFalse('error: [12 USD] is not to be considered zero!', TMoney.Create(12, 'USD').IsZero);
|
||||
AssertTrue(FMB1.subtract(FMB1).isZero);
|
||||
AssertTrue(TMoneyBag.CreateWith(TMoney.Create(0, 'CHF'), TMoney.Create(0, 'USD')).isZero);
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testMixedSimpleAdd;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoneyBag.CreateWith(F12CHF, F7USD);
|
||||
AssertTrue('expected ' + expected.toString + ' but was ' + F12CHF.add(F7USD).toString, expected.equals(F12CHF.add(F7USD)));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testBagNotEquals;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoneyBag.CreateWith(F12CHF, F7USD);
|
||||
AssertFalse(expected.equals(TMoney.Create(12, 'CAD').add(F7USD)));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testMoneyBagEquals;
|
||||
var
|
||||
equal: IMoney;
|
||||
begin
|
||||
AssertTrue(not FMB1.equals(nil));
|
||||
AssertTrue(FMB1.equals(FMB1));
|
||||
equal := TMoneyBag.CreateWith(TMoney.Create(12, 'CHF'), TMoney.Create(7, 'USD'));
|
||||
AssertTrue(FMB1.equals(equal));
|
||||
AssertTrue(not FMB1.equals(F12CHF));
|
||||
AssertTrue(not F12CHF.equals(FMB1));
|
||||
AssertTrue(not FMB1.equals(FMB2));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testMoneyEquals;
|
||||
var
|
||||
equalMoney: IMoney;
|
||||
begin
|
||||
AssertTrue('error: [12 CHF] does not equal nil', not F12CHF.equals(nil));
|
||||
equalMoney := TMoney.Create(12, 'CHF');
|
||||
AssertTrue(F12CHF.equals(F12CHF));
|
||||
AssertTrue(F12CHF.equals(equalMoney));
|
||||
AssertFalse(F12CHF.equals(F14CHF));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testSimplify;
|
||||
var
|
||||
money: IMoney;
|
||||
begin
|
||||
money := TMoneyBag.CreateWith(TMoney.Create(26, 'CHF'), TMoney.Create(28, 'CHF'));
|
||||
AssertTrue('Expected ' + TMoney.Create(54, 'CHF').toString + ' but was '
|
||||
+ money.toString, TMoney.Create(54, 'CHF').equals(money));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testNormalize2;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
// {[12 CHF][7 USD]} - [12 CHF] = [7 USD]
|
||||
expected := TMoney.Create(7, 'USD');
|
||||
AssertTrue('Expected ' + expected.toString + ' but was '
|
||||
+ FMB1.subtract(F12CHF).toString, expected.equals(FMB1.subtract(F12CHF)));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testNormalize3;
|
||||
var
|
||||
ms1: IMoney;
|
||||
expected: IMoney;
|
||||
begin
|
||||
// {[12 CHF][7 USD]} - {[12 CHF][3 USD]} = [4 USD]
|
||||
ms1 := TMoneyBag.CreateWith(TMoney.Create(12, 'CHF'), TMoney.Create(3, 'USD'));
|
||||
expected := TMoney.Create(4, 'USD');
|
||||
AssertTrue('Expected ' + expected.toString + ' but was ' + FMB1.subtract(ms1).toString,
|
||||
expected.equals(FMB1.subtract(ms1)));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testNormalize4;
|
||||
var
|
||||
ms1: IMoney;
|
||||
expected: IMoney;
|
||||
begin
|
||||
// [12 CHF] - {[12 CHF][3 USD]} = [-3 USD]
|
||||
ms1 := TMoneyBag.CreateWith(TMoney.Create(12, 'CHF'), TMoney.Create(3, 'USD'));
|
||||
expected := TMoney.Create(-3, 'USD');
|
||||
AssertTrue('Expected ' + expected.toString + ' but was ' + F12CHF.subtract(ms1).toString,
|
||||
expected.equals(F12CHF.subtract(ms1)));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testPrint;
|
||||
begin
|
||||
AssertEquals('[12 CHF]', F12CHF.ToString);
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testMoneyBagPrint;
|
||||
begin
|
||||
AssertEquals('{[12 CHF][7 USD]}', FMB1.toString);
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testSimpleAdd;
|
||||
var
|
||||
expected: IMoney;
|
||||
res: IMoney;
|
||||
begin
|
||||
expected := TMoney.Create(26, 'CHF');
|
||||
res := F12CHF.add(F14CHF);
|
||||
AssertTrue('addition error: [12 CHF] + [14 CHF] was not [26 CHF]', res.equals(expected));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testSimpleBagAdd;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoneyBag.CreateWith(TMoney.Create(26, 'CHF'), TMoney.Create(7, 'USD'));
|
||||
AssertTrue('expected ' + expected.toString + ' but was ' + F14CHF.add(FMB1).toString, expected.equals(F14CHF.add(FMB1)));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testSimpleMultiply;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoney.Create(28, 'CHF');
|
||||
AssertTrue('Multiply Error: [14 CHF] * 2 was not equal to [28 CHF]',
|
||||
expected.equals(F14CHF.Multiply(2)));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testSimpleNegate;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoney.Create(-14, 'CHF');
|
||||
AssertTrue('Negate Error: [14 CHF] negate was not equal to [-14 CHF]',
|
||||
expected.equals(F14CHF.negate));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testSimpleSubtract;
|
||||
var
|
||||
expected: IMoney;
|
||||
begin
|
||||
expected := TMoney.Create(2, 'CHF');
|
||||
AssertTrue('Negate Error: [14 CHF] - [12 CHF] was not equal to [2 CHF]',
|
||||
expected.equals(F14CHF.subtract(F12CHF)));
|
||||
end;
|
||||
|
||||
procedure TMoneyTest.testOperators;
|
||||
var
|
||||
mb: IMoney;
|
||||
ma: IMoney;
|
||||
begin
|
||||
ma := TMoney.Create(2, 'CHF');
|
||||
AssertTrue(F14CHF.equals(F12CHF + ma ));
|
||||
AssertTrue('expected ' + FMB1.toString +' but was ' +
|
||||
(FMB2 - TMoneyBag.CreateWith(TMoney.Create(2, 'CHF'), TMoney.Create(14, 'USD'))).toString,
|
||||
FMB1.equals(FMB2 - TMoneyBag.CreateWith(TMoney.Create(2, 'CHF'), TMoney.Create(14, 'USD'))));
|
||||
mb := TMoneyBag.CreateWith(TMoney.Create(28, 'CHF'), TMoney.Create(42, 'USD'));
|
||||
AssertTrue('expected ' + mb.toString + ' but was ' + (FMB2 *2).toString, (FMB2 * 2).equals(mb));
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
888
fcl/fpcunit/fpcunit.pp
Normal file
888
fcl/fpcunit/fpcunit.pp
Normal file
@ -0,0 +1,888 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec, Michael Van Canneyt
|
||||
|
||||
Port to Free Pascal of the JUnit framework.
|
||||
|
||||
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 fpcunit;
|
||||
|
||||
interface
|
||||
|
||||
{$define SHOWLINEINFO}
|
||||
|
||||
uses
|
||||
{$ifdef SHOWLINEINFO}
|
||||
LineInfo,
|
||||
{$endif}
|
||||
SysUtils, Classes;
|
||||
|
||||
type
|
||||
|
||||
EAssertionFailedError = class(Exception)
|
||||
constructor Create; overload;
|
||||
constructor Create(const msg :string); overload;
|
||||
end;
|
||||
|
||||
TRunMethod = procedure of object;
|
||||
|
||||
TTestResult = class;
|
||||
|
||||
{$M+}
|
||||
TTest = class(TObject)
|
||||
protected
|
||||
function GetTestName: string; virtual;
|
||||
function GetTestSuiteName: string; virtual;
|
||||
public
|
||||
function CountTestCases: integer; virtual;
|
||||
procedure Run(AResult: TTestResult); virtual;
|
||||
published
|
||||
property TestName: string read GetTestName;
|
||||
property TestSuiteName: string read GetTestSuiteName;
|
||||
end;
|
||||
{$M-}
|
||||
|
||||
TAssert = class(TTest)
|
||||
public
|
||||
class procedure Fail(const AMessage: string);
|
||||
class procedure AssertTrue(const AMessage: string; ACondition: boolean); overload;
|
||||
class procedure AssertTrue(ACondition: boolean); overload;
|
||||
class procedure AssertFalse(const AMessage: string; ACondition: boolean); overload;
|
||||
class procedure AssertFalse(ACondition: boolean); overload;
|
||||
class procedure AssertEquals(const AMessage: string; Expected, Actual: string); overload;
|
||||
class procedure AssertEquals(Expected, Actual: string); overload;
|
||||
class procedure AssertEquals(const AMessage: string; Expected, Actual: integer); overload;
|
||||
class procedure AssertEquals(Expected, Actual: integer); overload;
|
||||
class procedure AssertEquals(const AMessage: string; Expected, Actual: int64); overload;
|
||||
class procedure AssertEquals(Expected, Actual: int64); overload;
|
||||
class procedure AssertEquals(const AMessage: string; Expected, Actual: currency); overload;
|
||||
class procedure AssertEquals(Expected, Actual: currency); overload;
|
||||
class procedure AssertEquals(const AMessage: string; Expected, Actual, Delta: double); overload;
|
||||
class procedure AssertEquals(Expected, Actual, Delta: double); overload;
|
||||
class procedure AssertEquals(const AMessage: string; Expected, Actual: boolean); overload;
|
||||
class procedure AssertEquals(Expected, Actual: boolean); overload;
|
||||
class procedure AssertEquals(const AMessage: string; Expected, Actual: char); overload;
|
||||
class procedure AssertEquals(Expected, Actual: char); overload;
|
||||
class procedure AssertEquals(const AMessage: string; Expected, Actual: TClass); overload;
|
||||
class procedure AssertEquals(Expected, Actual: TClass); overload;
|
||||
class procedure AssertSame(const AMessage: string; Expected, Actual: TObject); overload;
|
||||
class procedure AssertSame(Expected, Actual: TObject); overload;
|
||||
class procedure AssertNotSame(const AMessage: string; Expected, Actual: TObject); overload;
|
||||
class procedure AssertNotSame(Expected, Actual: TObject); overload;
|
||||
class procedure AssertNotNull(const AMessage: string; AObject: TObject); overload;
|
||||
class procedure AssertNotNull(AObject: TObject); overload;
|
||||
class procedure AssertNull(const AMessage: string; AObject: TObject); overload;
|
||||
class procedure AssertNull(AObject: TObject); overload;
|
||||
class procedure AssertNotNull(const AMessage, AString: string); overload;
|
||||
class procedure AssertNotNull(const AString: string); overload;
|
||||
class procedure AssertException(const AMessage: string; AExceptionClass: ExceptClass; AMethod: TRunMethod); overload;
|
||||
class procedure AssertException(AExceptionClass: ExceptClass; AMethod: TRunMethod); overload;
|
||||
end;
|
||||
|
||||
TTestFailure = class(TObject)
|
||||
private
|
||||
FTestName: string;
|
||||
FTestSuiteName: string;
|
||||
FLineNumber: longint;
|
||||
FMethodName: string;
|
||||
FRaisedExceptionClass: TClass;
|
||||
FRaisedExceptionMessage: string;
|
||||
FSourceUnitName: string;
|
||||
function GetAsString: string;
|
||||
function GetExceptionMessage: string;
|
||||
function GetIsFailure: boolean;
|
||||
function GetExceptionClassName: string;
|
||||
public
|
||||
constructor CreateFailure(ATest: TTest; E: Exception);
|
||||
property ExceptionClass: TClass read FRaisedExceptionClass;
|
||||
published
|
||||
property AsString: string read GetAsString;
|
||||
property IsFailure: boolean read GetIsFailure;
|
||||
property ExceptionMessage: string read GetExceptionMessage;
|
||||
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;
|
||||
end;
|
||||
|
||||
ITestListener = interface
|
||||
['{0CE9D3AE-882A-D811-9401-ADEB5E4C7FC1}']
|
||||
procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
|
||||
procedure AddError(ATest: TTest; AError: TTestFailure);
|
||||
procedure StartTest(ATest: TTest);
|
||||
procedure EndTest(ATest: TTest);
|
||||
end;
|
||||
|
||||
TTestCase = class(TAssert)
|
||||
private
|
||||
FName: string;
|
||||
FTestSuiteName: string;
|
||||
protected
|
||||
function CreateResult: TTestResult; virtual;
|
||||
procedure SetUp; virtual;
|
||||
procedure TearDown; virtual;
|
||||
procedure RunTest; virtual;
|
||||
function GetTestName: string; override;
|
||||
function GetTestSuiteName: string; override;
|
||||
procedure SetTestSuiteName(const aName: string); virtual;
|
||||
procedure SetTestName(const Value: string); virtual;
|
||||
public
|
||||
constructor Create; virtual;
|
||||
constructor CreateWith(const AName: string; const ATestSuiteName: string); virtual;
|
||||
constructor CreateWithName(const AName: string); virtual;
|
||||
function CountTestCases: integer; override;
|
||||
function CreateResultAndRun: TTestResult; virtual;
|
||||
procedure Run(AResult: TTestResult); override;
|
||||
procedure RunBare; virtual;
|
||||
function AsString: string;
|
||||
property TestSuiteName: string read GetTestSuiteName write SetTestSuiteName;
|
||||
published
|
||||
property TestName: string read GetTestName write SetTestName;
|
||||
end;
|
||||
|
||||
TTestClass = Class of TTestCase;
|
||||
|
||||
TTestSuite = class(TTest)
|
||||
private
|
||||
FTests: TList;
|
||||
FName: string;
|
||||
FTestSuiteName: string;
|
||||
function GetTest(Index: integer): TTest;
|
||||
protected
|
||||
function IsTestMethod(AMethodName: string): boolean; virtual;
|
||||
function GetTestName: string; override;
|
||||
function GetTestSuiteName: string; override;
|
||||
procedure SetTestSuiteName(const aName: string); virtual;
|
||||
procedure SetTestName(const Value: string); virtual;
|
||||
public
|
||||
constructor Create(AClass: TClass; AName: string); reintroduce; overload; virtual;
|
||||
constructor Create(AClass: TClass); reintroduce; overload; virtual;
|
||||
constructor Create(AClassArray: Array of TClass); reintroduce; overload; virtual;
|
||||
constructor Create(AName: string); reintroduce; overload; virtual;
|
||||
constructor Create; reintroduce; overload; virtual;
|
||||
destructor Destroy; override;
|
||||
function CountTestCases: integer; override;
|
||||
procedure Run(AResult: TTestResult); override;
|
||||
procedure RunTest(ATest: TTest; AResult: TTestResult); virtual;
|
||||
procedure AddTest(ATest: TTestCase); overload; virtual;
|
||||
procedure AddTest(ATestSuite: TTestSuite); overload; virtual;
|
||||
procedure AddTestSuiteFromClass(ATestClass: TClass); virtual;
|
||||
class function Warning(const aMessage: string): TTestCase;
|
||||
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;
|
||||
end;
|
||||
|
||||
TTestResult = class(TObject)
|
||||
private
|
||||
protected
|
||||
FRunTests: integer;
|
||||
FFailures: TList;
|
||||
FErrors: TList;
|
||||
FListeners: TList;
|
||||
function GetNumErrors: integer;
|
||||
function GetNumFailures: integer;
|
||||
public
|
||||
constructor Create; virtual;
|
||||
destructor Destroy; override;
|
||||
property Listeners: TList 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);
|
||||
procedure EndTest(ATest: TTest);
|
||||
procedure AddListener(AListener: ITestListener);
|
||||
procedure RemoveListener(AListener: ITestListener);
|
||||
procedure Run(ATestCase: TTestCase);
|
||||
procedure RunProtected(ATestCase: TTestCase);
|
||||
function WasSuccessful: boolean;
|
||||
published
|
||||
property Failures: TList read FFailures;
|
||||
property Errors: TList read FErrors;
|
||||
property RunTests: integer read FRunTests;
|
||||
property NumberOfErrors: integer read GetNumErrors;
|
||||
property NumberOfFailures: integer read GetNumFailures;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
testutils;
|
||||
|
||||
type
|
||||
|
||||
TTestWarning = class(TTestCase)
|
||||
private
|
||||
FMessage: String;
|
||||
protected
|
||||
procedure RunTest; override;
|
||||
end;
|
||||
|
||||
procedure TTestWarning.RunTest;
|
||||
begin
|
||||
Fail(FMessage);
|
||||
end;
|
||||
|
||||
constructor EAssertionFailedError.Create;
|
||||
begin
|
||||
inherited Create('');
|
||||
end;
|
||||
|
||||
constructor EAssertionFailedError.Create(const msg: string);
|
||||
begin
|
||||
inherited Create(msg);
|
||||
end;
|
||||
|
||||
constructor TTestFailure.CreateFailure(ATest: TTest; E: Exception);
|
||||
begin
|
||||
inherited Create;
|
||||
FTestName := ATest.GetTestName;
|
||||
FTestSuiteName := ATest.GetTestSuiteName;
|
||||
FRaisedExceptionClass := E.ClassType;
|
||||
FRaisedExceptionMessage := E.Message;
|
||||
end;
|
||||
|
||||
function TTestFailure.GetAsString: string;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
if FTestSuiteName <> '' then
|
||||
s := FTestSuiteName + '.'
|
||||
else
|
||||
s := '';
|
||||
Result := s + FTestName + ': ' + FRaisedExceptionMessage;
|
||||
end;
|
||||
|
||||
function TTestFailure.GetExceptionClassName: string;
|
||||
begin
|
||||
Result := FRaisedExceptionClass.ClassName;
|
||||
end;
|
||||
|
||||
function TTestFailure.GetExceptionMessage: string;
|
||||
begin
|
||||
Result := FRaisedExceptionMessage;
|
||||
end;
|
||||
|
||||
function TTestFailure.GetIsFailure: boolean;
|
||||
begin
|
||||
Result := FRaisedExceptionClass.InheritsFrom(EAssertionFailedError);
|
||||
end;
|
||||
|
||||
{ TTest}
|
||||
|
||||
function TTest.GetTestName: string;
|
||||
begin
|
||||
Result := 'TTest';
|
||||
end;
|
||||
|
||||
function TTest.GetTestSuiteName: string;
|
||||
begin
|
||||
Result := 'TTest';
|
||||
end;
|
||||
|
||||
function TTest.CountTestCases: integer;
|
||||
begin
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
procedure TTest.Run(AResult: TTestResult);
|
||||
begin
|
||||
end;
|
||||
|
||||
{ TAssert }
|
||||
|
||||
class procedure TAssert.Fail(const AMessage: String);
|
||||
begin
|
||||
raise EAssertionFailedError.Create(AMessage);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertTrue(const AMessage: String; ACondition: Boolean);
|
||||
begin
|
||||
if (not ACondition) then
|
||||
Fail(AMessage);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertTrue(ACondition: Boolean);
|
||||
begin
|
||||
AssertTrue('', ACondition);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertFalse(const AMessage: String; ACondition: Boolean);
|
||||
begin
|
||||
AssertTrue(AMessage, not ACondition);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertFalse(ACondition: Boolean);
|
||||
begin
|
||||
AssertFalse('', ACondition);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: string);
|
||||
begin
|
||||
AssertTrue(AMessage + ': ' + 'expected <' + Expected+ '> but was <' + Actual + '>' ,
|
||||
AnsiCompareStr(Expected, Actual) = 0);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(Expected, Actual: string);
|
||||
begin
|
||||
AssertEquals('', Expected, Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertNotNull(const AString: string);
|
||||
begin
|
||||
AssertNotNull('', AString);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: integer);
|
||||
begin
|
||||
AssertTrue(AMessage + ' ' + 'expected: <' + IntToStr(Expected) + '> but was: <'
|
||||
+ IntToStr(Actual) + '>', Expected = Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(Expected, Actual: integer);
|
||||
begin
|
||||
AssertEquals('', Expected, Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: int64);
|
||||
begin
|
||||
AssertTrue(AMessage + ' ' + 'expected: <' + IntToStr(Expected) + '> but was: <'
|
||||
+ IntToStr(Actual) + '>', Expected = Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(Expected, Actual: int64);
|
||||
begin
|
||||
AssertEquals('', Expected, Actual);
|
||||
end;
|
||||
|
||||
|
||||
class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: currency);
|
||||
begin
|
||||
AssertTrue(AMessage + ' ' + 'expected: <' + FloatToStr(Expected) + '> but was: <'
|
||||
+ FloatToStr(Actual) + '>', Expected = Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(Expected, Actual: currency);
|
||||
begin
|
||||
AssertEquals('', Expected, Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual, Delta: double);
|
||||
begin
|
||||
AssertTrue(AMessage + ' ' + 'expected: <' + FloatToStr(Expected) + '> but was: <'
|
||||
+ FloatToStr(Actual) + '>', (Abs(Expected - Actual) <= Delta));
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(Expected, Actual, Delta: double);
|
||||
begin
|
||||
AssertEquals('', Expected, Actual, Delta);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertNotNull(const AMessage, AString: string);
|
||||
begin
|
||||
AssertTrue(AMessage, AString <> '');
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: boolean);
|
||||
begin
|
||||
AssertTrue(AMessage + ' ' + 'expected: <' + BoolToStr(Expected) + '> but was: <'
|
||||
+ BoolToStr(Actual) + '>', Expected = Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(Expected, Actual: boolean);
|
||||
begin
|
||||
AssertEquals('', Expected, Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: char);
|
||||
begin
|
||||
AssertTrue(AMessage + ' ' + 'expected: <' + Expected + '> but was: <'
|
||||
+ Actual + '>', Expected = Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(Expected, Actual: char);
|
||||
begin
|
||||
AssertEquals('', Expected, Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: TClass);
|
||||
begin
|
||||
AssertTrue(AMessage + ' ' + 'expected: <' + Expected.ClassName + '> but was: <'
|
||||
+ Actual.ClassName + '>', Expected = Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertEquals(Expected, Actual: TClass);
|
||||
begin
|
||||
AssertEquals('', Expected, Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertSame(const AMessage: string; Expected, Actual: TObject);
|
||||
begin
|
||||
AssertTrue(AMessage + ' ' + 'expected: <' + IntToStr(PtrInt(Expected)) + '> but was: <'
|
||||
+ IntToStr(PtrInt(Actual)) + '>', Expected = Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertSame(Expected, Actual: TObject);
|
||||
begin
|
||||
AssertSame('', Expected, Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertNotSame(const AMessage: string; Expected, Actual: TObject);
|
||||
begin
|
||||
AssertFalse('expected not same', Expected = Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertNotSame(Expected, Actual: TObject);
|
||||
begin
|
||||
AssertNotSame('', Expected, Actual);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertNotNull(const AMessage: string; AObject: TObject);
|
||||
begin
|
||||
AssertTrue(AMessage, (AObject <> nil));
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertNotNull(AObject: TObject);
|
||||
begin
|
||||
AssertNotNull('', AObject);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertNull(const AMessage: string; AObject: TObject);
|
||||
begin
|
||||
AssertTrue(AMessage, (AObject = nil));
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertNull(AObject: TObject);
|
||||
begin
|
||||
AssertNull('', AObject);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertException(const AMessage: string; AExceptionClass: ExceptClass;
|
||||
AMethod: TRunMethod);
|
||||
var
|
||||
Passed : Boolean;
|
||||
ExceptionName: string;
|
||||
begin
|
||||
Passed := False;
|
||||
try
|
||||
AMethod;
|
||||
except
|
||||
on E: Exception do
|
||||
begin
|
||||
ExceptionName := E.ClassName;
|
||||
if E.ClassType.InheritsFrom(AExceptionClass) then
|
||||
begin
|
||||
Passed := AExceptionClass.ClassName = E.ClassName;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
AssertTrue(Format('Exception %s expected but %s was raised',
|
||||
[AExceptionClass.ClassName, ExceptionName])+ ': ' + AMessage, Passed);
|
||||
end;
|
||||
|
||||
class procedure TAssert.AssertException(AExceptionClass: ExceptClass;
|
||||
AMethod: TRunMethod);
|
||||
begin
|
||||
AssertException('', AExceptionClass, AMethod);
|
||||
end;
|
||||
|
||||
constructor TTestCase.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
end;
|
||||
|
||||
constructor TTestCase.CreateWithName(const AName: string);
|
||||
begin
|
||||
Create;
|
||||
FName := AName;
|
||||
end;
|
||||
|
||||
constructor TTestCase.CreateWith(const AName: string; const ATestSuiteName: string);
|
||||
begin
|
||||
Create;
|
||||
FName := AName;
|
||||
FTestSuiteName := ATestSuiteName;
|
||||
end;
|
||||
|
||||
function TTestCase.AsString: string;
|
||||
begin
|
||||
Result := TestName + '(' + ClassName + ')';
|
||||
end;
|
||||
|
||||
function TTestCase.CountTestCases: integer;
|
||||
begin
|
||||
Result := 1;
|
||||
end;
|
||||
|
||||
function TTestCase.CreateResult: TTestResult;
|
||||
begin
|
||||
Result := TTestResult.Create;
|
||||
end;
|
||||
|
||||
|
||||
function TTestCase.GetTestName: string;
|
||||
begin
|
||||
Result := FName;
|
||||
end;
|
||||
|
||||
function TTestCase.GetTestSuiteName: string;
|
||||
begin
|
||||
Result := FTestSuiteName;
|
||||
end;
|
||||
|
||||
procedure TTestCase.SetTestSuiteName(const aName: string);
|
||||
begin
|
||||
if FTestSuiteName <> aName then
|
||||
FTestSuiteName := aName;
|
||||
end;
|
||||
|
||||
procedure TTestCase.SetTestName(const Value: string);
|
||||
begin
|
||||
FName := Value;
|
||||
end;
|
||||
|
||||
function TTestCase.CreateResultAndRun: TTestResult;
|
||||
begin
|
||||
Result := CreateResult;
|
||||
Run(Result);
|
||||
end;
|
||||
|
||||
procedure TTestCase.Run(AResult: TTestResult);
|
||||
begin
|
||||
(AResult).Run(Self);
|
||||
end;
|
||||
|
||||
procedure TTestCase.RunBare;
|
||||
begin
|
||||
SetUp;
|
||||
try
|
||||
RunTest;
|
||||
finally
|
||||
TearDown;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase.RunTest;
|
||||
var
|
||||
m: TMethod;
|
||||
RunMethod: TRunMethod;
|
||||
pMethod : Pointer;
|
||||
begin
|
||||
AssertNotNull(FName);
|
||||
pMethod := Self.MethodAddress(FName);
|
||||
if (Assigned(pMethod)) then
|
||||
begin
|
||||
m.Code := pMethod;
|
||||
m.Data := self;
|
||||
RunMethod := TRunMethod(m);
|
||||
RunMethod;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Fail('Method "' + FName + '" not found');
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestCase.SetUp;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
procedure TTestCase.TearDown;
|
||||
begin
|
||||
|
||||
end;
|
||||
|
||||
constructor TTestSuite.Create(AClass: TClass; AName: string);
|
||||
begin
|
||||
Create(AClass);
|
||||
FName := AName;
|
||||
end;
|
||||
|
||||
constructor TTestSuite.Create(AClass: TClass);
|
||||
var
|
||||
ml: TStringList;
|
||||
i: integer;
|
||||
tc: TTestClass;
|
||||
begin
|
||||
Create(AClass.ClassName);
|
||||
if AClass.InheritsFrom(TTestCase) then
|
||||
begin
|
||||
tc := TTestClass(AClass);
|
||||
ml := TStringList.Create;
|
||||
try
|
||||
GetMethodList(AClass, ml);
|
||||
for i := 0 to ml.Count -1 do
|
||||
begin
|
||||
if IsTestMethod(ml.Strings[i]) then
|
||||
AddTest(tc.CreateWith(ml.Strings[i], tc.ClassName));
|
||||
end;
|
||||
finally
|
||||
ml.Free;
|
||||
end;
|
||||
end
|
||||
else
|
||||
AddTest(Warning(AClass.ClassName + ' does not inherit from TTestCase'));
|
||||
if FTests.Count = 0 then
|
||||
AddTest(Warning('No valid tests found in ' + AClass.ClassName));
|
||||
end;
|
||||
|
||||
constructor TTestSuite.Create(AClassArray: Array of TClass);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
Create;
|
||||
for i := Low(AClassArray) to High(AClassArray) do
|
||||
if Assigned(AClassArray[i]) then
|
||||
AddTest(TTestSuite.Create(AClassArray[i]));
|
||||
end;
|
||||
|
||||
constructor TTestSuite.Create(AName: string);
|
||||
begin
|
||||
Create();
|
||||
FName := AName;
|
||||
end;
|
||||
|
||||
constructor TTestSuite.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FTests := TList.Create;
|
||||
end;
|
||||
|
||||
destructor TTestSuite.Destroy;
|
||||
begin
|
||||
FreeObjects(FTests);
|
||||
FTests.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TTestSuite.GetTest(Index: integer): TTest;
|
||||
begin
|
||||
Result := TTest(FTests[Index]);
|
||||
end;
|
||||
|
||||
function TTestSuite.GetTestName: string;
|
||||
begin
|
||||
Result := FName;
|
||||
end;
|
||||
|
||||
function TTestSuite.GetTestSuiteName: string;
|
||||
begin
|
||||
Result := FTestSuiteName;
|
||||
end;
|
||||
|
||||
procedure TTestSuite.SetTestName(const Value: string);
|
||||
begin
|
||||
FName := Value;
|
||||
end;
|
||||
|
||||
procedure TTestSuite.SetTestSuiteName(const aName: string);
|
||||
begin
|
||||
if FTestSuiteName <> aName then
|
||||
FTestSuiteName := aName;
|
||||
end;
|
||||
|
||||
function TTestSuite.IsTestMethod(AMethodName: string): Boolean;
|
||||
begin
|
||||
Result := Pos('TEST', UpperCase(AMethodName))= 1;
|
||||
end;
|
||||
|
||||
function TTestSuite.CountTestCases: integer;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
Result := 0;
|
||||
for i := 0 to FTests.Count - 1 do
|
||||
begin
|
||||
Result := Result + TTest(FTests[i]).CountTestCases;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestSuite.Run(AResult: TTestResult);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i := 0 to FTests.Count - 1 do
|
||||
RunTest(TTest(FTests[i]), AResult);
|
||||
end;
|
||||
|
||||
procedure TTestSuite.RunTest(ATest: TTest; AResult: TTestResult);
|
||||
begin
|
||||
ATest.Run(AResult);
|
||||
end;
|
||||
|
||||
procedure TTestSuite.AddTest(ATest: TTestCase);
|
||||
begin
|
||||
FTests.Add(ATest);
|
||||
if ATest.TestSuiteName = '' then
|
||||
ATest.TestSuiteName := Self.TestName;
|
||||
end;
|
||||
|
||||
procedure TTestSuite.AddTest(ATestSuite: TTestSuite);
|
||||
begin
|
||||
FTests.Add(ATestSuite);
|
||||
if ATestSuite.TestSuiteName = '' then
|
||||
ATestSuite.TestSuiteName := Self.TestName;
|
||||
end;
|
||||
|
||||
procedure TTestSuite.AddTestSuiteFromClass(ATestClass: TClass);
|
||||
begin
|
||||
AddTest(TTestSuite.Create(ATestClass));
|
||||
end;
|
||||
|
||||
class function TTestSuite.Warning(const aMessage: string): TTestCase;
|
||||
var
|
||||
w: TTestWarning;
|
||||
begin
|
||||
w := TTestWarning.Create;
|
||||
w.FMessage := aMessage;
|
||||
Result := w;
|
||||
end;
|
||||
|
||||
constructor TTestResult.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FFailures := TList.Create;
|
||||
FErrors := TList.Create;
|
||||
FListeners := TList.Create;
|
||||
end;
|
||||
|
||||
destructor TTestResult.Destroy;
|
||||
begin
|
||||
FreeObjects(FFailures);
|
||||
FFailures.Free;
|
||||
FreeObjects(FErrors);
|
||||
FErrors.Free;
|
||||
FListeners.Free;
|
||||
end;
|
||||
|
||||
procedure TTestResult.ClearErrorLists;
|
||||
begin
|
||||
FreeObjects(FFailures);
|
||||
FFailures.Clear;
|
||||
FreeObjects(FErrors);
|
||||
FErrors.Clear;
|
||||
end;
|
||||
|
||||
function TTestResult.GetNumErrors: integer;
|
||||
begin
|
||||
Result := FErrors.Count;
|
||||
end;
|
||||
|
||||
function TTestResult.GetNumFailures: integer;
|
||||
begin
|
||||
Result := FFailures.Count;
|
||||
end;
|
||||
|
||||
procedure TTestResult.AddListener(AListener: ITestListener);
|
||||
begin
|
||||
FListeners.Add(pointer(AListener));
|
||||
end;
|
||||
|
||||
procedure TTestResult.RemoveListener(AListener: ITestListener);
|
||||
begin
|
||||
FListeners.Remove(pointer(AListener));
|
||||
end;
|
||||
|
||||
procedure TTestResult.AddFailure(ATest: TTest; E: EAssertionFailedError);
|
||||
var
|
||||
i: integer;
|
||||
f: TTestFailure;
|
||||
begin
|
||||
//lock mutex
|
||||
f := TTestFailure.CreateFailure(ATest, E);
|
||||
FFailures.Add(f);
|
||||
for i := 0 to FListeners.Count - 1 do
|
||||
ITestListener(FListeners[i]).AddFailure(ATest, f);
|
||||
//unlock mutex
|
||||
end;
|
||||
|
||||
procedure TTestResult.AddError(ATest: TTest; E: Exception;
|
||||
AUnitName: string; AMethodName: string; ALineNumber: longint);
|
||||
var
|
||||
i: integer;
|
||||
f: TTestFailure;
|
||||
begin
|
||||
//lock mutex
|
||||
f := TTestFailure.CreateFailure(ATest, E);
|
||||
f.SourceUnitName := AUnitName;
|
||||
f.MethodName := AMethodName;
|
||||
f.LineNumber := ALineNumber;
|
||||
FErrors.Add(f);
|
||||
for i := 0 to FListeners.Count - 1 do
|
||||
ITestListener(FListeners[i]).AddError(ATest, f);
|
||||
//unlock mutex
|
||||
end;
|
||||
|
||||
procedure TTestResult.EndTest(ATest: TTest);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i := 0 to FListeners.Count - 1 do
|
||||
ITestListener(FListeners[i]).EndTest(ATest);
|
||||
end;
|
||||
|
||||
|
||||
procedure TTestResult.Run(ATestCase: TTestCase);
|
||||
begin
|
||||
StartTest(ATestCase);
|
||||
RunProtected(ATestCase);
|
||||
EndTest(ATestCase);
|
||||
end;
|
||||
|
||||
procedure TTestResult.RunProtected(ATestCase: TTestCase);
|
||||
var
|
||||
func, source: shortstring;
|
||||
line: longint;
|
||||
begin
|
||||
func := '';
|
||||
source := '';
|
||||
line := 0;
|
||||
try
|
||||
ATestCase.RunBare;
|
||||
except
|
||||
on E: EAssertionFailedError do AddFailure(ATestCase, E);
|
||||
on E: Exception do
|
||||
begin
|
||||
{$ifdef SHOWLINEINFO}
|
||||
GetLineInfo(LongWord(ExceptAddr), func, source, line);
|
||||
{$endif}
|
||||
AddError(ATestCase, E, source, func, line);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestResult.StartTest(ATest: TTest);
|
||||
var
|
||||
count: integer;
|
||||
i: integer;
|
||||
begin
|
||||
count := ATest.CountTestCases;
|
||||
//lock mutex
|
||||
FRunTests := FRunTests + count;
|
||||
for i := 0 to FListeners.Count - 1 do
|
||||
ITestListener(FListeners[i]).StartTest(ATest);
|
||||
//unlock mutex
|
||||
end;
|
||||
|
||||
function TTestResult.WasSuccessful: boolean;
|
||||
begin
|
||||
//lock mutex
|
||||
Result := (FErrors.Count = 0) and (FFailures.Count = 0);
|
||||
//unlock mutex
|
||||
end;
|
||||
|
||||
end.
|
||||
73
fcl/fpcunit/testregistry.pp
Normal file
73
fcl/fpcunit/testregistry.pp
Normal file
@ -0,0 +1,73 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec, Michael Van Canneyt
|
||||
|
||||
Port to Free Pascal of the JUnit framework.
|
||||
|
||||
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 testregistry;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
fpcunit;
|
||||
|
||||
|
||||
procedure RegisterTest(ATestClass: TTestClass); overload;
|
||||
|
||||
procedure RegisterTests(ATests: Array of TTestClass);
|
||||
|
||||
function NumberOfRegisteredTests: longint;
|
||||
|
||||
function GetTestRegistry: TTestSuite;
|
||||
|
||||
implementation
|
||||
|
||||
var
|
||||
FTestRegistry: TTestSuite;
|
||||
|
||||
function GetTestRegistry: TTestSuite;
|
||||
begin
|
||||
if not Assigned(FTestRegistry) then
|
||||
FTestRegistry := TTestSuite.Create;
|
||||
Result := FTestRegistry;
|
||||
end;
|
||||
|
||||
procedure RegisterTest(ATestClass: TTestClass);
|
||||
begin
|
||||
GetTestRegistry.AddTestSuiteFromClass(ATestClass);
|
||||
end;
|
||||
|
||||
procedure RegisterTests(ATests: Array of TTestClass);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i := Low(ATests) to High(ATests) do
|
||||
if Assigned(ATests[i]) then
|
||||
begin
|
||||
RegisterTest(ATests[i]);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function NumberOfRegisteredTests: longint;
|
||||
begin
|
||||
Result := GetTestRegistry.CountTestCases;
|
||||
end;
|
||||
|
||||
initialization
|
||||
FTestRegistry := nil;
|
||||
finalization
|
||||
FTestRegistry.Free;
|
||||
end.
|
||||
|
||||
207
fcl/fpcunit/testreport.pp
Normal file
207
fcl/fpcunit/testreport.pp
Normal file
@ -0,0 +1,207 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec, Michael Van Canneyt
|
||||
|
||||
an example of a console test runner of FPCUnit tests.
|
||||
|
||||
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 testreport;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
classes, SysUtils, fpcunit, testutils;
|
||||
|
||||
type
|
||||
TXMLResultsWriter = class(TNoRefCountObject, ITestListener)
|
||||
public
|
||||
procedure WriteHeader;
|
||||
procedure WriteResult(aResult: TTestResult);
|
||||
{ITestListener}
|
||||
procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
|
||||
procedure AddError(ATest: TTest; AError: TTestFailure);
|
||||
procedure StartTest(ATest: TTest);
|
||||
procedure EndTest(ATest: TTest);
|
||||
end;
|
||||
|
||||
{
|
||||
TLatexResultsWriter = class(TNoRefCountObject, ITestListener)
|
||||
public
|
||||
procedure AddFailure(ATest: TTest; AFailure: TTestFailure);
|
||||
procedure AddError(ATest: TTest; AError: TTestFailure);
|
||||
procedure StartTest(ATest: TTest);
|
||||
procedure EndTest(ATest: TTest);
|
||||
end;}
|
||||
|
||||
|
||||
function TestSuiteAsXML(aSuite: TTestSuite): string;
|
||||
function TestSuiteAsLatex(aSuite:TTestSuite): string;
|
||||
function GetSuiteAsXML(aSuite: TTestSuite): string;
|
||||
function GetSuiteAsLatex(aSuite: TTestSuite): string;
|
||||
function TestResultAsXML(aTestResult: TTestResult): string;
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
procedure TXMLResultsWriter.WriteHeader;
|
||||
begin
|
||||
writeln('<testresults>');
|
||||
writeln('<testlisting>');
|
||||
end;
|
||||
|
||||
procedure TXMLResultsWriter.WriteResult(aResult: TTestResult);
|
||||
begin
|
||||
writeln('</testlisting>');
|
||||
writeln(TestResultAsXML(aResult));
|
||||
writeln('</testresults>');
|
||||
end;
|
||||
|
||||
{TXMLResultsWriter}
|
||||
procedure TXMLResultsWriter.AddFailure(ATest: TTest; AFailure: TTestFailure);
|
||||
begin
|
||||
writeln('<failure ExceptionClassName="', AFailure.ExceptionClassName, '">');
|
||||
writeln('<message>', AFailure.ExceptionMessage, '</message>');
|
||||
writeln('</failure>');
|
||||
end;
|
||||
|
||||
procedure TXMLResultsWriter.AddError(ATest: TTest; AError: TTestFailure);
|
||||
begin
|
||||
writeln('<error ExceptionClassName="', AError.ExceptionClassName, '">');
|
||||
writeln('<message>', AError.ExceptionMessage, '</message>');
|
||||
writeln('<sourceunit>', AError.SourceUnitName, '</sourceunit>');
|
||||
writeln('<methodname>', AError.MethodName, '</methodname>');
|
||||
writeln('<linenumber>', AError.LineNumber, '</linenumber>');
|
||||
writeln('</error>');
|
||||
end;
|
||||
|
||||
procedure TXMLResultsWriter.StartTest(ATest: TTest);
|
||||
begin
|
||||
writeln('<test name="' , ATest.TestSuiteName + '.' + ATest.TestName, '">');
|
||||
end;
|
||||
|
||||
procedure TXMLResultsWriter.EndTest(ATest: TTest);
|
||||
begin
|
||||
writeln('</test>');
|
||||
end;
|
||||
|
||||
|
||||
|
||||
function TestSuiteAsXML(aSuite:TTestSuite): string;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
Result := '<TestSuite name="' + ASuite.TestName + '">' + System.sLineBreak;
|
||||
for i := 0 to aSuite.Tests.Count - 1 do
|
||||
if TTest(aSuite.Tests.Items[i]) is TTestSuite then
|
||||
Result := Result + TestSuiteAsXML(TTestSuite(aSuite.Tests.Items[i]))
|
||||
else
|
||||
if TTest(aSuite.Tests.Items[i]) is TTestCase then
|
||||
Result := Result +'<test>' + TTestcase(aSuite.Tests.Items[i]).TestName + '</test>' + System.sLineBreak;
|
||||
Result := Result + '</TestSuite>' + System.sLineBreak;
|
||||
end;
|
||||
|
||||
function TestSuiteAsLatex(aSuite:TTestSuite): string;
|
||||
var
|
||||
i,j: integer;
|
||||
s: TTestSuite;
|
||||
begin
|
||||
Result := '\flushleft' + System.sLineBreak;
|
||||
for i := 0 to aSuite.Tests.Count - 1 do
|
||||
begin
|
||||
s := TTestSuite(ASuite.Tests.Items[i]);
|
||||
Result := Result + s.TestSuiteName + System.sLineBreak;
|
||||
Result := Result + '\begin{itemize}'+ System.sLineBreak;
|
||||
for j := 0 to s.Tests.Count - 1 do
|
||||
if TTest(s.Tests.Items[j]) is TTestCase then
|
||||
Result := Result + '\item[-] ' + TTestcase(s.Tests.Items[j]).TestName + System.sLineBreak;
|
||||
Result := Result +'\end{itemize}' + System.sLineBreak;
|
||||
end;
|
||||
end;
|
||||
|
||||
function GetSuiteAsXML(aSuite: TTestSuite): string;
|
||||
begin
|
||||
if aSuite <> nil then
|
||||
begin
|
||||
if aSuite.TestName = '' then
|
||||
aSuite.TestName := 'Test Suite';
|
||||
Result := TestSuiteAsXML(aSuite)
|
||||
end
|
||||
else
|
||||
Result := '';
|
||||
end;
|
||||
|
||||
function GetSuiteAsLatex(aSuite: TTestSuite): string;
|
||||
begin
|
||||
if aSuite <> nil then
|
||||
begin
|
||||
Result := '\documentclass[a4paper,12pt]{article}' + System.sLineBreak;
|
||||
Result := Result + '\usepackage{array}' + System.sLineBreak;
|
||||
Result := Result + '\usepackage{mdwlist}' + System.sLineBreak + System.sLineBreak;
|
||||
Result := Result + '\begin{document}' + System.sLineBreak + System.sLineBreak;
|
||||
if aSuite.TestName = '' then
|
||||
aSuite.TestName := 'Test Suite';
|
||||
Result := Result + TestSuiteAsLatex(aSuite);
|
||||
Result := Result + '\end{document}';
|
||||
end
|
||||
else
|
||||
Result := '';
|
||||
end;
|
||||
|
||||
function TestResultAsXML(aTestResult: TTestResult): string;
|
||||
var
|
||||
i: longint;
|
||||
f: TTestFailure;
|
||||
begin
|
||||
with aTestResult do
|
||||
begin
|
||||
Result := '<NumberOfRunnedTests>' + intToStr(RunTests) + '</NumberOfRunnedTests>' + System.sLineBreak;
|
||||
Result := Result + '<NumberOfErrors>' + intToStr(NumberOfErrors) + '</NumberOfErrors>' + System.sLineBreak;
|
||||
Result := Result + '<NumberOfFailures>' + intToStr(NumberOfFailures) + '</NumberOfFailures>';
|
||||
if NumberOfErrors <> 0 then
|
||||
begin
|
||||
Result := Result + System.sLineBreak;
|
||||
Result := Result + '<ListOfErrors>';
|
||||
for i := 0 to Errors.Count - 1 do
|
||||
begin
|
||||
Result := Result + System.sLineBreak;
|
||||
Result := Result + '<Error>' + System.sLineBreak;
|
||||
f := TTestFailure(Errors.Items[i]);
|
||||
Result := Result + ' <Message>' + f.AsString + '</Message>' + System.sLineBreak;
|
||||
Result := Result + ' <ExceptionClass>' + f.ExceptionClassName + '</ExceptionClass>' + System.sLineBreak;
|
||||
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 + '</Error>' + System.sLineBreak;
|
||||
end;
|
||||
Result := Result + '</ListOfErrors>';
|
||||
end;
|
||||
if NumberOfFailures <> 0 then
|
||||
begin
|
||||
Result := Result + System.sLineBreak;
|
||||
Result := Result + '<ListOfFailures>' + System.sLineBreak;
|
||||
for i := 0 to Failures.Count - 1 do
|
||||
begin
|
||||
Result := Result + '<Failure>' + System.sLineBreak;
|
||||
f := TTestFailure(Failures.Items[i]);
|
||||
Result := Result + ' <Message>' + f.AsString + '</Message>' + System.sLineBreak;
|
||||
Result := Result + ' <ExceptionClass>' + f.ExceptionClassName + '</ExceptionClass>' + System.sLineBreak;
|
||||
Result := Result + ' <ExceptionMessage>' + f.ExceptionMessage + '</ExceptionMessage>' + System.sLineBreak;
|
||||
Result := Result + '</Failure>' + System.sLineBreak;
|
||||
end;
|
||||
Result := Result + '</ListOfFailures>';
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
214
fcl/fpcunit/tests/asserttest.pp
Normal file
214
fcl/fpcunit/tests/asserttest.pp
Normal file
@ -0,0 +1,214 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec
|
||||
|
||||
Port to Free Pascal of the JUnit framework.
|
||||
|
||||
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 asserttest;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
fpcunit;
|
||||
|
||||
type
|
||||
|
||||
TAssertTest = class(TTestCase)
|
||||
published
|
||||
procedure TestFail;
|
||||
procedure TestAssertSame;
|
||||
procedure TestAssertSameNull;
|
||||
procedure TestAssertNotSameFailsNull;
|
||||
procedure TestAssertStringEquals;
|
||||
procedure TestNullNotSameObject;
|
||||
procedure TestAssertNull;
|
||||
procedure TestAssertNotNull;
|
||||
procedure TestAssertTrue;
|
||||
procedure TestAssertFalse;
|
||||
procedure TestAssertNotSame;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
procedure TAssertTest.TestFail;
|
||||
begin
|
||||
try
|
||||
fail('Wrong or no exception raised with fail');
|
||||
except
|
||||
on E: EAssertionfailedError do
|
||||
Exit;
|
||||
end;
|
||||
raise EAssertionFailedError.Create;
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestAssertSame;
|
||||
var
|
||||
o: TObject;
|
||||
o1: TObject;
|
||||
begin
|
||||
o := TObject.Create;
|
||||
AssertSame(o, o);
|
||||
o1 := TObject.Create;
|
||||
try
|
||||
AssertSame(o, o1);
|
||||
except
|
||||
on E: EAssertionFailedError do
|
||||
begin
|
||||
o.Free;
|
||||
o1.Free;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
o.Free;
|
||||
o1.Free;
|
||||
Fail('Wrong or no exception raised');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestAssertSameNull;
|
||||
var
|
||||
a, b: TObject;
|
||||
begin
|
||||
a := nil;
|
||||
b := nil;
|
||||
AssertSame(a, b);
|
||||
AssertSame(nil, a);
|
||||
AssertSame(a, nil);
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestAssertNotSameFailsNull;
|
||||
var
|
||||
a, b: TObject;
|
||||
begin
|
||||
a := nil;
|
||||
b := nil;
|
||||
try
|
||||
assertNotSame(a, b);
|
||||
except
|
||||
on E: EAssertionFailedError do
|
||||
Exit;
|
||||
end;
|
||||
fail('error: nil should equal nil');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestAssertStringEquals;
|
||||
begin
|
||||
AssertEquals('a', 'a')
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestNullNotSameObject;
|
||||
var
|
||||
obj: TObject;
|
||||
begin
|
||||
obj := TObject.Create;
|
||||
try
|
||||
AssertSame(nil, obj);
|
||||
except
|
||||
on E: EAssertionFailedError do
|
||||
begin
|
||||
obj.Free;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
Fail('error comparing a valid obj instance with nil');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestAssertNull;
|
||||
var
|
||||
obj: TObject;
|
||||
begin
|
||||
AssertNull(nil);
|
||||
obj := TObject.Create;
|
||||
try
|
||||
AssertNull(obj);
|
||||
except
|
||||
on E: EAssertionFailedError do
|
||||
begin
|
||||
obj.Free;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
obj.Free;
|
||||
Fail('failure: obj is not null!');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestAssertNotNull;
|
||||
var
|
||||
obj: TObject;
|
||||
begin
|
||||
obj := TObject.Create;
|
||||
AssertNotNull(obj);
|
||||
try
|
||||
AssertNotNull(nil);
|
||||
except
|
||||
on E: EAssertionFailedError do
|
||||
begin
|
||||
obj.Free;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
obj.Free;
|
||||
Fail('error: nil is not a valid object');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestAssertTrue;
|
||||
begin
|
||||
assertTrue(true);
|
||||
try
|
||||
assertTrue(false);
|
||||
except
|
||||
on E: EAssertionFailedError do
|
||||
Exit;
|
||||
end;
|
||||
fail('error asserting true');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestAssertFalse;
|
||||
begin
|
||||
assertFalse(false);
|
||||
try
|
||||
assertFalse(true);
|
||||
except
|
||||
on E: EAssertionFailedError do
|
||||
Exit;
|
||||
end;
|
||||
fail('error asserting false');
|
||||
end;
|
||||
|
||||
procedure TAssertTest.TestAssertNotSame;
|
||||
var
|
||||
obj: TObject;
|
||||
obj1: TObject;
|
||||
begin
|
||||
obj := TObject.Create;
|
||||
obj1 := TObject.Create;
|
||||
AssertNotSame(obj, nil);
|
||||
AssertNotSame(nil, obj);
|
||||
AssertNotSame(obj, obj1);
|
||||
try
|
||||
AssertNotSame(obj, obj)
|
||||
except
|
||||
on E: EAssertionFailedError do
|
||||
begin
|
||||
obj.Free;
|
||||
obj1.Free;
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
obj.Free;
|
||||
obj1.Free;
|
||||
Fail('Error: Objects are the same!');
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
138
fcl/fpcunit/tests/frameworktest.pp
Normal file
138
fcl/fpcunit/tests/frameworktest.pp
Normal file
@ -0,0 +1,138 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec, Michael Van Canneyt
|
||||
|
||||
an example of a console test runner of FPCUnit tests.
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
program frameworktest;
|
||||
|
||||
uses
|
||||
custapp, classes, SysUtils, fpcunit, testreport, asserttest, suitetest;
|
||||
|
||||
Const
|
||||
ShortOpts = 'alh';
|
||||
Longopts : Array[1..5] of String = (
|
||||
'all','list','format:','suite:','help');
|
||||
Version = 'Version 0.1';
|
||||
|
||||
Type
|
||||
TTestRunner = Class(TCustomApplication)
|
||||
private
|
||||
FSuite: TTestSuite;
|
||||
FXMLResultsWriter: TXMLResultsWriter;
|
||||
protected
|
||||
procedure DoRun ; Override;
|
||||
procedure doTestRun(aTest: TTest); virtual;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
|
||||
constructor TTestRunner.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FXMLResultsWriter := TXMLResultsWriter.Create;
|
||||
FSuite := TTestSuite.Create;
|
||||
FSuite.TestName := 'Framework test';
|
||||
FSuite.AddTestSuiteFromClass(TAssertTest);
|
||||
FSuite.AddTest(TSuiteTest.Suite());
|
||||
end;
|
||||
|
||||
destructor TTestRunner.Destroy;
|
||||
begin
|
||||
FXMLResultsWriter.Free;
|
||||
FSuite.Free;
|
||||
end;
|
||||
|
||||
procedure TTestRunner.doTestRun(aTest: TTest);
|
||||
var
|
||||
testResult: TTestResult;
|
||||
begin
|
||||
testResult := TTestResult.Create;
|
||||
try
|
||||
testResult.AddListener(FXMLResultsWriter);
|
||||
FXMLResultsWriter.WriteHeader;
|
||||
aTest.Run(testResult);
|
||||
FXMLResultsWriter.WriteResult(testResult);
|
||||
finally
|
||||
testResult.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestRunner.DoRun;
|
||||
var
|
||||
I : Integer;
|
||||
S : String;
|
||||
begin
|
||||
S:=CheckOptions(ShortOpts,LongOpts);
|
||||
If (S<>'') then
|
||||
Writeln(S);
|
||||
if HasOption('h', 'help') or (ParamCount = 0) then
|
||||
begin
|
||||
writeln(Title);
|
||||
writeln(Version);
|
||||
writeln('Usage: ');
|
||||
writeln('-l or --list to show a list of registered tests');
|
||||
writeln('default format is xml, add --format=latex to output the list as latex source');
|
||||
writeln('-a or --all to run all the tests and show the results in xml format');
|
||||
writeln('The results can be redirected to an xml file,');
|
||||
writeln('for example: ./testrunner --all > results.xml');
|
||||
writeln('use --suite=MyTestSuiteName to run only the tests in a single test suite class');
|
||||
end
|
||||
else;
|
||||
if HasOption('l', 'list') then
|
||||
begin
|
||||
if HasOption('format') then
|
||||
begin
|
||||
if GetOptionValue('format') = 'latex' then
|
||||
writeln(GetSuiteAsLatex(FSuite))
|
||||
else
|
||||
writeln(GetSuiteAsXML(FSuite));
|
||||
end
|
||||
else
|
||||
writeln(GetSuiteAsXML(FSuite));
|
||||
end;
|
||||
if HasOption('a', 'all') then
|
||||
begin
|
||||
doTestRun(FSuite)
|
||||
end
|
||||
else
|
||||
if HasOption('suite') then
|
||||
begin
|
||||
S := '';
|
||||
S:=GetOptionValue('suite');
|
||||
if S = '' then
|
||||
for I := 0 to FSuite.Tests.count - 1 do
|
||||
writeln(FSuite[i].TestName)
|
||||
else
|
||||
for I := 0 to FSuite.Tests.count - 1 do
|
||||
if FSuite[i].TestName = S then
|
||||
begin
|
||||
doTestRun(FSuite.Test[i]);
|
||||
end;
|
||||
end;
|
||||
Terminate;
|
||||
end;
|
||||
|
||||
Var
|
||||
App : TTestRunner;
|
||||
|
||||
begin
|
||||
App:=TTestRunner.Create(Nil);
|
||||
App.Initialize;
|
||||
App.Title := 'FPCUnit Console Test Case runner.';
|
||||
App.Run;
|
||||
App.Free;
|
||||
end.
|
||||
221
fcl/fpcunit/tests/suitetest.pp
Normal file
221
fcl/fpcunit/tests/suitetest.pp
Normal file
@ -0,0 +1,221 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec
|
||||
|
||||
Port to Free Pascal of the JUnit framework.
|
||||
|
||||
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 suitetest;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
fpcunit, testreport;
|
||||
|
||||
type
|
||||
|
||||
TNoTestCases = class(TTestCase)
|
||||
published
|
||||
procedure NoTestCase;
|
||||
end;
|
||||
|
||||
{$M+}
|
||||
TNoTestCaseClass = class(TObject)
|
||||
published
|
||||
procedure TestSuccess;
|
||||
end;
|
||||
{$M-}
|
||||
|
||||
TOneTestCase = class(TTestCase)
|
||||
published
|
||||
procedure NoTestCase;
|
||||
procedure TestCase; virtual;
|
||||
end;
|
||||
|
||||
TOverrideTestCase = class(TOneTestCase)
|
||||
published
|
||||
procedure TestCase; override;
|
||||
end;
|
||||
|
||||
|
||||
TInheritedTestCase = class(TOneTestCase)
|
||||
published
|
||||
procedure Test2;
|
||||
end;
|
||||
|
||||
TSuiteTest = class(TTestCase)
|
||||
private
|
||||
FResult: TTestResult;
|
||||
protected
|
||||
procedure Setup; override;
|
||||
procedure Teardown; override;
|
||||
public
|
||||
class function Suite: TTestSuite;
|
||||
published
|
||||
procedure testNoTestCaseClass;
|
||||
procedure testNoTestCases;
|
||||
procedure testOneTestCase;
|
||||
procedure testInheritedTests;
|
||||
procedure testNotExistingTestCase;
|
||||
procedure testShadowedTests;
|
||||
procedure testAddTestSuiteFromClass;
|
||||
procedure testCreateTestSuiteFromArray;
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
procedure TNoTestCases.NoTestCase;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TNoTestCaseClass.TestSuccess;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TOneTestCase.NoTestCase;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TOneTestCase.TestCase;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TOverrideTestCase.TestCase;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TInheritedTestCase.Test2;
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TSuiteTest.Setup;
|
||||
begin
|
||||
FResult := TTestResult.Create;
|
||||
end;
|
||||
|
||||
procedure TSuiteTest.Teardown;
|
||||
begin
|
||||
FResult.Free;
|
||||
end;
|
||||
|
||||
class function TSuiteTest.Suite: TTestSuite;
|
||||
begin
|
||||
Result := TTestSuite.Create('TSuiteTest');
|
||||
Result.AddTest(TSuiteTest.CreateWithName('testNoTestCaseClass'));
|
||||
Result.AddTest(TSuiteTest.CreateWithName('testNoTestCases'));
|
||||
Result.AddTest(TSuiteTest.CreateWithName('testOneTestCase'));
|
||||
Result.AddTest(TSuiteTest.CreateWithName('testInheritedTests'));
|
||||
Result.AddTest(TSuiteTest.CreateWithName('testNotExistingTestCase'));
|
||||
Result.AddTest(TSuiteTest.CreateWithName('testShadowedTests'));
|
||||
Result.AddTest(TSuiteTest.CreateWithName('testAddTestSuiteFromClass'));
|
||||
Result.AddTest(TSuiteTest.CreateWithName('testCreateTestSuiteFromArray'));
|
||||
end;
|
||||
|
||||
procedure TSuiteTest.testNoTestCaseClass;
|
||||
var
|
||||
ts: TTestSuite;
|
||||
begin
|
||||
ts := TTestSuite.Create(TNoTestCaseClass);
|
||||
ts.Run(FResult);
|
||||
ts.Free;
|
||||
AssertEquals(1, FResult.RunTests);
|
||||
AssertTrue(not FResult.WasSuccessful);
|
||||
end;
|
||||
|
||||
procedure TSuiteTest.testNoTestCases;
|
||||
var
|
||||
ts: TTestSuite;
|
||||
begin
|
||||
ts := TTestSuite.Create(TNoTestCases);
|
||||
ts.Run(FResult);
|
||||
ts.Free;
|
||||
AssertTrue(FResult.RunTests = 1);
|
||||
AssertTrue(FResult.NumberOfFailures = 1);
|
||||
AssertTrue(not FResult.WasSuccessful);
|
||||
end;
|
||||
|
||||
procedure TSuiteTest.testOneTestCase;
|
||||
var
|
||||
ts: TTestSuite;
|
||||
begin
|
||||
ts := TTestSuite.Create(TOneTestCase);
|
||||
ts.Run(FResult);
|
||||
ts.Free;
|
||||
AssertTrue(FResult.RunTests = 1);
|
||||
AssertTrue(FResult.NumberOfFailures = 0);
|
||||
AssertTrue(FResult.NumberOfErrors = 0);
|
||||
AssertTrue(FResult.WasSuccessful);
|
||||
end;
|
||||
|
||||
procedure TSuiteTest.testInheritedTests;
|
||||
var
|
||||
ts: TTestSuite;
|
||||
begin
|
||||
ts := TTestSuite.Create(TInheritedTestCase);
|
||||
ts.Run(FResult);
|
||||
ts.Free;
|
||||
AssertEquals(2, FResult.RunTests);
|
||||
AssertTrue(FResult.WasSuccessful);
|
||||
end;
|
||||
|
||||
procedure TSuiteTest.testNotExistingTestCase;
|
||||
var
|
||||
t: TTestCase;
|
||||
begin
|
||||
t := TSuiteTest.CreateWithName('notExistingMethod');
|
||||
t.Run(FResult);
|
||||
t.Free;
|
||||
AssertTrue(FResult.RunTests = 1);
|
||||
AssertTrue(FResult.NumberOfFailures = 1);
|
||||
AssertTrue(FResult.NumberOfErrors = 0);
|
||||
end;
|
||||
|
||||
procedure TSuiteTest.testShadowedTests;
|
||||
var
|
||||
ts: TTestSuite;
|
||||
begin
|
||||
ts := TTestSuite.Create(TOverrideTestCase);
|
||||
ts.Run(FResult);
|
||||
ts.Free;
|
||||
AssertEquals(1, FResult.RunTests);
|
||||
end;
|
||||
|
||||
procedure TSuiteTest.testAddTestSuiteFromClass;
|
||||
var
|
||||
ts: TTestSuite;
|
||||
begin
|
||||
ts := TTestSuite.Create;
|
||||
ts.AddTestSuiteFromClass(TOneTestCase);
|
||||
ts.Run(FResult);
|
||||
ts.Free;
|
||||
AssertEquals(1, FResult.RunTests);
|
||||
end;
|
||||
|
||||
procedure TSuiteTest.testCreateTestSuiteFromArray;
|
||||
var
|
||||
ts: TTestSuite;
|
||||
begin
|
||||
ts := TTestSuite.Create([TOneTestCase, TInheritedTestCase]);
|
||||
try
|
||||
AssertEquals(3, ts.CountTestCases);
|
||||
AssertEquals(2, ts.Tests.Count);
|
||||
AssertEquals('TOneTestCase', ts[0].TestName);
|
||||
AssertEquals('TInheritedTestCase', ts[1].TestName);
|
||||
finally
|
||||
ts.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
115
fcl/fpcunit/testutils.pp
Normal file
115
fcl/fpcunit/testutils.pp
Normal file
@ -0,0 +1,115 @@
|
||||
{$mode objfpc}
|
||||
{$h+}
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2004 by Dean Zobec
|
||||
|
||||
Port to Free Pascal of the JUnit framework.
|
||||
|
||||
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 testutils;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils;
|
||||
|
||||
type
|
||||
{$M+}
|
||||
TNoRefCountObject = class(TObject, IInterface)
|
||||
protected
|
||||
{ IInterface }
|
||||
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
|
||||
function _AddRef: Integer; stdcall;
|
||||
function _Release: Integer; stdcall;
|
||||
end;
|
||||
{$M-}
|
||||
|
||||
procedure FreeObjects(List: TList);
|
||||
procedure GetMethodList( AObject: TObject; AList: TStrings ); overload;
|
||||
procedure GetMethodList( AClass: TClass; AList: TStrings ); overload;
|
||||
|
||||
implementation
|
||||
|
||||
function TNoRefCountObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
|
||||
begin
|
||||
if GetInterface(IID, Obj) then Result := 0
|
||||
else Result := HRESULT($80004002);
|
||||
end;
|
||||
|
||||
function TNoRefCountObject._AddRef: Integer;stdcall;
|
||||
begin
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
function TNoRefCountObject._Release: Integer;stdcall;
|
||||
begin
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
// been to the dentist and suffered a lot
|
||||
// Hack Alert! see objpas.inc
|
||||
// Get a list of published methods for a given class or object
|
||||
procedure GetMethodList( AObject: TObject; AList: TStrings );
|
||||
begin
|
||||
GetMethodList( AObject.ClassType, AList );
|
||||
end;
|
||||
|
||||
procedure GetMethodList(AClass: TClass; AList: TStrings);
|
||||
type
|
||||
TMethodNameRec = packed record
|
||||
name : pshortstring;
|
||||
addr : pointer;
|
||||
end;
|
||||
|
||||
TMethodNameTable = packed record
|
||||
count : dword;
|
||||
entries : packed array[0..0] of TMethodNameRec;
|
||||
end;
|
||||
|
||||
pMethodNameTable = ^TMethodNameTable;
|
||||
|
||||
var
|
||||
methodTable : pMethodNameTable;
|
||||
i : dword;
|
||||
vmt: TClass;
|
||||
idx: integer;
|
||||
begin
|
||||
AList.Clear;
|
||||
vmt := aClass;
|
||||
while assigned(vmt) do
|
||||
begin
|
||||
methodTable := pMethodNameTable((Pointer(vmt) + vmtMethodTable)^);
|
||||
if assigned(MethodTable) then
|
||||
begin
|
||||
for i := 0 to MethodTable^.count - 1 do
|
||||
begin
|
||||
idx := aList.IndexOf(MethodTable^.entries[i].name^);
|
||||
if (idx <> - 1) then
|
||||
//found overridden method so delete it
|
||||
aList.Delete(idx);
|
||||
aList.AddObject(MethodTable^.entries[i].name^, TObject(MethodTable^.entries[i].addr));
|
||||
end;
|
||||
end;
|
||||
vmt := pClass(pointer(vmt) + vmtParent)^;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FreeObjects(List: TList);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
for i:= 0 to List.Count - 1 do
|
||||
TObject(List.Items[i]).Free;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user