paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 07:47:59 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Tests for Stack/Queue comparison with pas2js

Browse Source 
git-svn-id: trunk@45610 -
This commit is contained in:
michael 2020-06-07 15:37:49 +00:00
parent 95f94bebba
commit 816ff7966b
5 changed files with 804 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -8867,7 +8867,9 @@ packages/rtl-generics/tests/tests.generics.arrayhelper.pas svneol=native#text/pa
packages/rtl-generics/tests/tests.generics.bugs.pas svneol=native#text/pascal
packages/rtl-generics/tests/tests.generics.dictionary.pas svneol=native#text/plain
packages/rtl-generics/tests/tests.generics.hashmaps.pas svneol=native#text/pascal
packages/rtl-generics/tests/tests.generics.queue.pas svneol=native#text/plain
packages/rtl-generics/tests/tests.generics.sets.pas svneol=native#text/pascal
packages/rtl-generics/tests/tests.generics.stack.pas svneol=native#text/plain
packages/rtl-generics/tests/tests.generics.stdcollections.pas svneol=native#text/pascal
packages/rtl-generics/tests/tests.generics.trees.pas svneol=native#text/pascal
packages/rtl-generics/tests/tests.generics.utils.pas svneol=native#text/pascal

10
packages/rtl-generics/tests/testrunner.rtlgenerics.lpi
View File

@ -27,7 +27,7 @@
<CommandLineParams Value="-a --format=plain"/>
</local>
</RunParams>
<Units Count="8">
<Units Count="10">
<Unit0>
<Filename Value="testrunner.rtlgenerics.pp"/>
<IsPartOfProject Value="True"/>
@ -60,6 +60,14 @@
<Filename Value="tests.generics.dictionary.pas"/>
<IsPartOfProject Value="True"/>
</Unit7>
<Unit8>
<Filename Value="tests.generics.stack.pas"/>
<IsPartOfProject Value="True"/>
</Unit9>
<Unit9>
<Filename Value="tests.generics.queue.pas"/>
<IsPartOfProject Value="True"/>
</Unit9>
</Units>
</ProjectOptions>
<CompilerOptions>

2
packages/rtl-generics/tests/testrunner.rtlgenerics.pp
View File

@ -13,6 +13,8 @@ uses
tests.generics.trees,
tests.generics.stdcollections,
tests.generics.sets,
tests.generics.queue,
tests.generics.stack,
tests.generics.dictionary
;

388
packages/rtl-generics/tests/tests.generics.queue.pas Normal file
View File

