unit UCache;

////////////////////////////////////////////////////////////////////////////////
///  This unit defines the TCache object, which allows for caching of an array
///  of const, and a reply. Items in the cache can be found by passing in an
///  array of const with the same values.
///  This object allows for easy caching of VISTA calls, but it's generic enough
///  to be used in many other situations.
///
///  A simple example of use:
///    CacheItem := Cache.Find([1, 'Two', 3.33]);
///    if Assigned(CacheItem) then Reply := CacheItem.Reply
///    else
///    begin
///      CallVista('RPCName', [1, 'Two', 3.33], Reply);
///      Cache.Add([1, 'Two', 3.33], Reply);
///    end;
///    // Reply is now assigned and you can use it.
///
///  Tips:
///    Use TCache.MaxSize to set the maximum size the cache may grow to
///    Use TCache.IgnoreCase to compare all strings without case
///      consideration, the default is True.
///    Inherit from TCacheItem<T> and implement the TCache<T>.OnCreateCacheItem
///      event to add additional handling, such as deep-copying of specific
///      classes, interfaces, or pointers, or specific equality comparisson,
///      etc.You are expected to create and return a new instance of
///      an object inheriting from TCacheItem<T> (this transfers ownership of it
///      to the cache!) Tip: you can assign a class method on the inherited
///      TCacheItem<T> to OnCreateCacheItem to make things neat and easy.
///
///  Warnings:
///    Due to limitations of deep copying an array of TVarRec (that's what an
///    array of const is behind the scenes) you should probably not cache
//     Interfaces, Pointers, and Objects unless you know what you are doing.
///    A very specific exception to this rule are TStrings descendants, for
///    which special code is implemented that stores and compares them at the
///    strings level.
////////////////////////////////////////////////////////////////////////////////
interface

uses
  System.Generics.Collections;

type
  TCacheData = TArray<TVarRec>;

  TCache<T> = class;

  TCacheItem<T> = class
  strict private
    FCache: TCache<T>;
    FCreated: TDateTime;
    FData: TCacheData;
    FReply: T;
    function GetAge: Int64;
  strict protected
    function IsSameVarRec(const ALeft, ARight: TVarRec; AIgnoreCase: Boolean)
      : Boolean; virtual;
    class function CopyVarRec(const AItem: TVarRec): TVarRec; virtual;
    class procedure FinalizeVarRec(var AItem: TVarRec); virtual;
  public
    class function CreateCacheData(const AData: array of const): TCacheData;
    class procedure FreeCacheData(var AData: TCacheData);
  public
    constructor Create(ACache: TCache<T>; const AData: array of const);
    destructor Destroy; override;
    property Cache: TCache<T> read FCache;
    property Data: TCacheData read FData;
    property Reply: T read FReply write FReply;
    function IsSameData(const AData: array of const): Boolean;
    property Age: Int64 read GetAge; // in MilliSeconds
    procedure AgeReset;
  end;

  TOnCreateCacheItemEvent<T> = function(ACache: TCache<T>;
    const AData: array of const): TCacheItem<T> of object;

  TBeforeDestroyCacheItemEvent<T> = procedure(ACache: TCache<T>;
    ACacheItem: TCacheItem<T>) of object;

  TCache<T> = class
  strict private
    FList: TObjectList<TCacheItem<T>>;
    FMaxSize: integer;
    FMaxAge: Int64;
    FIgnoreCase: boolean;
    FEnabled: Boolean;
    procedure SetEnabled(const Value: Boolean);
  protected
    function CreateCacheItem(const AData: array of const)
      : TCacheItem<T>; virtual;
    procedure DestroyCacheItem(ACacheItem: TCacheItem<T>); virtual;
  public
    constructor Create;
    destructor Destroy; override;
    property Enabled: Boolean read FEnabled write SetEnabled;
    function Find(const AData: array of const): TCacheItem<T>; virtual;
    function Add(const AData: array of const): TCacheItem<T>; overload;
    function Add(const AData: array of const; const AReply: T)
      : TCacheItem<T>; overload;
    function Remove(const AData: array of const): Boolean;
    procedure Clear;
    property MaxSize: integer read FMaxSize write FMaxSize;
    property MaxAge: Int64 read FMaxAge write FMaxAge;
    // In Miliseconds, 0 means no MaxAge
    property IgnoreCase: boolean read FIgnoreCase write FIgnoreCase;
  end;

