{
 *****************************************************************************
 *                                                                           *
 *  This file is part of the Lazarus Component Library (LCL)                 *
 *                                                                           *
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,    *
 *  for details about the copyright.                                         *
 *                                                                           *
 *  This program is distributed in the hope that it will be useful,          *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
 *                                                                           *
 *****************************************************************************

  Author: Mattias Gaertner
  
  Abstract:
    Types and methods to cache interface resources.
    See graphics.pp for examples.
}
unit LCLResCache;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FPCAdds, Types, LCLType, LCLProc, AvgLvlTree, WSReferences;
  
{off $DEFINE CheckResCacheConsistency}

type
  TResourceCache = class;
  TResourceCacheDescriptor = class;

  { TResourceCacheItem }

  TResourceCacheItem = class
  protected
    FDestroying: boolean;
    FReferenceCount: integer;
  public
    Handle: TLCLHandle;
    Cache: TResourceCache;
    FirstDescriptor, LastDescriptor: TResourceCacheDescriptor;
    Next, Prev: TResourceCacheItem;
    constructor Create(TheCache: TResourceCache; TheHandle: TLCLHandle);
    destructor Destroy; override;
    procedure IncreaseRefCount;
    procedure DecreaseRefCount;
    procedure AddToList(var First, Last: TResourceCacheItem);
    procedure RemoveFromList(var First, Last: TResourceCacheItem);
    procedure WarnReferenceHigh; virtual;
  public
    property ReferenceCount: integer read FReferenceCount;
  end;
  TResourceCacheItemClass = class of TResourceCacheItem;


  { TResourceCacheDescriptor }

  TResourceCacheDescriptor = class
  protected
    FDestroying: boolean;
  public
    Item: TResourceCacheItem;
    Cache: TResourceCache;
    Next, Prev: TResourceCacheDescriptor;
    constructor Create(TheCache: TResourceCache; TheItem: TResourceCacheItem);
    destructor Destroy; override;
    procedure AddToList(var First, Last: TResourceCacheDescriptor);
    procedure RemoveFromList(var First, Last: TResourceCacheDescriptor);
  end;
  TResourceCacheDescriptorClass = class of TResourceCacheDescriptor;


  { TResourceCache }

  TResourceCache = class
  protected
    FItems: TAvgLvlTree;
    FDescriptors: TAvgLvlTree;
    FDestroying: boolean;
    FResourceCacheDescriptorClass: TResourceCacheDescriptorClass;
    FResourceCacheItemClass: TResourceCacheItemClass;
    FMaxUnusedItem: integer; // how many freed resources to keep
    FFirstUnusedItem, FLastUnusedItem: TResourceCacheItem;
    FUnUsedItemCount: integer;
    procedure RemoveItem(Item: TResourceCacheItem); virtual;
    procedure RemoveDescriptor(Desc: TResourceCacheDescriptor); virtual;
    procedure ItemUsed(Item: TResourceCacheItem);
    procedure ItemUnused(Item: TResourceCacheItem);
    function ItemIsUsed(Item: TResourceCacheItem): boolean;
  public
    constructor Create;
    procedure Clear;
    destructor Destroy; override;
    function CompareItems(Tree: TAvgLvlTree; Item1, Item2: Pointer): integer; virtual;
    function CompareDescriptors(Tree: TAvgLvlTree; Desc1, Desc2: Pointer): integer; virtual; abstract;
    procedure ConsistencyCheck;
  public
    property MaxUnusedItem: integer read FMaxUnusedItem
                                           write FMaxUnusedItem;
    property ResourceCacheItemClass: TResourceCacheItemClass
                                                   read FResourceCacheItemClass;
    property ResourceCacheDescriptorClass: TResourceCacheDescriptorClass
                                             read FResourceCacheDescriptorClass;
  end;


  { THandleResourceCache }

  THandleResourceCache = class(TResourceCache)
  public
    function FindItem(Handle: TLCLHandle): TResourceCacheItem;
  end;


  { TBlockResourceCacheDescriptor }

  TBlockResourceCacheDescriptor = class(TResourceCacheDescriptor)
  public
    Data: Pointer;
    destructor Destroy; override;
  end;


  { TBlockResourceCache }

  TBlockResourceCache = class(THandleResourceCache)
  private
    FDataSize: integer;
  protected
    FOnCompareDescPtrWithDescriptor: TListSortCompare;
  public
    constructor Create(TheDataSize: integer);
    function FindDescriptor(DescPtr: Pointer): TBlockResourceCacheDescriptor;
    function AddResource(Handle: TLCLHandle; DescPtr: Pointer
                         ): TBlockResourceCacheDescriptor;
    function CompareDescriptors(Tree: TAvgLvlTree;
                                Desc1, Desc2: Pointer): integer; override;
  public
    property DataSize: integer read FDataSize;
    property OnCompareDescPtrWithDescriptor: TListSortCompare
                                           read FOnCompareDescPtrWithDescriptor;
  end;