@ -0,0 +1,388 @@
unit tests.generics.queue;
{$mode objfpc}
interface
uses
fpcunit, testregistry, Classes, SysUtils, Generics.Defaults, Generics.Collections;
Type
TMySimpleQueue = Class(Specialize TQueue<String>);
{$IFDEF FPC}
EList = EListError;
{$ENDIF}
{ TTestSimpleQueue }
TTestSimpleQueue = Class(TTestCase)
Private
FQueue : TMySimpleQueue;
FnotifyMessage : String;
FCurrentValueNotify : Integer;
FExpectValues : Array of String;
FExpectValueAction: Array of TCollectionNotification;
procedure DoAdd(aCount: Integer; aOffset: Integer=0);
procedure DoAdd2;
Procedure DoneExpectValues;
procedure DoGetValue(Match: String; ExceptionClass: TClass=nil);
procedure DoValueNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: String; AAction: TCollectionNotification);
Public
Procedure SetExpectValues(aMessage : string; AKeys : Array of String; AActions : Array of TCollectionNotification; DoReverse : Boolean = False);
Procedure SetUp; override;
Procedure TearDown; override;
Property Queue : TMySimpleQueue Read FQueue;
Published
Procedure TestEmpty;
Procedure TestAdd;
Procedure TestClear;
Procedure TestGetValue;
Procedure TestPeek;
Procedure TestDequeue;
Procedure TestToArray;
Procedure TestEnumerator;
procedure TestValueNotification;
procedure TestValueNotificationDelete;
end;
{ TMyObject }
TMyObject = Class(TObject)
Private
fOnDestroy : TNotifyEvent;
FID : Integer;
public
Constructor Create(aID : Integer; aOnDestroy : TNotifyEvent);
destructor destroy; override;
Property ID : Integer Read FID;
end;
TSingleObjectQueue = Class(Specialize TObjectQueue<TMyObject>);
{ TTestSingleObjectQueue }
TTestSingleObjectQueue = Class(TTestCase)
private
FOQueue: TSingleObjectQueue;
FList : TFPList;
procedure DoAdd(aID: Integer);
procedure DoDestroy(Sender: TObject);
Public
Procedure SetUp; override;
Procedure TearDown; override;
Property Queue : TSingleObjectQueue Read FOQueue;
Published
Procedure TestEmpty;
Procedure TestFreeOnDequeue;
Procedure TestNoFreeOnDeQueue;
end;
implementation
{ TTestSingleObjectQueue }
procedure TTestSingleObjectQueue.SetUp;
begin
FOQueue:=TSingleObjectQueue.Create(True);
FList:=TFPList.Create;
inherited SetUp;
end;
procedure TTestSingleObjectQueue.TearDown;
begin
FreeAndNil(FOQueue);
FreeAndNil(FList);
inherited TearDown;
end;
procedure TTestSingleObjectQueue.TestEmpty;
begin
AssertNotNull('Have object',Queue);
AssertEquals('Have empty object',0,Queue.Count);
end;
procedure TTestSingleObjectQueue.DoAdd(aID : Integer);
Var
O : TMyObject;
begin
O:=TMyObject.Create(aID,@DoDestroy);
FOQueue.EnQueue(O);
FList.Add(O);
end;
procedure TTestSingleObjectQueue.DoDestroy(Sender: TObject);
Var
I : Integer;
begin
I:=FList.IndexOf(Sender);
AssertTrue('Have object in Queue',I<>-1);
FList.Delete(I);
end;
procedure TTestSingleObjectQueue.TestFreeOnDeQueue;
begin
DoAdd(1);
AssertEquals('Have obj',1,FList.Count);
Queue.Dequeue;
AssertEquals('Have no obj',0,FList.Count);
end;
procedure TTestSingleObjectQueue.TestNoFreeOnDeQueue;
begin
Queue.OwnsObjects:=False;
DoAdd(1);
AssertEquals('Have obj',1,FList.Count);
Queue.DeQueue;
AssertEquals('Have obj',1,FList.Count);
end;
{ TMyObject }
constructor TMyObject.Create(aID: Integer; aOnDestroy: TNotifyEvent);
begin
FOnDestroy:=aOnDestroy;
FID:=AID;
end;
destructor TMyObject.destroy;
begin
if Assigned(FOnDestroy) then
FOnDestroy(Self);
inherited destroy;
end;
{ TTestSimpleQueue }
procedure TTestSimpleQueue.SetUp;
begin
inherited SetUp;
FQueue:=TMySimpleQueue.Create;
FCurrentValueNotify:=0;
FExpectValues:=[];
FExpectValueAction:=[];
end;
procedure TTestSimpleQueue.TearDown;
begin
// So we don't get clear messages
FQueue.OnNotify:=Nil;
FreeAndNil(FQueue);
inherited TearDown;
end;
procedure TTestSimpleQueue.TestEmpty;
begin
AssertNotNull('Have dictionary',Queue);
AssertEquals('empty dictionary',0,Queue.Count);
end;
procedure TTestSimpleQueue.DoAdd(aCount : Integer; aOffset : Integer=0);
Var
I : Integer;
begin
if aOffset=-1 then
aOffset:=Queue.Count;
For I:=aOffset+1 to aOffset+aCount do
Queue.EnQueue(IntToStr(i));
end;
procedure TTestSimpleQueue.TestAdd;
begin
DoAdd(1);
AssertEquals('Count OK',1,Queue.Count);
DoAdd(1,1);
AssertEquals('Count OK',2,Queue.Count);
end;
procedure TTestSimpleQueue.TestClear;
begin
DoAdd(3);
AssertEquals('Count OK',3,Queue.Count);
Queue.Clear;
AssertEquals('Count after clear OK',0,Queue.Count);
end;
procedure TTestSimpleQueue.DoGetValue(Match: String; ExceptionClass: TClass);
Var
EC : TClass;
A,EM : String;
begin
EC:=Nil;
try
A:=Queue.DeQueue;
except
On E : Exception do
begin
EC:=E.ClassType;
EM:=E.Message;
end
end;
if ExceptionClass=Nil then
begin
if EC<>Nil then
Fail('Got exception '+EC.ClassName+' with message: '+EM);
AssertEquals('Value is correct',Match,A)
end
else
begin
if EC=Nil then
Fail('Expected exception '+ExceptionClass.ClassName+' but got none');
if EC<>ExceptionClass then
Fail('Expected exception class '+ExceptionClass.ClassName+' but got '+EC.ClassName+' with message '+EM);
end;
end;
procedure TTestSimpleQueue.DoValueNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: String; AAction: TCollectionNotification);
begin
// Writeln(FnotifyMessage+' value Notification',FCurrentValueNotify);
AssertSame(FnotifyMessage+' value Correct sender', FQueue,aSender);
if (FCurrentValueNotify>=Length(FExpectValues)) then
Fail(FnotifyMessage+' Too many value notificiations');
AssertEquals(FnotifyMessage+' Notification value no '+IntToStr(FCurrentValueNotify),FExpectValues[FCurrentValueNotify],aItem);
Inc(FCurrentValueNotify);
end;
procedure TTestSimpleQueue.SetExpectValues(aMessage: string; AKeys: array of String;
AActions: array of TCollectionNotification; DoReverse: Boolean);
Var
I,L : integer;
begin
FnotifyMessage:=aMessage;
FCurrentValueNotify:=0;
L:=Length(aKeys);
AssertEquals('SetExpectValues: Lengths arrays equal',l,Length(aActions));
SetLength(FExpectValues,L);
SetLength(FExpectValueAction,L);
Dec(L);
if DoReverse then
For I:=0 to L do
begin
FExpectValues[L-i]:=AKeys[i];
FExpectValueAction[L-i]:=AActions[I];
end
else
For I:=0 to L do
begin
FExpectValues[i]:=AKeys[i];
FExpectValueAction[i]:=AActions[I];
end;
end;
procedure TTestSimpleQueue.TestGetValue;
Var
I : integer;
begin
DoAdd(3);
For I:=1 to 3 do
DoGetValue(IntToStr(I));
DoGetValue('4',EArgumentOutOfRangeException);
end;
procedure TTestSimpleQueue.TestPeek;
Var
I : integer;
begin
DoAdd(3);
For I:=1 to 3 do
begin
AssertEquals('Peek ',IntToStr(I),FQueue.Peek);
DoGetValue(IntToStr(I));
end;
end;
procedure TTestSimpleQueue.DoAdd2;
begin
Queue.Enqueue('A new 2');
end;
procedure TTestSimpleQueue.DoneExpectValues;
begin
AssertEquals(FnotifyMessage+' Expected number of values seen',Length(FExpectValues),FCurrentValueNotify);
end;
procedure TTestSimpleQueue.TestDequeue;
begin
DoAdd(3);
AssertEquals('1',Queue.Dequeue);
AssertEquals('Count',2,Queue.Count);
end;
procedure TTestSimpleQueue.TestToArray;
Var
A : specialize TArray<String>;
I : Integer;
SI : String;
begin
DoAdd(3);
A:=Queue.ToArray;
AssertEquals('Length Ok',3,Length(A));
For I:=1 to 3 do
begin
SI:=IntToStr(I);
AssertEquals('Value '+SI,SI,A[i-1]);
end;
end;
procedure TTestSimpleQueue.TestEnumerator;
Var
A : String;
I : Integer;
SI : String;
begin
DoAdd(3);
I:=1;
For A in Queue do
begin
SI:=IntToStr(I);
AssertEquals('Value '+SI,SI,A);
Inc(I);
end;
end;
procedure TTestSimpleQueue.TestValueNotification;
begin
Queue.OnNotify:=@DoValueNotify;
SetExpectValues('Add',['1','2','3'],[cnAdded,cnAdded,cnAdded]);
DoAdd(3);
DoneExpectValues;
end;
procedure TTestSimpleQueue.TestValueNotificationDelete;
begin
DoAdd(3);
Queue.OnNotify:=@DoValueNotify;
SetExpectValues('Clear',['1','2','3'],[cnRemoved,cnRemoved,cnRemoved],{$IFDEF FPC}true{$ELSE}False{$endif});
Queue.Clear;
DoneExpectValues;
end;
begin
RegisterTests([ TTestSimpleQueue,TTestSingleObjectQueue]);
end.

