CentrED

(*

 * CDDL HEADER START

 *

 * The contents of this file are subject to the terms of the

 * Common Development and Distribution License, Version 1.0 only

 * (the "License").  You may not use this file except in compliance

 * with the License.

 *

 * You can obtain a copy of the license at

 * http://www.opensource.org/licenses/cddl1.php.

 * See the License for the specific language governing permissions

 * and limitations under the License.

 *

 * When distributing Covered Code, include this CDDL HEADER in each

 * file and include the License file at

 * http://www.opensource.org/licenses/cddl1.php.  If applicable,

 * add the following below this CDDL HEADER, with the fields enclosed

 * by brackets "[]" replaced with your own identifying * information:

 *      Portions Copyright [yyyy] [name of copyright owner]

 *

 * CDDL HEADER END

 *

 *

 *      Portions Copyright 2010 Andreas Schneider

 *)

unit UCacheManager;

{$mode objfpc}{$H+}

{$interfaces corba}

interface

uses

  SysUtils, Classes;

type

  ICacheable = interface['{0ABAA4DE-8128-47B3-ABFE-5250A74A0428}']

    function CanBeRemoved: Boolean;

    procedure RemoveFromCache;

  end;

  { TCacheManager }

  generic TCacheManager<T> = class

  public type

    { Types }

    TRemoveObjectEvent = procedure(AObject: T) of object;

    PCacheEntry = ^TCacheEntry;

    TCacheEntry = record

      ID: Integer;

      Obj: T;

      Next: PCacheEntry;

    end;

  protected

    { Members }

    FSize: Integer;

    FFirst: PCacheEntry;

    FLast: PCacheEntry;

    FOnRemoveObject: TRemoveObjectEvent;

    procedure DoRemoveObject(var AObject: T; ANotify: Boolean = True);

  public

    constructor Create(ASize: Integer);

    destructor Destroy; override;

    { Fields }

    property OnRemoveObject: TRemoveObjectEvent read FOnRemoveObject

      write FOnRemoveObject;

    { Methods }

    function QueryID(const AID: Integer; out AObj: T): Boolean;

    procedure StoreID(AID: Integer; AObj: T);

    procedure DiscardID(AID: Integer);

    procedure DiscardObj(AObj: T);

    procedure RemoveID(AID: Integer);

    procedure Clear;

    function Iterate(var ACacheEntry: PCacheEntry): Boolean;

  end;

implementation

uses

  Logging;

{ TCacheManager }

procedure TCacheManager.DoRemoveObject(var AObject: T; ANotify: Boolean = True);

var

  cacheable: ICacheable;

begin

  if ANotify and Assigned(FOnRemoveObject) then FOnRemoveObject(AObject);

  if TObject(AObject).GetInterface(ICacheable, cacheable) then

    cacheable.RemoveFromCache

  else

    TObject(AObject).Free;

  TObject(AObject) := nil;

end;

constructor TCacheManager.Create(ASize: Integer);

var

  i: Integer;

  current: PCacheEntry;

begin

  FOnRemoveObject := nil;

  FSize := ASize;

  if FSize > 0 then

  begin

    New(FFirst);

    current := FFirst;

    current^.ID := LongInt($FFFFFFFF);

    current^.Obj := nil;

    for i := 2 to FSize do

    begin

      New(current^.Next);

      FLast := current;

      current := current^.Next;

      current^.ID := LongInt($FFFFFFFF);

      current^.Obj := nil;

    end;

    current^.Next := nil;

  end;

end;

destructor TCacheManager.Destroy;

var

  i: Integer;

  current, last: PCacheEntry;

begin

  current := FFirst;

  for i := 1 to FSize do

  begin

    if Pointer(current^.Obj) <> nil then

      DoRemoveObject(current^.Obj);

    last := current;

    current := current^.Next;

    Dispose(last);

  end;

  inherited;

end;

procedure TCacheManager.DiscardID(AID: Integer);

var

  current: PCacheEntry;

begin

  current := FFirst;

  while (current <> nil) do

  begin

    if (current^.ID = AID) then

    begin

      current^.ID := LongInt($FFFFFFFF);

      current^.Obj := nil;

      current := nil;

    end else

      current := current^.Next;

  end;

end;

procedure TCacheManager.DiscardObj(AObj: T);

var

  current: PCacheEntry;

begin

  current := FFirst;

  while (current <> nil) do

  begin

    if (current^.Obj = AObj) then

    begin

      current^.ID := LongInt($FFFFFFFF);

      current^.Obj := nil;

      current := nil;

    end else

      current := current^.Next;

  end;

end;

procedure TCacheManager.RemoveID(AID: Integer);

var

  current: PCacheEntry;

begin

  current := FFirst;

  FLast := current;

  while (current <> nil) do

  begin

    if (current^.ID = AID) then

    begin

      current^.ID := LongInt($FFFFFFFF);

      if Pointer(current^.Obj) <> nil then

        DoRemoveObject(current^.Obj, False);

    end;

    if (current^.Next <> nil) then

      FLast := current;

    current := current^.Next;

  end;

end;

procedure TCacheManager.Clear;

var

  current: PCacheEntry;

begin

  current := FFirst;

  while current <> nil do

  begin

    if Pointer(current^.Obj) <> nil then

    begin

      current^.ID := LongInt($FFFFFFFF);

      DoRemoveObject(current^.Obj);

    end;

    current := current^.Next;

  end;

end;

function TCacheManager.Iterate(var ACacheEntry: PCacheEntry): Boolean;

begin

  if ACacheEntry = nil then

    ACacheEntry := FFirst

  else

    ACacheEntry := ACacheEntry^.Next;

  Result := ACacheEntry <> nil;

end;

function TCacheManager.QueryID(const AID: Integer;

  out AObj: T): Boolean;

var

  current: PCacheEntry;

begin

  current := FFirst;

  FLast := current;

  Result := False;

  while (current <> nil) and (not Result) do

  begin

    if (current^.ID = AID) then

    begin

      Result := True;

      AObj := current^.Obj;

      if current <> FFirst then

      begin

        FLast^.Next := current^.Next;

        current^.Next := FFirst;

        FFirst := current;

      end;

    end;

    if (current^.Next <> nil) then

      FLast := current;

    current := current^.Next;

  end;

end;

procedure TCacheManager.StoreID(AID: Integer; AObj: T);

var

  current: PCacheEntry;

  cacheable: ICacheable;

  i: Integer;

begin

  current := FLast^.Next; //well, FLast is not really the last, but the one before the last ;)

  FLast^.Next := nil;

  current^.Next := FFirst;

  FFirst := current;

  if Pointer(FFirst^.Obj) <> nil then //if the last cache entry did contain an object, remove it now or grow

  begin

    if TObject(FFirst^.Obj).GetInterface(ICacheable, cacheable) and

      not cacheable.CanBeRemoved then

    begin

      Logger.Send([lcInfo], 'Cache growing (%s)', [ClassName]);

      New(FLast^.Next);

      current := FLast^.Next;

      current^.ID := FFirst^.ID;

      current^.Obj := FFirst^.Obj;

      for i := 2 to FSize do

      begin

        New(current^.Next);

        FLast := current;

        current := current^.Next;

        current^.ID := LongInt($FFFFFFFF);

        current^.Obj := nil;

      end;

      current^.Next := nil;

      FSize := FSize * 2;

    end else

      DoRemoveObject(current^.Obj);

  end;

  FFirst^.ID := AID;

  FFirst^.Obj := AObj;

end;

end.