CentrED - /UCacheManager.pas - AKS DataBasis Redmine

root / UCacheManager.pas

History | View | Annotate | Download (6.5 kB)

 (*
  * 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.