implementation

uses
  System.DateUtils,
  System.AnsiStrings,
  System.Classes,
  System.SysUtils;

// TCacheItem<T>

constructor TCacheItem<T>.Create(ACache: TCache<T>;
  const AData: array of const);
begin
  inherited Create;
  if not Assigned(ACache) then raise Exception.Create('ACache not assigned');
  FCache := ACache;
  FCreated := Now;
  FData := CreateCacheData(AData);
end;

destructor TCacheItem<T>.Destroy;
begin
  FreeCacheData(FData);
  inherited Destroy;
end;

class function TCacheItem<T>.CopyVarRec(const AItem: TVarRec): TVarRec;
// Copies a TVarRec and its contents. If the content is referenced
// the value will be copied to a new location and the reference
// updated.
// The Result is an allocated TVarRec that needs to be finalized with
// FinalizeVarRec to prevent memory leaks!
var
  W: WideString;
begin
  // Copy entire TVarRec first
  Result := AItem;
  // Now handle special cases
  case AItem.VType of
    vtExtended:
      begin
        New(Result.VExtended);
        Result.VExtended^ := AItem.VExtended^;
      end;
    vtString:
      begin
        // Improvement suggestion by Hallvard Vassbotn: only copy real length.
        GetMem(Result.VString, Length(AItem.VString^) + 1);
        Result.VString^ := AItem.VString^;
      end;
    vtPChar: Result.VPChar := System.AnsiStrings.StrNew(AItem.VPChar);
    vtPWideChar:
      begin
        // There is no StrNew for PWideChar
        W := AItem.VPWideChar;
        GetMem(Result.VPWideChar, (Length(W) + 1) * SizeOf(WideChar));
        Move(PWideChar(W)^, Result.VPWideChar^,
          (Length(W) + 1) * SizeOf(WideChar));
      end;
    vtAnsiString:
      begin
        // A little trickier: casting to AnsiString will ensure reference
        // counting is done properly.
        // nil out first, so no attempt to decrement reference count.
        Result.VAnsiString := nil;
        AnsiString(Result.VAnsiString) := AnsiString(AItem.VAnsiString);
      end;
    vtCurrency:
      begin
        New(Result.VCurrency);
        Result.VCurrency^ := AItem.VCurrency^;
      end;
    vtVariant:
      begin
        New(Result.VVariant);
        Result.VVariant^ := AItem.VVariant^;
      end;
    vtInterface:
      begin
        // Casting ensures proper reference counting.
        Result.VInterface := nil;
        IInterface(Result.VInterface) := IInterface(AItem.VInterface);
      end;
    vtWideString:
      begin
        // Casting ensures a proper copy is created.
        Result.VWideString := nil;
        WideString(Result.VWideString) := WideString(AItem.VWideString);
      end;
    vtInt64:
      begin
        New(Result.VInt64);
        Result.VInt64^ := AItem.VInt64^;
      end;
    vtUnicodeString:
      begin
        // Similar to AnsiString.
        Result.VUnicodeString := nil;
        UnicodeString(Result.VUnicodeString) :=
          UnicodeString(AItem.VUnicodeString);
      end;
    vtObject:
      begin
        // Copies a TStrings or decendent to a TStringList, but raises an error
        // on all other objects
        if AItem.VObject is TStrings then
        begin
          Result.VObject := TStringList.Create;
          TStrings(Result.VObject).Assign(TStrings(AItem.VObject));
          // In all other situations the pointer to the object is stored. This
          // may not have a lot of meaning in comparissons and is not
          // recommended.
        end;
      end;
    // vtPointer: raise Exception.Create('CopyVarRec cannot copy a Pointer');
    //   Not raising the exception, but copying of a pointer is not recommended
    //   as caching and comparing pointers has very little meaning
  end;
end;

class procedure TCacheItem<T>.FinalizeVarRec(var AItem: TVarRec);
// use this function on copied TVarRecs only!
begin
  case AItem.VType of
    vtExtended: Dispose(AItem.VExtended);
    vtString: Dispose(AItem.VString);
    vtPChar: System.AnsiStrings.StrDispose(AItem.VPChar);
    vtPWideChar: FreeMem(AItem.VPWideChar);
    vtAnsiString: AnsiString(AItem.VAnsiString) := '';
    vtCurrency: Dispose(AItem.VCurrency);
    vtVariant: Dispose(AItem.VVariant);
    vtInterface: IInterface(AItem.VInterface) := nil;
    vtWideString: WideString(AItem.VWideString) := '';
    vtInt64: Dispose(AItem.VInt64);
    vtUnicodeString: UnicodeString(AItem.VUnicodeString) := '';
    vtObject: AItem.VObject.Free;
  end;
  AItem.VInteger := 0;