function ComparePHandleWithResourceCacheItem(HandlePtr: PLCLHandle; Item:
  TResourceCacheItem): integer;
function CompareDescPtrWithBlockResDesc(DescPtr: Pointer;
  Item: TBlockResourceCacheDescriptor): integer;

implementation


function ComparePHandleWithResourceCacheItem(HandlePtr: PLCLHandle; Item:
  TResourceCacheItem): integer;
begin
  Result := CompareLCLHandles(HandlePtr^, Item.Handle);
end;

function CompareDescPtrWithBlockResDesc(DescPtr: Pointer;
  Item: TBlockResourceCacheDescriptor): integer;
begin
  Result := CompareMemRange(DescPtr, Item.Data,
              TBlockResourceCache(Item.Cache).DataSize);
end;


{ TResourceCacheItem }

constructor TResourceCacheItem.Create(TheCache: TResourceCache;
  TheHandle: TLCLHandle);
begin
  Cache:=TheCache;
  Handle:=TheHandle;
end;

destructor TResourceCacheItem.Destroy;
begin
  if FDestroying then
    RaiseGDBException('');
  FDestroying:=true;
  Cache.RemoveItem(Self);
  //debugln('TResourceCacheItem.Destroy B ',dbgs(Self));
  Handle:=0;
  inherited Destroy;
  //debugln('TResourceCacheItem.Destroy END ',dbgs(Self));
end;

procedure TResourceCacheItem.IncreaseRefCount;
begin
  inc(FReferenceCount);
  if FReferenceCount=1 then
    Cache.ItemUsed(Self);
  if (FReferenceCount=1000) or (FReferenceCount=10000) then
    WarnReferenceHigh;
end;

procedure TResourceCacheItem.DecreaseRefCount;

  procedure RaiseRefCountZero;
  begin
    RaiseGDBException('TResourceCacheItem.DecreaseRefCount=0 '+ClassName);
  end;

begin
  //debugln('TResourceCacheItem.DecreaseRefCount ',ClassName,' ',dbgs(Self),' ',dbgs(FReferenceCount));
  if FReferenceCount=0 then
    RaiseRefCountZero;
  dec(FReferenceCount);
  if FReferenceCount=0 then
    Cache.ItemUnused(Self);
  //debugln('TResourceCacheItem.DecreaseRefCount END ');
end;

procedure TResourceCacheItem.AddToList(var First, Last: TResourceCacheItem
  );
// add as last
begin
  Next:=nil;
  Prev:=Last;
  Last:=Self;
  if First=nil then First:=Self;
  if Prev<>nil then Prev.Next:=Self;
end;

procedure TResourceCacheItem.RemoveFromList(var First,Last: TResourceCacheItem);
begin
  if First=Self then First:=Next;
  if Last=Self then Last:=Prev;
  if Next<>nil then Next.Prev:=Prev;
  if Prev<>nil then Prev.Next:=Next;
  Next:=nil;
  Prev:=nil;
end;

procedure TResourceCacheItem.WarnReferenceHigh;
begin
  debugln('WARNING: TResourceCacheItem.IncreaseRefCount ',dbgs(FReferenceCount),' ',Cache.ClassName);
end;

{ TResourceCacheDescriptor }

constructor TResourceCacheDescriptor.Create(TheCache: TResourceCache;
  TheItem: TResourceCacheItem);
begin
  Cache:=TheCache;
  Item:=TheItem;
  Item.IncreaseRefCount;
  AddToList(Item.FirstDescriptor,Item.LastDescriptor);
end;

destructor TResourceCacheDescriptor.Destroy;
begin
  if FDestroying then
    RaiseGDBException('');
  FDestroying:=true;
  Cache.RemoveDescriptor(Self);
  inherited Destroy;
end;

procedure TResourceCacheDescriptor.AddToList(
  var First, Last: TResourceCacheDescriptor);
// add as last
begin
  Next:=nil;
  Prev:=Last;
  Last:=Self;
  if First=nil then First:=Self;
  if Prev<>nil then Prev.Next:=Self;
end;

procedure TResourceCacheDescriptor.RemoveFromList(
  var First, Last: TResourceCacheDescriptor);
begin
  if First=Self then First:=Next;
  if Last=Self then Last:=Prev;
  if Next<>nil then Next.Prev:=Prev;
  if Prev<>nil then Prev.Next:=Next;
  Next:=nil;
  Prev:=nil;
