paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-27 21:30:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Implement status support (Delphi DUnit compatibility)

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-02-17 15:20:21 +01:00
parent 7a29d8f54d
commit 8ee31342fe
2 changed files with 33 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
packages/fcl-fpcunit/src/consoletestrunner.pas
View File

@ -63,6 +63,7 @@ type
FSkipAddressInfo : Boolean; FSkipAddressInfo : Boolean;
FSuite: String; FSuite: String;
FRunMode : TRunMode; FRunMode : TRunMode;
procedure DoStatus(const msg: string);
protected protected
Class function StrToFormat(const S: String): TFormat; Class function StrToFormat(const S: String): TFormat;
function DefaultsFileName: String; function DefaultsFileName: String;
@ -97,10 +98,10 @@ uses inifiles, testdecorator;
{$ENDIF FPC_DOTTEDUNITS} {$ENDIF FPC_DOTTEDUNITS}
const const
ShortOpts = 'alhpsyrn'; ShortOpts = 'alhpsyrnu';
DefaultLongOpts: array[1..11] of string = DefaultLongOpts: array[1..12] of string =
('all', 'list', 'progress', 'help', 'skiptiming', ('all', 'list', 'progress', 'help', 'skiptiming',
'suite:', 'format:', 'file:', 'stylesheet:','sparse','no-addresses'); 'suite:', 'format:', 'file:', 'stylesheet:','sparse','no-addresses','status');
Type Type
TTestDecoratorClass = Class of TTestDecorator; TTestDecoratorClass = Class of TTestDecorator;
@ -242,6 +243,11 @@ begin
inherited Destroy; inherited Destroy;
end; end;
procedure TTestRunner.DoStatus(const msg: string);
begin
Writeln(stderr,msg);
end;
class function TTestRunner.StrToFormat(const S: String): TFormat; class function TTestRunner.StrToFormat(const S: String): TFormat;
begin begin
@ -342,6 +348,7 @@ begin
writeln(' -l or --list show a list of registered tests'); writeln(' -l or --list show a list of registered tests');
writeln(' -a or --all run all tests'); writeln(' -a or --all run all tests');
writeln(' -p or --progress show progress'); writeln(' -p or --progress show progress');
writeln(' -u or --status show status messages on stderr');
writeln(' -s or --suite=MyTestSuiteName run single test suite class'); writeln(' -s or --suite=MyTestSuiteName run single test suite class');
WriteCustomHelp; WriteCustomHelp;
writeln; writeln;
@ -422,6 +429,8 @@ begin
FSparse:=True; FSparse:=True;
If HasOption('n','no-addresses') then If HasOption('n','no-addresses') then
FSkipAddressInfo:=True; FSkipAddressInfo:=True;
If HasOption('u','status') then
TAssert.StatusEvent:=@DoStatus;
// Determine runmode // Determine runmode
if HasOption('s','suite') then if HasOption('s','suite') then
begin begin

21
packages/fcl-fpcunit/src/fpcunit.pp
View File

@ -100,6 +100,14 @@ type
protected protected
Class var AssertCount : Integer; Class var AssertCount : Integer;
public public
type
TStatusHook = Procedure(const msg : string);
TStatusEvent = Procedure(const msg : string) of object;
class var StatusHook : TStatusHook;
class var StatusEvent : TStatusEvent;
public
class procedure Status(const aMsg: String); inline;
class procedure Status(const aMsg: String; const aArgs: array of const); inline;
class procedure Fail(const AMessage: string; AErrorAddrs: Pointer = nil); class procedure Fail(const AMessage: string; AErrorAddrs: Pointer = nil);
class procedure Fail(const AFmt: string; Args : Array of const; AErrorAddrs: Pointer = nil); class procedure Fail(const AFmt: string; Args : Array of const; AErrorAddrs: Pointer = nil);
class procedure FailEquals(const expected, actual: string; const ErrorMsg: string = ''; AErrorAddrs: Pointer = nil); class procedure FailEquals(const expected, actual: string; const ErrorMsg: string = ''; AErrorAddrs: Pointer = nil);
@ -647,6 +655,19 @@ end;
{ TAssert } { TAssert }
class procedure TAssert.Status(const aMsg: String);
begin
If Assigned(StatusHook) then
StatusHook(aMsg);
if Assigned(StatusEvent) then
StatusEvent(aMsg);
end;
class procedure TAssert.Status(const aMsg: String; const aArgs: array of const);
begin
Status(SafeFormat(aMsg,aArgs));
end;
class procedure TAssert.Fail(const AMessage: string; AErrorAddrs: Pointer); class procedure TAssert.Fail(const AMessage: string; AErrorAddrs: Pointer);
begin begin
Inc(AssertCount); Inc(AssertCount);