* System.Imagelist for Delphi compatibility

packages/vcl-compat/fpmake.pp

@@ -46,6 +46,7 @@ begin
     T:=P.Targets.AddUnit('system.devices.pp');
     T:=P.Targets.AddUnit('system.analytics.pp');
     T:=P.Targets.AddUnit('system.ansistrings.pp');
+    T:=P.Targets.AddUnit('system.imagelist.pp');
 
 
 {$ifndef ALLPACKAGES}

packages/vcl-compat/src/system.imagelist.pp

@@ -0,0 +1,257 @@
+{$mode objfpc}
+{$h+}
+unit System.ImageList;
+
+interface
+
+{$IFDEF FPC_DOTTEDUNITS}
+uses
+  System.Classes, System.UITypes;
+{$ELSE}
+uses
+  Classes, System.UITypes;
+{$ENDIF}
+
+type
+  TImageLink = class;
+
+  { TBaseImageList }
+
+  TBaseImageList = class(TComponent)
+  private
+    FUpdateCount: Integer;
+    FList: TFPList;
+    FChanged: Boolean;
+    function GetLinkCount: Integer;
+    function GetLinks(const aIndex: Integer): TImageLink;
+    Procedure ClearList;
+  protected
+    procedure AddLink(aLink: TImageLink);
+    procedure DeleteLink(aLink: TImageLink);
+    function LinkContains(const aLink: TImageLink; const aStartIndex: Integer = -1): Boolean;
+    procedure DoChange; virtual; abstract;
+    function GetCount: Integer; virtual; abstract;
+    procedure Updated; override;
+    procedure Loaded; override;
+    property LinkCount: Integer read GetLinkCount;
+    property Links[aIndex: Integer]: TImageLink read GetLinks;
+  public
+    constructor Create(aOwner : TComponent); override;
+    destructor Destroy; override;
+    procedure Change; virtual;
+    procedure BeginUpdate;
+    procedure EndUpdate;
+    property Count: Integer read GetCount;
+  end;
+
+  { TImageLink }
+
+  TImageLink = class
+  private
+    FImages: TBaseImageList;
+    FImageIndex: TImageIndex;
+    FIgnoreIndex: Boolean;
+    FOnChange: TNotifyEvent;
+    FIgnoreImages: Boolean;
+    procedure SetImageList(aValue: TBaseImageList);
+    procedure SetImageIndex(aValue: TImageIndex);
+  public
+    constructor Create; virtual;
+    destructor Destroy; override;
+    procedure Change; virtual;
+    property Images: TBaseImageList read FImages write SetImageList;
+    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;
+    property IgnoreIndex: Boolean read FIgnoreIndex write FIgnoreIndex;
+    property IgnoreImages: Boolean read FIgnoreImages write FIgnoreImages;
+    property OnChange: TNotifyEvent read FOnChange write FOnChange;
+  end;
+
+implementation
+
+uses
+{$IFDEF FPC_DOTTEDUNITS}
+  System.SysUtils;
+{$ELSE}
+  SysUtils;
+{$ENDIF}
+
+{ TBaseImageList }
+
+function TBaseImageList.GetLinkCount: Integer;
+begin
+  Result:=FList.Count;
+end;
+
+
+function TBaseImageList.GetLinks(const aIndex: Integer): TImageLink;
+
+begin
+  Result:=TImageLink(FList[aIndex]);
+end;
+
+
+procedure TBaseImageList.AddLink(aLink: TImageLink);
+
+begin
+  if Not assigned(aLink) then
+    exit;
+  FList.Add(aLink);
+end;
+
+procedure TBaseImageList.DeleteLink(aLink: TImageLink);
+
+begin
+  if not Assigned(aLink) then
+    exit;
+  FList.Remove(aLink);
+  aLink.FImages:=Nil;
+end;
+
+
+function TBaseImageList.LinkContains(const aLink: TImageLink; const aStartIndex: Integer): Boolean;
+
+begin
+  Result:=False;
+  if (aStartIndex<0) or (aStartIndex>=LinkCount) then
+    exit;
+  Result:=FList.IndexOf(aLink)>=aStartIndex;
+end;
+
+
+procedure TBaseImageList.Updated;
+
+begin
+  inherited Updated;
+  if FChanged then
+    Change;
+end;
+
+
+procedure TBaseImageList.Loaded;
+
+begin
+  inherited Loaded;
+  if FChanged then
+     Change;
+end;
+
+
+procedure TBaseImageList.ClearList;
+
+var
+  aCount : integer;
+
+begin
+  aCount:=FList.Count-1;
+  While aCount>=0 do
+    begin
+    TImageLink(FList[aCount]).FImages:=Nil;
+    FList.Delete(aCount);
+    aCount:=FList.Count-1;
+    end;
+end;
+
+
+constructor TBaseImageList.Create(aOwner: TComponent);
+
+begin
+  inherited Create(aOwner);
+  FList:=TFPList.Create;
+end;
+
+
+destructor TBaseImageList.Destroy;
+
+begin
+  ClearList;
+  FreeAndNil(FList);
+  inherited Destroy;
+end;
+
+
+procedure TBaseImageList.Change;
+
+const
+  NoChangeStates = [csLoading,csDestroying,csUpdating];
+
+begin
+  FChanged:=True;
+  if ((ComponentState*NoChangeStates)=[]) then
+    begin
+    DoChange;
+    FChanged:=False;
+    end;
+end;
+
+
+procedure TBaseImageList.BeginUpdate;
+
+begin
+  if FUpdateCount = 0 then
+    Updating;
+  Inc(FUpdateCount);
+end;
+
+
+procedure TBaseImageList.EndUpdate;
+
+begin
+  if FUpdateCount<=0 then
+    exit;
+  Dec(FUpdateCount);
+  if FUpdateCount=0 then
+    Updated;
+end;
+
+{ TImageLink }
+
+procedure TImageLink.SetImageList(aValue: TBaseImageList);
+
+begin
+  if aValue=FImages then
+    exit;
+  if Assigned(FImages) then
+    FImages.DeleteLink(Self);
+  FImages:=aValue;
+  if Assigned(FImages) then
+    FImages.AddLink(Self);
+  if not FIgnoreImages then
+    Change;
+end;
+
+
+procedure TImageLink.SetImageIndex(aValue: TImageIndex);
+
+begin
+  if aValue=FImageIndex then
+    exit;
+  FImageIndex:=aValue;
+  If not IgnoreIndex then
+    Change;
+end;
+
+
+constructor TImageLink.Create;
+
+begin
+  FImageIndex:=-1;
+end;
+
+
+destructor TImageLink.Destroy;
+
+begin
+  Images:=Nil;
+  inherited Destroy;
+end;
+
+
+procedure TImageLink.Change;
+
+begin
+  if Assigned(FOnChange) then
+    FOnChange(FImages);
+end;
+
+
+end.