end;

{ TResourceCache }

procedure TResourceCache.RemoveItem(Item: TResourceCacheItem);
begin
  if not FDestroying then begin
    while Item.FirstDescriptor<>nil do begin
      if Item.FirstDescriptor.FDestroying then
        RaiseGDBException('TResourceCache.RemoveItem');
      Item.FirstDescriptor.Free;
    end;
    FItems.Remove(Item);
  end;
end;

procedure TResourceCache.RemoveDescriptor(Desc: TResourceCacheDescriptor);
var
  Item: TResourceCacheItem;
begin
  if not FDestroying then begin
    Item:=Desc.Item;
    if Item<>nil then
      Desc.RemoveFromList(Item.FirstDescriptor,Item.LastDescriptor);
    FDescriptors.Remove(Desc);
    if (Item<>nil) and (Item.FirstDescriptor=nil) and (not Item.FDestroying)
    then
      Item.Free;
  end;
end;

procedure TResourceCache.ItemUsed(Item: TResourceCacheItem);
// called after creation or when Item is used again
begin
  if not ItemIsUsed(Item) then begin
    // remove from unused list
    Item.RemoveFromList(FFirstUnusedItem,FLastUnusedItem);
    dec(FUnUsedItemCount);
  end;
end;

procedure TResourceCache.ItemUnused(Item: TResourceCacheItem);
// called when Item is not used any more
var
  DeleteItem: TResourceCacheItem;
begin
  {$IFDEF CheckResCacheConsistency}
  ConsistencyCheck;
  {$ENDIF}
  //debugln('TResourceCache.ItemUnused A ',ClassName,' ',dbgs(Self));
  if not ItemIsUsed(Item) then
    raise Exception.Create('TResourceCache.ItemUnused');
  //debugln('TResourceCache.ItemUnused B ',ClassName,' ',dbgs(Self));
  Item.AddToList(FFirstUnusedItem,FLastUnusedItem);
  inc(FUnUsedItemCount);
  //debugln('TResourceCache.ItemUnused C ',ClassName,' ',dbgs(Self));
  if FUnUsedItemCount>FMaxUnusedItem then begin
    // maximum unused resources reached -> free the oldest
    DeleteItem:=FFirstUnusedItem;
    DeleteItem.RemoveFromList(FFirstUnusedItem,FLastUnusedItem);
    DeleteItem.Free;
  end;
  //debugln('TResourceCache.ItemUnused END ',ClassName,' ',dbgs(Self));
end;

function TResourceCache.ItemIsUsed(Item: TResourceCacheItem): boolean;
begin
  Result:=(FFirstUnusedItem<>Item) and (Item.Next=nil)
          and (Item.Prev=nil)
end;

constructor TResourceCache.Create;
begin
  FMaxUnusedItem:=100;
  FItems:=TAvgLvlTree.CreateObjectCompare(@CompareItems);
  FDescriptors:=TAvgLvlTree.CreateObjectCompare(@CompareDescriptors);
  FResourceCacheItemClass:=TResourceCacheItem;
  FResourceCacheDescriptorClass:=TResourceCacheDescriptor;
end;

procedure TResourceCache.Clear;
begin
  while FFirstUnusedItem<>nil do
    FFirstUnusedItem.RemoveFromList(FFirstUnusedItem,FLastUnusedItem);
  FItems.FreeAndClear;
  FDescriptors.FreeAndClear;
end;

destructor TResourceCache.Destroy;
begin
  FDestroying := True;
  Clear;
  FItems.Free;
  FItems := nil;
  FDescriptors.Free;
  FDescriptors := nil;
  inherited Destroy;
end;

function TResourceCache.CompareItems(Tree: TAvgLvlTree; Item1, Item2: Pointer
  ): integer;
begin
  Result:=CompareLCLHandles(TResourceCacheItem(Item1).Handle,
                            TResourceCacheItem(Item2).Handle);
end;

procedure TResourceCache.ConsistencyCheck;
var
  ANode: TAvgLvlTreeNode;
  Item: TResourceCacheItem;
  Desc: TResourceCacheDescriptor;
  Desc2: TResourceCacheDescriptor;
