* Test generic list

packages/rtl/generics.collections.pas

@@ -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 Create2(const AComparer: IComparer<T>); overload;
-    constructor Create(ACollection: TEnumerable<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 }
 

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');

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<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.
+

test/testrtl.lpi

@@ -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>

test/testrtl.lpr

@@ -29,7 +29,8 @@ uses
 //  tcstream, tccompstreaming, simplelinkedlist, tcsyshelpers
 //  tcgenarrayhelper,
 //  tcstringhelp
-  tcgenericdictionary,
+//  tcgenericdictionary,
+  tcgenericlist,
   strutils, sysutils, webutils;
 
 var