packages/vcl-compat/tests/testcompat.lpi

@@ -48,6 +48,10 @@
         <Filename Value="utcanalytics.pas"/>
         <IsPartOfProject Value="True"/>
       </Unit>
+      <Unit>
+        <Filename Value="utcimagelist.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

packages/vcl-compat/tests/testcompat.lpr

@@ -4,7 +4,7 @@ program testcompat;
 
 uses
   {$IFDEF UNIX}cwstring,{$ENDIF}
-  Classes, consoletestrunner, tcnetencoding, tciotuils, utmessagemanager, utcdevices, utcanalytics;
+  Classes, consoletestrunner, tcnetencoding, tciotuils, utmessagemanager, utcdevices, utcanalytics, utcimagelist;
 
 type
 

packages/vcl-compat/tests/utcimagelist.pas

@@ -0,0 +1,190 @@
+unit utcImagelist;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpcunit, testutils, testregistry, system.imagelist;
+
+type
+  
+  { TMyImageList }
+
+  TMyImageList = class(TBaseImageList)
+  private
+    FDidChange: Boolean;
+  protected
+    procedure DoChange; override;
+    function GetCount: Integer; override;
+    Property DidChange : Boolean Read FDidChange;
+    property LinkCount;
+    property Links;
+  end;
+
+  { TestBaseImageList }
+
+  TestBaseImageList= class(TTestCase)
+  private
+    FLink1: TImageLink;
+    FLink2: TImageLink;
+    FList1: TBaseImageList;
+    FList2: TBaseImageList;
+    FLink1Change : TObject;
+    procedure FreeLink1;
+    procedure FreeLink2;
+    procedure Link1Changed(Sender: TObject);
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+    Property List1 : TBaseImageList Read FList1;
+    Property List2 : TBaseImageList Read FList2;
+    Property Link1 : TImageLink Read FLink1;
+    Property Link2 : TImageLink Read FLink2;
+  published
+    procedure TestHookUp;
+    procedure TestSetLink;
+    procedure TestChangeLink;
+    procedure TestSetLinkIgnoreChange;
+    procedure TestFreeList;
+    procedure TestFreeLink;
+    procedure TestSetImageIndex;
+  end;
+
+implementation
+
+{ TMyImageList }
+
+procedure TMyImageList.DoChange;
+begin
+  FDidchange:=True;
+end;
+
+function TMyImageList.GetCount: Integer;
+begin
+  Result:=0;
+end;
+
+procedure TestBaseImageList.TestHookUp;
+
+begin
+  AssertNull('No change in link 1',FLink1Change);
+  AssertNotNull('Link 1',Link1);
+  AssertNotNull('Link 2',Link2);
+  AssertNotNull('List 1',List1);
+  AssertNotNull('List 2',List1);
+end;
+
+procedure TestBaseImageList.TestSetLink;
+begin
+  Link1.Images:=List1;
+  AssertSame('Assigned link 1', List1,Link1.Images);
+  AssertEquals('Count list 1', 1, TMyImageList(List1).LinkCount);
+  AssertFalse('changed list 1', TMyImageList(List1).DidChange);
+  AssertSame('Link 1 changed',List1,FLink1Change);
+  Link2.Images:=List2;
+  AssertSame('Assigned link 2', List2,Link2.Images);
+  AssertEquals('Count list 2', 1, TMyImageList(List2).LinkCount);
+  AssertFalse('changed list 2', TMyImageList(List2).DidChange);
+end;
+
+procedure TestBaseImageList.TestChangeLink;
+begin
+  Link1.Images:=List1;
+  AssertSame('Assigned link 1', List1,Link1.Images);
+  AssertEquals('Count list 1', 1, TMyImageList(List1).LinkCount);
+  AssertFalse('changed list 1', TMyImageList(List1).DidChange);
+  Link2.Images:=List2;
+  AssertSame('Assigned link 2', List2,Link2.Images);
+  AssertEquals('Count list 2', 1, TMyImageList(List2).LinkCount);
+  AssertFalse('changed list 2', TMyImageList(List2).DidChange);
+  Link2.Images:=List1;
+  AssertSame('Assigned link 1', List1,Link1.Images);
+  AssertEquals('Count list 1', 2, TMyImageList(List1).LinkCount);
+  AssertFalse('changed list 1', TMyImageList(List1).DidChange);
+  AssertEquals('Count list 2', 0, TMyImageList(List2).LinkCount);
+  AssertFalse('changed list 2', TMyImageList(List2).DidChange);
+end;
+
+procedure TestBaseImageList.TestSetLinkIgnoreChange;
+begin
+  Link1.IgnoreImages:=True;
+  Link1.Images:=List1;
+  AssertSame('Assigned link 1', List1,Link1.Images);
+  AssertEquals('Count list 1', 1, TMyImageList(List1).LinkCount);
+  AssertFalse('changed list 1', TMyImageList(List1).DidChange);
+  AssertNull('Link 1 not changed',FLink1Change);
+end;
+
+procedure TestBaseImageList.TestFreeList;
+begin
+  Link1.Images:=List1;
+  Link2.Images:=List1;
+  FreeAndNil(Flist1);
+  AssertNull('Link 1 no images',Link1.Images);
+  AssertNull('Link 2 no images',Link2.Images);
+end;
+
+procedure TestBaseImageList.TestFreeLink;
+begin
+  Link1.Images:=List1;
+  Link2.Images:=List1;
+  FreeLink1;
+  AssertEquals('Link 1 image count',1,TMyImageList(List1).LinkCount);
+end;
+
+procedure TestBaseImageList.TestSetImageIndex;
+begin
+  Link1.Images:=List1;
+  Link1.ImageIndex:=1;
+  AssertSame('Changed',List1,FLink1Change);
+  FLink1Change:=Nil;
+  Link1.ImageIndex:=1;
+  AssertNull('Not Changed',FLink1Change);
+  Link1.IgnoreIndex:=True;
+  Link1.ImageIndex:=2;
+  AssertNull('Not Changed',FLink1Change);
+end;
+
+procedure TestBaseImageList.SetUp;
+begin
+  FList1:=TMyImageList.Create(Nil);
+  FList2:=TMyImageList.Create(Nil);
+  FLink1:=TImageLink.Create;
+  FLink1.OnChange:=@Link1Changed;
+  FLink2:=TImageLink.Create;
+  FLink1Change:=Nil;
+end;
+
+procedure TestBaseImageList.FreeLink1;
+
+begin
+  FreeAndNil(FLink1);
+end;
+
+procedure TestBaseImageList.FreeLink2;
+
+begin
+  FreeAndNil(FLink2);
+end;
+
+procedure TestBaseImageList.Link1Changed(Sender: TObject);
+begin
+  FLink1Change:=Sender;
+end;
+
+procedure TestBaseImageList.TearDown;
+begin
+  FreeLink1;
+  FreeLink2;
+  FreeAndNil(FList1);
+  FreeAndNil(FList2);
+  inherited TearDown;
+end;
+
+
+initialization
+
+  RegisterTest(TestBaseImageList);
+end.
+