403
packages/rtl-generics/tests/tests.generics.stack.pas Normal file
View File

@ -0,0 +1,403 @@
unit tests.generics.stack;
{$mode objfpc}
interface
uses
fpcunit, testregistry, Classes, SysUtils, Generics.Defaults, Generics.Collections;
Type
TMySimpleStack = Class(Specialize TStack<String>);
{$IFDEF FPC}
EList = EListError;
{$ENDIF}
{ TTestSimpleStack }
TTestSimpleStack = Class(TTestCase)
Private
FStack : TMySimpleStack;
FnotifyMessage : String;
FCurrentValueNotify : Integer;
FExpectValues : Array of String;
FExpectValueAction: Array of TCollectionNotification;
procedure DoAdd(aCount: Integer);
procedure DoAdd2;
Procedure DoneExpectValues;
procedure DoGetValue(Match: String; ExceptionClass: TClass=nil);
procedure DoValueNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: String; AAction: TCollectionNotification);
Public
Procedure SetExpectValues(aMessage : string; AKeys : Array of String; AActions : Array of TCollectionNotification; DoReverse : Boolean = False);
Procedure SetUp; override;
Procedure TearDown; override;
Property Stack : TMySimpleStack Read FStack;
Published
Procedure TestEmpty;
Procedure TestAdd;
Procedure TestClear;
Procedure TestGetValue;
Procedure TestPeek;
Procedure TestPop;
Procedure TestToArray;
Procedure TestEnumerator;
procedure TestValueNotification;
procedure TestValueNotificationDelete;
end;
{ TMyObject }
TMyObject = Class(TObject)
Private
fOnDestroy : TNotifyEvent;
FID : Integer;
public
Constructor Create(aID : Integer; aOnDestroy : TNotifyEvent);
destructor destroy; override;
Property ID : Integer Read FID;
end;
TSingleObjectStack = Class(Specialize TObjectStack<TMyObject>);
{ TTestSingleObjectStack }
TTestSingleObjectStack = Class(TTestCase)
private
FOStack: TSingleObjectStack;
FList : TFPList;
procedure DoAdd(aID: Integer);
procedure DoDestroy(Sender: TObject);
Public
Procedure SetUp; override;
Procedure TearDown; override;
Property Stack : TSingleObjectStack Read FOStack;
Published
Procedure TestEmpty;
Procedure TestFreeOnPop;
Procedure TestNoFreeOnPop;
end;
implementation
{ TTestSingleObjectStack }
procedure TTestSingleObjectStack.SetUp;
begin
FOStack:=TSingleObjectStack.Create(True);
FList:=TFPList.Create;
inherited SetUp;
end;
procedure TTestSingleObjectStack.TearDown;
Var
I : integer;
A : TObject;
begin
FreeAndNil(FOStack);
for I:=0 to FList.Count-1 do
begin
A:=TObject(FList[i]);
A.Free;
end;
FreeAndNil(FList);
inherited TearDown;
end;
procedure TTestSingleObjectStack.TestEmpty;
begin
AssertNotNull('Have object',Stack);
AssertEquals('Have empty object',0,Stack.Count);
end;
procedure TTestSingleObjectStack.DoAdd(aID : Integer);
Var
O : TMyObject;
begin
O:=TMyObject.Create(aID,@DoDestroy);
FOStack.Push(O);
FList.Add(O);
end;
procedure TTestSingleObjectStack.DoDestroy(Sender: TObject);
Var
I : Integer;
begin
I:=FList.IndexOf(Sender);
AssertTrue('Have object in Stack',I<>-1);
FList.Delete(I);
end;
procedure TTestSingleObjectStack.TestFreeOnPop;
begin
DoAdd(1);
AssertEquals('Have obj',1,FList.Count);
Stack.Pop;
AssertEquals('Have no obj',0,FList.Count);
end;
procedure TTestSingleObjectStack.TestNoFreeOnPop;
begin
Stack.OwnsObjects:=False;
DoAdd(1);
AssertEquals('Have obj',1,FList.Count);
Stack.Pop;
AssertEquals('Have obj',1,FList.Count);
end;
{ TMyObject }
constructor TMyObject.Create(aID: Integer; aOnDestroy: TNotifyEvent);
begin
FOnDestroy:=aOnDestroy;
FID:=AID;
end;
destructor TMyObject.destroy;
begin
if Assigned(FOnDestroy) then
FOnDestroy(Self);
inherited destroy;
end;
{ TTestSimpleStack }
procedure TTestSimpleStack.SetUp;
begin
inherited SetUp;
FStack:=TMySimpleStack.Create;
FCurrentValueNotify:=0;
FExpectValues:=[];
FExpectValueAction:=[];
end;
procedure TTestSimpleStack.TearDown;
begin
// So we don't get clear messages
FStack.OnNotify:=Nil;
FreeAndNil(FStack);
inherited TearDown;
end;
procedure TTestSimpleStack.TestEmpty;
begin
AssertNotNull('Have dictionary',Stack);
AssertEquals('empty dictionary',0,Stack.Count);
end;
procedure TTestSimpleStack.DoAdd(aCount : Integer);
Var
I : Integer;
begin
For I:=1 to aCount do
Stack.Push(IntToStr(i));
end;
procedure TTestSimpleStack.TestAdd;
begin
DoAdd(1);
AssertEquals('Count OK',1,Stack.Count);
DoAdd(1);
AssertEquals('Count OK',2,Stack.Count);
end;
procedure TTestSimpleStack.TestClear;
begin
DoAdd(3);
AssertEquals('Count OK',3,Stack.Count);
Stack.Clear;
AssertEquals('Count after clear OK',0,Stack.Count);
end;
procedure TTestSimpleStack.DoGetValue(Match: String; ExceptionClass: TClass);
Var
EC : TClass;
A,EM : String;
begin
EC:=Nil;
try
A:=Stack.Pop;
except
On E : Exception do
begin
EC:=E.ClassType;
EM:=E.Message;
end
end;
if ExceptionClass=Nil then
begin
if EC<>Nil then
Fail('Got exception '+EC.ClassName+' with message: '+EM);
AssertEquals('Value is correct',Match,A)
end
else
begin
if EC=Nil then
Fail('Expected exception '+ExceptionClass.ClassName+' but got none');
if EC<>ExceptionClass then
Fail('Expected exception class '+ExceptionClass.ClassName+' but got '+EC.ClassName+' with message '+EM);
end;
end;
procedure TTestSimpleStack.DoValueNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: String; AAction: TCollectionNotification);
begin
// Writeln(FnotifyMessage+' value Notification',FCurrentValueNotify);
AssertSame(FnotifyMessage+' value Correct sender', FStack,aSender);
if (FCurrentValueNotify>=Length(FExpectValues)) then
Fail(FnotifyMessage+' Too many value notificiations');
AssertEquals(FnotifyMessage+' Notification value no '+IntToStr(FCurrentValueNotify),FExpectValues[FCurrentValueNotify],aItem);
Inc(FCurrentValueNotify);
end;
procedure TTestSimpleStack.SetExpectValues(aMessage: string; AKeys: array of String;
AActions: array of TCollectionNotification; DoReverse: Boolean);
Var
I,L : integer;
begin
FnotifyMessage:=aMessage;
FCurrentValueNotify:=0;
L:=Length(aKeys);
AssertEquals('SetExpectValues: Lengths arrays equal',l,Length(aActions));
SetLength(FExpectValues,L);
SetLength(FExpectValueAction,L);
Dec(L);
if DoReverse then
For I:=0 to L do
begin
FExpectValues[L-i]:=AKeys[i];
FExpectValueAction[L-i]:=AActions[I];
end
else
For I:=0 to L do
begin
FExpectValues[i]:=AKeys[i];
FExpectValueAction[i]:=AActions[I];
end;
end;
procedure TTestSimpleStack.TestGetValue;
Var
I : integer;
begin
DoAdd(3);
For I:=3 downto 1 do
DoGetValue(IntToStr(I));
DoGetValue('4',EArgumentOutOfRangeException);
end;
procedure TTestSimpleStack.TestPeek;
Var
I : integer;
begin
DoAdd(3);
For I:=3 downto 1 do
begin
AssertEquals('Peek ',IntToStr(I),FStack.Peek);
DoGetValue(IntToStr(I));
end;
end;
procedure TTestSimpleStack.DoAdd2;
begin
Stack.Push('A new 2');
end;
procedure TTestSimpleStack.DoneExpectValues;
begin
AssertEquals(FnotifyMessage+' Expected number of values seen',Length(FExpectValues),FCurrentValueNotify);
end;
procedure TTestSimpleStack.TestPop;
Var
I : Integer;
SI : String;
begin
DoAdd(3);
For I:=3 downto 1 do
begin
SI:=IntToStr(I);
AssertEquals('Value '+SI,SI,FStack.Pop);
end;
AssertEquals('Count',0,Stack.Count);
end;
procedure TTestSimpleStack.TestToArray;
Var
A : specialize TArray<String>;
I : Integer;
SI : String;
begin
DoAdd(3);
A:=Stack.ToArray;
AssertEquals('Length Ok',3,Length(A));
For I:=1 to 3 do
begin
SI:=IntToStr(I);
AssertEquals('Value '+SI,SI,A[i-1]);
end;
end;
procedure TTestSimpleStack.TestEnumerator;
Var
A : String;
I : Integer;
SI : String;
begin
DoAdd(3);
I:=1;
For A in Stack do
begin
SI:=IntToStr(i);
AssertEquals('Value '+SI,SI,A);
Inc(I);
end;
end;
procedure TTestSimpleStack.TestValueNotification;
begin
Stack.OnNotify:=@DoValueNotify;
SetExpectValues('Add',['1','2','3'],[cnAdded,cnAdded,cnAdded]);
DoAdd(3);
DoneExpectValues;
end;
procedure TTestSimpleStack.TestValueNotificationDelete;
begin
DoAdd(3);
Stack.OnNotify:=@DoValueNotify;
SetExpectValues('Clear',['3','2','1'],[cnRemoved,cnRemoved,cnRemoved],False);
Stack.Clear;
DoneExpectValues;
end;
begin
RegisterTests([ TTestSimpleStack,TTestSingleObjectStack]);
end.