From 796126d257066d5331d81fef52ef1f7479ef5316 Mon Sep 17 00:00:00 2001 From: michael Date: Mon, 1 Jun 2020 17:11:50 +0000 Subject: [PATCH] * Test generic list --- packages/rtl/generics.collections.pas | 65 +++- test/tcgenericdictionary.pp | 4 +- test/tcgenericlist.pp | 427 ++++++++++++++++++++++++++ test/testrtl.lpi | 4 + test/testrtl.lpr | 3 +- 5 files changed, 485 insertions(+), 18 deletions(-) create mode 100644 test/tcgenericlist.pp diff --git a/packages/rtl/generics.collections.pas b/packages/rtl/generics.collections.pas index 0eaabc1..93f5f55 100644 --- a/packages/rtl/generics.collections.pas +++ b/packages/rtl/generics.collections.pas @@ -84,11 +84,12 @@ type protected type TMyEnumerator = TEnumerator; - TMyArray = TArray; function DoGetEnumerator: TMyEnumerator; virtual; abstract; public + type + TMyArray = TArray; 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; override; - property Count: SizeInt read GetCount; property Capacity: SizeInt read GetCapacity write SetCapacity; property OnNotify: TCollectionNotifyEvent read FOnNotify write FOnNotify; @@ -152,11 +151,12 @@ type public type TEnumerator = class(TCustomListEnumerator); + TMyType = TList; function GetEnumerator: TEnumerator; reintroduce; public constructor Create; overload; - constructor Create(const AComparer: IComparer); overload; - constructor Create(ACollection: TEnumerable); overload; + constructor Create2(const AComparer: IComparer); overload; + constructor Create3(ACollection: TEnumerable); overload; destructor Destroy; override; @@ -202,6 +202,19 @@ type property Items[Index: SizeInt]: T read GetItem write SetItem; default; end; + + TObjectList = class(TList) + private + FObjectsOwner: Boolean; + protected + procedure Notify(const aValue: T; Action: TCollectionNotification); override; + public + constructor Create(aOwnsObjects: Boolean = True); overload; + constructor Create2(const AComparer: IComparer; aOwnsObjects: Boolean = True); overload; + constructor Create3(const aCollection: TEnumerable; 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.ToArray: TArray; -begin - Result := ToArray; -end; { TCustomListEnumerator } @@ -774,13 +783,13 @@ begin FComparer := TComparer.Default; end; -constructor TList.Create(const AComparer: IComparer); +constructor TList.Create2(const AComparer: IComparer); begin InitializeList; FComparer := AComparer; end; -constructor TList.Create(ACollection: TEnumerable); +constructor TList.Create3(ACollection: TEnumerable); var LItem: T; begin @@ -1462,11 +1471,37 @@ begin Result:=inherited ToArray; end; -Type - TMyDict = TDictionary; + +{ TObjectList } + +procedure TObjectList.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.Create(AOwnsObjects: Boolean); +begin + inherited Create; + FObjectsOwner := AOwnsObjects; +end; + +constructor TObjectList.Create2(const AComparer: IComparer; AOwnsObjects: Boolean); +begin + inherited Create2(AComparer); + FObjectsOwner := AOwnsObjects; +end; + +constructor TObjectList.Create3(const ACollection: TEnumerable; aOwnsObjects: Boolean); +begin + inherited Create3(ACollection); + FObjectsOwner := AOwnsObjects; +end; { TThreadList } diff --git a/test/tcgenericdictionary.pp b/test/tcgenericdictionary.pp index 7ecd664..3ae4fb1 100644 --- a/test/tcgenericdictionary.pp +++ b/test/tcgenericdictionary.pp @@ -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'); diff --git a/test/tcgenericlist.pp b/test/tcgenericlist.pp new file mode 100644 index 0000000..1dbf3b3 --- /dev/null +++ b/test/tcgenericlist.pp @@ -0,0 +1,427 @@ +unit tcgenericlist; + +{$mode objfpc} + +interface + +uses + fpcunit, testregistry, Classes, SysUtils, Generics.Defaults, Generics.Collections; + + +Type + TMySimpleList = Class(Specialize TList); +{$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); + + { 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; + + 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. + diff --git a/test/testrtl.lpi b/test/testrtl.lpi index e0d3da5..bf038e6 100644 --- a/test/testrtl.lpi +++ b/test/testrtl.lpi @@ -84,6 +84,10 @@ + + + + diff --git a/test/testrtl.lpr b/test/testrtl.lpr index 635225e..454a256 100644 --- a/test/testrtl.lpr +++ b/test/testrtl.lpr @@ -29,7 +29,8 @@ uses // tcstream, tccompstreaming, simplelinkedlist, tcsyshelpers // tcgenarrayhelper, // tcstringhelp - tcgenericdictionary, +// tcgenericdictionary, + tcgenericlist, strutils, sysutils, webutils; var