begin
  if (FFirstUnusedItem=nil) xor (FLastUnusedItem=nil) then
    RaiseGDBException('');

  // check items
  if FItems.ConsistencyCheck<>0 then
    RaiseGDBException('');
  ANode:=FItems.FindLowest;
  while ANode<>nil do begin
    Item:=TResourceCacheItem(ANode.Data);
    if Item.FirstDescriptor=nil then
      RaiseGDBException('');
    if Item.LastDescriptor=nil then
      RaiseGDBException('');
    if Item.FirstDescriptor.Prev<>nil then
      RaiseGDBException('');
    if Item.LastDescriptor.Next<>nil then
      RaiseGDBException('');
    Desc:=Item.FirstDescriptor;
    while Desc<>nil do begin
      if Desc.Item<>Item then
        RaiseGDBException('');
      if (Desc.Next<>nil) and (Desc.Next.Prev<>Desc) then
        RaiseGDBException('');
      if (Desc.Prev<>nil) and (Desc.Prev.Next<>Desc) then
        RaiseGDBException('');
      if (Desc.Next=nil) and (Item.LastDescriptor<>Desc) then
        RaiseGDBException('');
      Desc:=Desc.Next;
    end;
    ANode:=FItems.FindSuccessor(ANode);
  end;
  
  // check Descriptors
  if FDescriptors.ConsistencyCheck<>0 then
    RaiseGDBException('');
  ANode:=FDescriptors.FindLowest;
  while ANode<>nil do begin
    Desc:=TResourceCacheDescriptor(ANode.Data);
    Item:=Desc.Item;
    if Item=nil then
      RaiseGDBException('');
    Desc2:=Item.FirstDescriptor;
    while (Desc2<>nil) and (Desc2<>Desc) do
      Desc2:=Desc2.Next;
    if Desc<>Desc2 then
      RaiseGDBException('');
    ANode:=FItems.FindSuccessor(ANode);
  end;
end;

{ THandleResourceCache }

function THandleResourceCache.FindItem(Handle: TLCLHandle): TResourceCacheItem;
var
  ANode: TAvgLvlTreeNode;
begin
  ANode:=FItems.FindKey(@Handle,
                        TListSortCompare(@ComparePHandleWithResourceCacheItem));
  if ANode<>nil then
    Result:=TResourceCacheItem(ANode.Data)
  else
    Result:=nil;
end;

{ TBlockResourceCache }

constructor TBlockResourceCache.Create(TheDataSize: integer);
begin
  inherited Create;
  FDataSize:=TheDataSize;
  FResourceCacheDescriptorClass:=TBlockResourceCacheDescriptor;
  FOnCompareDescPtrWithDescriptor:=
                              TListSortCompare(@CompareDescPtrWithBlockResDesc);
end;

function TBlockResourceCache.FindDescriptor(DescPtr: Pointer
  ): TBlockResourceCacheDescriptor;
var
  ANode: TAvgLvlTreeNode;
begin
  ANode:=FDescriptors.FindKey(DescPtr,FOnCompareDescPtrWithDescriptor);
  if ANode<>nil then
    Result:=TBlockResourceCacheDescriptor(ANode.Data)
  else
    Result:=nil;
end;

function TBlockResourceCache.AddResource(Handle: TLCLHandle; DescPtr: Pointer
  ): TBlockResourceCacheDescriptor;
var
  Item: TResourceCacheItem;

  procedure RaiseDescriptorAlreadyAdded;
  var
    Msg: String;
    i: Integer;
  begin
    Msg:='TBlockResourceCache.AddResource Descriptor Already Added '#13;
    for i:=0 to DataSize-1 do
      Msg:=Msg+HexStr(ord(PChar(DescPtr)[i]),2);
    raise Exception.Create(Msg);
  end;

begin
  {$IFDEF CheckResCacheConsistency}
  ConsistencyCheck;
  {$ENDIF}
  Result:=FindDescriptor(DescPtr);
  if Result<>nil then
    RaiseDescriptorAlreadyAdded;

  Item:=FindItem(Handle);
  if Item=nil then begin
    Item:=FResourceCacheItemClass.Create(Self,Handle);
    FItems.Add(Item);
  end;
  Result:=TBlockResourceCacheDescriptor(
                               FResourceCacheDescriptorClass.Create(Self,Item));
  ReAllocMem(Result.Data,DataSize);
  System.Move(DescPtr^,Result.Data^,DataSize);
  FDescriptors.Add(Result);
end;

function TBlockResourceCache.CompareDescriptors(Tree: TAvgLvlTree; Desc1,
  Desc2: Pointer): integer;
begin
  Result:=CompareMemRange(TBlockResourceCacheDescriptor(Desc1).Data,
                          TBlockResourceCacheDescriptor(Desc2).Data,
                          DataSize);
end;

{ TBlockResourceCacheDescriptor }

destructor TBlockResourceCacheDescriptor.Destroy;
begin
  inherited Destroy;
  ReAllocMem(Data,0);
end;

end.