mirror of
https://gitlab.com/freepascal.org/fpc/pas2js.git
synced 2025-04-05 18:17:45 +02:00
* Test generic list
This commit is contained in:
michael
parent
572897dec0
commit
796126d257
@ -84,11 +84,12 @@ type
|
||||
protected
|
||||
type
|
||||
TMyEnumerator = TEnumerator<T>;
|
||||
TMyArray = TArray<T>;
|
||||
function DoGetEnumerator: TMyEnumerator; virtual; abstract;
|
||||
public
|
||||
type
|
||||
TMyArray = TArray<T>;
|
||||
function GetEnumerator: TMyEnumerator; inline;
|
||||
function ToArray: TMyArray; virtual; overload;
|
||||
function ToArray: TMyArray; virtual;
|
||||
end;
|
||||
|
||||
{ TCustomList }
|
||||
@ -109,8 +110,6 @@ type
|
||||
procedure SetCapacity(AValue: SizeInt); virtual; abstract;
|
||||
function GetCount: SizeInt; virtual;
|
||||
public
|
||||
function ToArray: TArray<T>; override;
|
||||
|
||||
property Count: SizeInt read GetCount;
|
||||
property Capacity: SizeInt read GetCapacity write SetCapacity;
|
||||
property OnNotify: TCollectionNotifyEvent<T> read FOnNotify write FOnNotify;
|
||||
@ -152,11 +151,12 @@ type
|
||||
public
|
||||
type
|
||||
TEnumerator = class(TCustomListEnumerator<T>);
|
||||
TMyType = TList<T>;
|
||||
function GetEnumerator: TEnumerator; reintroduce;
|
||||
public
|
||||
constructor Create; overload;
|
||||
constructor Create(const AComparer: IComparer<T>); overload;
|
||||
constructor Create(ACollection: TEnumerable<T>); overload;
|
||||
constructor Create2(const AComparer: IComparer<T>); overload;
|
||||
constructor Create3(ACollection: TEnumerable<T>); overload;
|
||||
|
||||
destructor Destroy; override;
|
||||
|
||||
@ -202,6 +202,19 @@ type
|
||||
property Items[Index: SizeInt]: T read GetItem write SetItem; default;
|
||||
end;
|
||||
|
||||
|
||||
TObjectList<T: class> = class(TList<T>)
|
||||
private
|
||||
FObjectsOwner: Boolean;
|
||||
protected
|
||||
procedure Notify(const aValue: T; Action: TCollectionNotification); override;
|
||||
public
|
||||
constructor Create(aOwnsObjects: Boolean = True); overload;
|
||||
constructor Create2(const AComparer: IComparer<T>; aOwnsObjects: Boolean = True); overload;
|
||||
constructor Create3(const aCollection: TEnumerable<T>; aOwnsObjects: Boolean = True); overload;
|
||||
property OwnsObjects: Boolean read FObjectsOwner write FObjectsOwner;
|
||||
end;
|
||||
|
||||
{ TThreadList }
|
||||
// This is provided for delphi/FPC compatibility
|
||||
// No locking is done, since Javascript is single-threaded. We do keep a lock count for debugging purposes.
|
||||
@ -673,10 +686,6 @@ begin
|
||||
Result := FLength;
|
||||
end;
|
||||
|
||||
function TCustomList<T>.ToArray: TArray<T>;
|
||||
begin
|
||||
Result := ToArray;
|
||||
end;
|
||||
|
||||
{ TCustomListEnumerator }
|
||||
|
||||
@ -774,13 +783,13 @@ begin
|
||||
FComparer := TComparer<T>.Default;
|
||||
end;
|
||||
|
||||
constructor TList<T>.Create(const AComparer: IComparer<T>);
|
||||
constructor TList<T>.Create2(const AComparer: IComparer<T>);
|
||||
begin
|
||||
InitializeList;
|
||||
FComparer := AComparer;
|
||||
end;
|
||||
|
||||
constructor TList<T>.Create(ACollection: TEnumerable<T>);
|
||||
constructor TList<T>.Create3(ACollection: TEnumerable<T>);
|
||||
var
|
||||
LItem: T;
|
||||
begin
|
||||
@ -1462,11 +1471,37 @@ begin
|
||||
Result:=inherited ToArray;
|
||||
end;
|
||||
|
||||
Type
|
||||
TMyDict = TDictionary<integer,string>;
|
||||
|
||||
{ TObjectList<T> }
|
||||
|
||||
procedure TObjectList<T>.Notify(const aValue: T; Action: TCollectionNotification);
|
||||
|
||||
Var
|
||||
MyDict : TMyDict;
|
||||
A : TObject absolute aValue; // needed to fool compiler
|
||||
|
||||
begin
|
||||
inherited Notify(aValue, Action);
|
||||
if FObjectsOwner and (action = cnRemoved) then
|
||||
a.Free;
|
||||
end;
|
||||
|
||||
constructor TObjectList<T>.Create(AOwnsObjects: Boolean);
|
||||
begin
|
||||
inherited Create;
|
||||
FObjectsOwner := AOwnsObjects;
|
||||
end;
|
||||
|
||||
constructor TObjectList<T>.Create2(const AComparer: IComparer<T>; AOwnsObjects: Boolean);
|
||||
begin
|
||||
inherited Create2(AComparer);
|
||||
FObjectsOwner := AOwnsObjects;
|
||||
end;
|
||||
|
||||
constructor TObjectList<T>.Create3(const ACollection: TEnumerable<T>; aOwnsObjects: Boolean);
|
||||
begin
|
||||
inherited Create3(ACollection);
|
||||
FObjectsOwner := AOwnsObjects;
|
||||
end;
|
||||
|
||||
{ TThreadList }
|
||||
|
||||
|
||||
@ -365,7 +365,7 @@ end;
|
||||
|
||||
procedure TTestSimpleDictionary.DoKeyNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: Integer; AAction: TCollectionNotification);
|
||||
begin
|
||||
Writeln(FnotifyMessage+' Notification',FCurrentKeyNotify);
|
||||
// Writeln(FnotifyMessage+' Notification',FCurrentKeyNotify);
|
||||
AssertSame(FnotifyMessage+' Correct sender', FDict,aSender);
|
||||
if (FCurrentKeyNotify>=Length(FExpectKeys)) then
|
||||
Fail(FnotifyMessage+' Too many notificiations');
|
||||
@ -375,7 +375,7 @@ end;
|
||||
|
||||
procedure TTestSimpleDictionary.DoValueNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: String; AAction: TCollectionNotification);
|
||||
begin
|
||||
Writeln(FnotifyMessage+' value Notification',FCurrentValueNotify);
|
||||
// Writeln(FnotifyMessage+' value Notification',FCurrentValueNotify);
|
||||
AssertSame(FnotifyMessage+' value Correct sender', FDict,aSender);
|
||||
if (FCurrentValueNotify>=Length(FExpectValues)) then
|
||||
Fail(FnotifyMessage+' Too many value notificiations');
|
||||
|
||||
427
test/tcgenericlist.pp
Normal file
427
test/tcgenericlist.pp
Normal file
@ -0,0 +1,427 @@
|
||||
unit tcgenericlist;
|
||||
|
||||
{$mode objfpc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
fpcunit, testregistry, Classes, SysUtils, Generics.Defaults, Generics.Collections;
|
||||
|
||||
|
||||
Type
|
||||
TMySimpleList = Class(Specialize TList<String>);
|
||||
{$IFDEF FPC}
|
||||
EList = EListError;
|
||||
{$ENDIF}
|
||||
|
||||
{ TTestSimpleList }
|
||||
|
||||
TTestSimpleList = Class(TTestCase)
|
||||
Private
|
||||
FList : TMySimpleList;
|
||||
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(aKey: Integer; 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 List : TMySimpleList Read FList;
|
||||
Published
|
||||
Procedure TestEmpty;
|
||||
Procedure TestAdd;
|
||||
Procedure TestClear;
|
||||
Procedure TestGetValue;
|
||||
Procedure TestSetValue;
|
||||
Procedure TestContainsValue;
|
||||
Procedure TestDelete;
|
||||
Procedure TestToArray;
|
||||
Procedure TestEnumerator;
|
||||
procedure TestValueNotification;
|
||||
procedure TestValueNotificationDelete;
|
||||
procedure TestValueNotificationSet;
|
||||
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;
|
||||
|
||||
TSingleObjectList = Class(Specialize TObjectList<TMyObject>);
|
||||
|
||||
{ TTestSingleObjectList }
|
||||
|
||||
TTestSingleObjectList = Class(TTestCase)
|
||||
private
|
||||
FOList: TSingleObjectList;
|
||||
FList : TFPList;
|
||||
procedure DoAdd(aID: Integer);
|
||||
procedure DoDestroy(Sender: TObject);
|
||||
Public
|
||||
Procedure SetUp; override;
|
||||
Procedure TearDown; override;
|
||||
Property List : TSingleObjectList Read FOList;
|
||||
Published
|
||||
Procedure TestEmpty;
|
||||
Procedure TestFreeOnRemove;
|
||||
Procedure TestNoFreeOnRemove;
|
||||
Procedure TestFreeOnDelete;
|
||||
Procedure TestNoFreeDelete;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TTestSingleObjectList }
|
||||
|
||||
procedure TTestSingleObjectList.SetUp;
|
||||
begin
|
||||
FOList:=TSingleObjectList.Create(True);
|
||||
FList:=TFPList.Create;
|
||||
inherited SetUp;
|
||||
end;
|
||||
|
||||
procedure TTestSingleObjectList.TearDown;
|
||||
begin
|
||||
FreeAndNil(FList);
|
||||
FreeAndNil(FList);
|
||||
inherited TearDown;
|
||||
end;
|
||||
|
||||
procedure TTestSingleObjectList.TestEmpty;
|
||||
begin
|
||||
AssertNotNull('Have object',List);
|
||||
AssertEquals('Have empty object',0,List.Count);
|
||||
end;
|
||||
|
||||
procedure TTestSingleObjectList.DoAdd(aID : Integer);
|
||||
|
||||
Var
|
||||
O : TMyObject;
|
||||
|
||||
begin
|
||||
O:=TMyObject.Create(aID,@DoDestroy);
|
||||
FOList.Add(O);
|
||||
FList.Add(O);
|
||||
end;
|
||||
|
||||
procedure TTestSingleObjectList.DoDestroy(Sender: TObject);
|
||||
|
||||
Var
|
||||
I : Integer;
|
||||
|
||||
begin
|
||||
I:=FList.IndexOf(Sender);
|
||||
AssertTrue('Have object in list',I<>-1);
|
||||
FList.Delete(I);
|
||||
end;
|
||||
|
||||
procedure TTestSingleObjectList.TestFreeOnRemove;
|
||||
|
||||
begin
|
||||
DoAdd(1);
|
||||
AssertEquals('Have obj',1,FList.Count);
|
||||
List.Remove(TMyObject(FList[0]));
|
||||
AssertEquals('Have no obj',0,FList.Count);
|
||||
end;
|
||||
|
||||
procedure TTestSingleObjectList.TestNoFreeOnRemove;
|
||||
begin
|
||||
List.OwnsObjects:=False;
|
||||
DoAdd(1);
|
||||
AssertEquals('Have obj',1,FList.Count);
|
||||
List.Remove(TMyObject(FList[0]));
|
||||
AssertEquals('Have obj',1,FList.Count);
|
||||
end;
|
||||
|
||||
procedure TTestSingleObjectList.TestFreeOnDelete;
|
||||
begin
|
||||
DoAdd(1);
|
||||
AssertEquals('Have obj',1,FList.Count);
|
||||
List.Delete(0);
|
||||
AssertEquals('Have no obj',0,FList.Count);
|
||||
end;
|
||||
|
||||
procedure TTestSingleObjectList.TestNoFreeDelete;
|
||||
begin
|
||||
List.OwnsObjects:=False;
|
||||
DoAdd(1);
|
||||
AssertEquals('Have obj',1,FList.Count);
|
||||
List.Delete(0);
|
||||
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;
|
||||
|
||||
{ TTestSimpleList }
|
||||
|
||||
procedure TTestSimpleList.SetUp;
|
||||
begin
|
||||
inherited SetUp;
|
||||
FList:=TMySimpleList.Create;
|
||||
FCurrentValueNotify:=0;
|
||||
FExpectValues:=[];
|
||||
FExpectValueAction:=[];
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TearDown;
|
||||
begin
|
||||
// So we don't get clear messages
|
||||
FList.OnNotify:=Nil;
|
||||
FreeAndNil(FList);
|
||||
inherited TearDown;
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TestEmpty;
|
||||
begin
|
||||
AssertNotNull('Have dictionary',List);
|
||||
AssertEquals('empty dictionary',0,List.Count);
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.DoAdd(aCount : Integer; aOffset : Integer=0);
|
||||
|
||||
Var
|
||||
I : Integer;
|
||||
|
||||
begin
|
||||
if aOffset=-1 then
|
||||
aOffset:=List.Count;
|
||||
For I:=aOffset+1 to aOffset+aCount do
|
||||
List.Add(IntToStr(i));
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TestAdd;
|
||||
|
||||
begin
|
||||
DoAdd(1);
|
||||
AssertEquals('Count OK',1,List.Count);
|
||||
AssertTrue('Has added value',List.Contains('1'));
|
||||
DoAdd(1,1);
|
||||
AssertEquals('Count OK',2,List.Count);
|
||||
AssertTrue('Has added value',List.Contains('2'));
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TestClear;
|
||||
begin
|
||||
DoAdd(3);
|
||||
AssertEquals('Count OK',3,List.Count);
|
||||
List.Clear;
|
||||
AssertEquals('Count after clear OK',0,List.Count);
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.DoGetValue(aKey: Integer; Match: String; ExceptionClass: TClass);
|
||||
|
||||
Var
|
||||
EC : TClass;
|
||||
A,EM : String;
|
||||
|
||||
begin
|
||||
EC:=Nil;
|
||||
try
|
||||
A:=List.Items[aKey];
|
||||
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 for '+IntToStr(aKey),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 TTestSimpleList.DoValueNotify(ASender: TObject; {$ifdef fpc}constref{$else}const{$endif} AItem: String; AAction: TCollectionNotification);
|
||||
begin
|
||||
// Writeln(FnotifyMessage+' value Notification',FCurrentValueNotify);
|
||||
AssertSame(FnotifyMessage+' value Correct sender', FList,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 TTestSimpleList.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 TTestSimpleList.TestGetValue;
|
||||
|
||||
Var
|
||||
I : integer;
|
||||
|
||||
begin
|
||||
DoAdd(3);
|
||||
For I:=1 to 3 do
|
||||
DoGetValue(i-1,IntToStr(I));
|
||||
DoGetValue(3,'4',EArgumentOutOfRangeException);
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TestSetValue;
|
||||
begin
|
||||
TestGetValue;
|
||||
List.Items[1]:='Six';
|
||||
DoGetValue(1,'Six');
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.DoAdd2;
|
||||
|
||||
begin
|
||||
List.Add('A new 2');
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.DoneExpectValues;
|
||||
begin
|
||||
AssertEquals(FnotifyMessage+' Expected number of values seen',Length(FExpectValues),FCurrentValueNotify);
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TestContainsValue;
|
||||
|
||||
Var
|
||||
I : Integer;
|
||||
|
||||
begin
|
||||
DoAdd(3);
|
||||
For I:=1 to 3 do
|
||||
AssertTrue('Has '+IntToStr(i),List.Contains(IntToStr(i)));
|
||||
AssertFalse('Has not 4',List.Contains('4'));
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TestDelete;
|
||||
|
||||
begin
|
||||
DoAdd(3);
|
||||
List.Remove('2');
|
||||
AssertEquals('Count',2,List.Count);
|
||||
AssertFalse('Has not 2',List.Contains('2'));
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TestToArray;
|
||||
|
||||
Var
|
||||
A : specialize TArray<String>;
|
||||
|
||||
I : Integer;
|
||||
SI : String;
|
||||
|
||||
begin
|
||||
DoAdd(3);
|
||||
A:=List.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 TTestSimpleList.TestEnumerator;
|
||||
|
||||
Var
|
||||
A : String;
|
||||
I : Integer;
|
||||
SI : String;
|
||||
|
||||
begin
|
||||
DoAdd(3);
|
||||
I:=1;
|
||||
For A in List do
|
||||
begin
|
||||
SI:=IntToStr(I);
|
||||
AssertEquals('Value '+SI,SI,A);
|
||||
Inc(I);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TestValueNotification;
|
||||
begin
|
||||
List.OnNotify:=@DoValueNotify;
|
||||
SetExpectValues('Add',['1','2','3'],[cnAdded,cnAdded,cnAdded]);
|
||||
DoAdd(3);
|
||||
DoneExpectValues;
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TestValueNotificationDelete;
|
||||
begin
|
||||
DoAdd(3);
|
||||
List.OnNotify:=@DoValueNotify;
|
||||
SetExpectValues('Clear',['1','2','3'],[cnRemoved,cnRemoved,cnRemoved],{$IFDEF FPC}true{$ELSE}False{$endif});
|
||||
List.Clear;
|
||||
DoneExpectValues;
|
||||
end;
|
||||
|
||||
procedure TTestSimpleList.TestValueNotificationSet;
|
||||
begin
|
||||
DoAdd(3);
|
||||
List.OnNotify:=@DoValueNotify;
|
||||
SetExpectValues('Set',['2','Six'],[cnRemoved,cnAdded]);
|
||||
List[1]:='Six';
|
||||
DoneExpectValues;
|
||||
end;
|
||||
|
||||
begin
|
||||
RegisterTests([TTestSimpleList//, TTestSingleObjectList
|
||||
]);
|
||||
end.
|
||||
|
||||
@ -84,6 +84,10 @@
|
||||
<Filename Value="../packages/rtl/webutils.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
<Unit>
|
||||
<Filename Value="tcgenericlist.pp"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
|
||||
@ -29,7 +29,8 @@ uses
|
||||
// tcstream, tccompstreaming, simplelinkedlist, tcsyshelpers
|
||||
// tcgenarrayhelper,
|
||||
// tcstringhelp
|
||||
tcgenericdictionary,
|
||||
// tcgenericdictionary,
|
||||
tcgenericlist,
|
||||
strutils, sysutils, webutils;
|
||||
|
||||
var
|
||||
|
||||
Loading…
Reference in New Issue
Block a user