end;

function TCacheItem<T>.IsSameVarRec(const ALeft, ARight: TVarRec;
  AIgnoreCase: Boolean): Boolean;
begin
  if ALeft.VType <> ARight.VType then Exit(False);
  case ALeft.VType of
    vtInteger: if ALeft.VInteger <> ARight.VInteger then Exit(False);
    vtBoolean: if ALeft.VBoolean <> ARight.VBoolean then Exit(False);
    vtChar: if AIgnoreCase then
      begin
        if not SameText(ALeft.VChar, ARight.VChar) then Exit(False);
      end else begin
        if ALeft.VChar <> ARight.VChar then Exit(False);
      end;
    vtExtended: if ALeft.VExtended^ <> ARight.VExtended^ then Exit(False);
    vtString: if AIgnoreCase then
      begin
        if not SameText(ALeft.VString^, ARight.VString^) then Exit(False);
      end else begin
        if ALeft.VString^ <> ARight.VString^ then Exit(False);
      end;
    vtPointer: if ALeft.VPointer <> ARight.VPointer then Exit(False);
    vtPChar: if AIgnoreCase then
      begin
        if not SameText(ALeft.VPChar, ARight.VPChar) then Exit(False);
      end else begin
        if ALeft.VPChar <> ARight.VPChar then Exit(False);
      end;
    vtClass: if ALeft.VClass <> ARight.VClass then Exit(False);
    vtWideChar: if AIgnoreCase then
      begin
        if not SameText(ALeft.VWideChar, ARight.VWideChar) then Exit(False);
      end else begin
        if ALeft.VWideChar <> ARight.VWideChar then Exit(False);
      end;
    vtPWideChar: if AIgnoreCase then
      begin
        if not SameText(WideString(ALeft.VPWideChar),
          WideString(ARight.VPWideChar)) then Exit(False)
      end else begin
        if WideString(ALeft.VPWideChar) <> WideString(ARight.VPWideChar) then
            Exit(False);
      end;
    vtAnsiString: if AIgnoreCase then
      begin
        if not SameText(AnsiSTring(ALeft.VAnsiString),
          AnsiString(ARight.VAnsiString)) then Exit(False)
      end else begin
        if AnsiSTring(ALeft.VAnsiString) <> AnsiString(ARight.VAnsiString) then
            Exit(False);
      end;
    vtCurrency: if ALeft.VCurrency^ <> ARight.VCurrency^ then Exit(False);
    vtVariant: if ALeft.VVariant^ <> ARight.VVariant^ then Exit(False);
    vtInterface: if ALeft.VInterface <> ARight.VInterface then Exit(False);
    vtWideString: if AIgnoreCase then
      begin
        if not SameText(WideString(ALeft.VWideString),
          WideString(ARight.VWideString)) then Exit(False)
      end else begin
        if WideString(ALeft.VWideString) <> WideString(ARight.VWideString) then
            Exit(False);
      end;
    vtInt64: if ALeft.VInt64^ <> ARight.VInt64^ then Exit(False);
    vtUnicodeString: if AIgnoreCase then
      begin
        if not SameText(UnicodeString(ALeft.VUnicodeString),
          UnicodeString(ARight.VUnicodeString)) then Exit(False)
      end else begin
        if UnicodeString(ALeft.VUnicodeString) <>
          UnicodeString(ARight.VUnicodeString) then Exit(False);
      end;
    vtObject: if (ALeft.VObject is TStrings) and (ARight.VObject is TStrings)
      then
      begin
        if AIgnoreCase then
        begin
          if not SameText(TStrings(ALeft.VObject).Text, TStrings(ARight.VObject)
            .Text) then Exit(False);
        end else begin
          if TStrings(ALeft.VObject).Text <> TStrings(ARight.VObject).Text then
              Exit(False);
        end;
      end else begin
        if ALeft.VObject <> ARight.VObject then Exit(False);
      end;
  end;
  Result := True;
end;

function TCacheItem<T>.IsSameData(const AData: array of const): Boolean;
var
  I: integer;
begin
  if high(AData) <> high(FData) then Exit(False);
  for I := low(AData) to high(AData) do
    if not IsSameVarRec(AData[I], FData[I], Cache.IgnoreCase) then Exit(False);
  Result := True
end;

class function TCacheItem<T>.CreateCacheData(const AData: array of const)
  : TCacheData;
// Call FreeCacheData after use!
var
  I: Integer;
begin
  SetLength(Result, Length(AData));
  try
    for I := low(AData) to high(AData) do Result[I] := CopyVarRec(AData[I]);
  except
    FreeCacheData(Result);
  end;
end;

class procedure TCacheItem<T>.FreeCacheData(var AData: TCacheData);
// A TCacheData array contains TVarRecs that must be finalized. This function
// does that for all items in the array.
var
  I: Integer;
begin
  if Assigned(AData) then
  begin
    try
      for I := low(AData) to high(AData) do FinalizeVarRec(AData[I]);
    finally
      AData := nil;
    end;
  end;
end;

function TCacheItem<T>.GetAge: Int64;
begin
  Result := MilliSecondsBetween(FCreated, Now);
end;

procedure TCacheItem<T>.AgeReset;
begin
  FCreated := Now;
end;

// TCache<T>

constructor TCache<T>.Create;
begin
  inherited Create;
  FList := TObjectList<TCacheItem<T>>.Create(True);
  FMaxSize := 20; // 20 items
  FIgnoreCase := True;
  FEnabled := True;
end;

destructor TCache<T>.Destroy;
begin
  Clear;
  FreeAndNil(FList);
  inherited Destroy;
end;

function TCache<T>.Find(const AData: array of const): TCacheItem<T>;
// Find a matching item in the Cache. Returns nil if no item is found
var
  ACacheItem: TCacheItem<T>;
begin
  if not Enabled then Exit(nil);
  for ACacheItem in FList do
    if ACacheItem.IsSameData(AData) then
    begin
      if (MaxAge > 0) and (ACacheItem.Age > MaxAge) then
      begin
        // Items in cache that are too old are not found
        DestroyCacheItem(ACacheItem);
        Exit(nil);
      end;
      // Move item to end of list so the list is sorted from least to most
      // recently retrieved
      FList.Move(FList.IndexOf(ACacheItem), FList.Count - 1);
      Exit(ACacheItem);
    end;
  Result := nil;
end;

function TCache<T>.CreateCacheItem(const AData: array of const): TCacheItem<T>;
begin
  Result := TCacheItem<T>.Create(Self, AData);
end;

procedure TCache<T>.DestroyCacheItem(ACacheItem: TCacheItem<T>);
begin
  FList.Remove(ACacheItem);
end;

function TCache<T>.Add(const AData: array of const): TCacheItem<T>;
// adds an item to the cache, but only if it is unique.
begin
  if not Enabled then Exit(nil);
  Result := Find(AData);
  if not Assigned(Result) then
  begin
    Result := CreateCacheItem(AData);
    if not Assigned(Result) then
        raise Exception.Create('TCache<T>.CreateCacheItem failed');
    FList.Add(Result);
    if FList.Count > MaxSize then
    begin
      // add an item, free an item
      DestroyCacheItem(FList.Items[0]);
    end;
  end;
end;

function TCache<T>.Add(const AData: array of const; const AReply: T)
  : TCacheItem<T>;
// adds an item to the cache, but only if it is unique.
// If it is not unique, this will find the item that's already in the cache and
// update the reply
begin
  Result := Add(AData);
  if Assigned(Result) then Result.Reply := AReply;
end;

procedure TCache<T>.Clear;
// Clears the entire cache
var
  I: integer;
begin
  for I := FList.Count - 1 downto 0 do DestroyCacheItem(FList.Items[I]);
  FList.Clear;
end;

function TCache<T>.Remove(const AData: array of const): Boolean;
// Removes the matching item from the cache if it exists. Result = True means
// the item was found and removed.
var
  ACacheItem: TCacheItem<T>;
begin
  ACacheItem := Find(AData);
  Result := Assigned(ACacheItem);
  if Result then DestroyCacheItem(ACacheItem);
end;

procedure TCache<T>.SetEnabled(const Value: Boolean);
begin
  FEnabled := Value;
  if not Value then Clear;
end;

end.
