File Coverage

blib/lib/File/Properties/Cache.pm

Criterion	Covered	Total	%
statement	62	82	75.6
branch	13	24	54.1
condition	3	6	50.0
subroutine	13	16	81.2
pod	8	8	100.0
total	99	136	72.7

# ----------------------------------------------------------------------------
#
# This module supports caching of data in an SQL database. Once the
# cache table format has been defined, a simple interface is available
# for inserting and retrieving data from the cache.
#
# Copyright © 2010,2011 Brendt Wohlberg
# See distribution LICENSE file for license details.
#
# Most recent modification: 4 November 2011
#
# ----------------------------------------------------------------------------

package File::Properties::Cache;
our $VERSION = 0.01;

use File::Properties::Error;
use File::Properties::Database;
use base qw(File::Properties::Database);

require 5.005;
use strict;
use warnings;
use Error qw(:try);


# ----------------------------------------------------------------------------
# Initialiser
# ----------------------------------------------------------------------------
sub _init {
  my $self = shift;
  my $dbfp = shift; # Database file path
  my $opts = shift; # Options hash

  # Initialisation for base
  $self->SUPER::_init($dbfp, $opts);
  # Initialise hash recording cache table information
  $self->{'ctbl'} = {};
  ## Initialise cache persistent metadata table
  if (not $self->tableexists('FilePropertiesCacheMetaData')) {
    $self->definetable('FilePropertiesCacheMetaData',
		      ['Attribute TEXT', 'Value TEXT']);
    $self->cmetadata('File::Properties::Cache::Version', $VERSION);
  }
}


# ----------------------------------------------------------------------------
# Define cache table
# ----------------------------------------------------------------------------
sub define {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $cols = shift; # Array of column specifications of form: Name Type
  my $opts = shift; # Define options

  # Set flag indicating whether insertion date column and an
  # associated trigger should be added to the table
  my $dtrg = (defined $opts and defined $opts->{'IncludeInsertDate'})?
    $opts->{'IncludeInsertDate'}:0;
  # Make record of insertion date flag, and initialise properties hash
  # for new table
  $self->{'ctbl'}->{$tbnm} = {'dtrg' => $dtrg, 'props' => {}};
  ## If table does not exist, initialise it
  if (!$self->tableexists($tbnm)) {
    # Add insertion date column to table definition if flag set
    push @$cols, 'InsertDate DATE' if ($dtrg);
    # Define the database table
    $self->definetable($tbnm, $cols);
    # Create the insertion date trigger if flag set
    $self->createinsertdatetrigger($tbnm, 'InsertDate') if ($dtrg);
    # Create a table version entry in the persistent metadata if
    # details provided
    $self->cmetadata($opts->{'TableVersion'}->[0],$opts->{'TableVersion'}->[1])
      if defined $opts and defined $opts->{'TableVersion'};
  }
}


# ----------------------------------------------------------------------------
# Create insertion date trigger
# ----------------------------------------------------------------------------
sub createinsertdatetrigger {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $tcol = shift; # Name of column for date insertion

  my $trgn = $tbnm . "InsertDate";
  my $sqlc = <
CREATE TRIGGER IF NOT EXISTS $trgn AFTER INSERT ON $tbnm
BEGIN
  UPDATE $tbnm SET $tcol = STRFTIME('%Y-%m-%d','NOW')
    WHERE rowid = new.rowid;
END
EOF
  return $self->sql($sqlc);
}


# ----------------------------------------------------------------------------
# Insert a cache entry
# ----------------------------------------------------------------------------
sub cinsert {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $tbrw = shift; # Hash of column values to insert

  return $self->insert($tbnm, {'Data'=> $tbrw});
}


# ----------------------------------------------------------------------------
# Retrieve a cache entry
# ----------------------------------------------------------------------------
sub cretrieve {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $tkey = shift; # Hash of key columns and corresponding key values

  return $self->retrieve($tbnm, {'Where' => $tkey,
				 'FirstRow' => 1,
				 'ReturnType' => 'Hash'});
}


# ----------------------------------------------------------------------------
# Get (or set) cache properties (non-persistent metadata)
# ----------------------------------------------------------------------------
sub cproperties {
  my $self = shift;
  my $tbnm = shift; # Table name
  my $pnam = shift; # Property name

  $self->{'ctbl'}->{$tbnm}->{'props'}->{$pnam} = shift if (@_);
  return $self->{'ctbl'}->{$tbnm}->{'props'}->{$pnam};
}


# ----------------------------------------------------------------------------
# List of cache entries older than a specified number of days
# ----------------------------------------------------------------------------
sub expirelist {
   my $self = shift;
   my $tbnm = shift; # Table name
   my $nday = shift; # Expiry age in number of days

   ## Date based expiry is only possible if the table has an insertion
   ## date field with insertion trigger
   if ($self->{'ctbl'}->{$tbnm}->{'dtrg'}) {
     return $self->retrieve($tbnm,
			    {'Where' =>
			     "julianday('NOW')-julianday(InsertDate)>$nday",
			     'ReturnType' => 'Array'});
   } else {
     return [];
   }
}


# ----------------------------------------------------------------------------
# Expire cache entries older than a specified number of days
# ----------------------------------------------------------------------------
sub expire {
   my $self = shift;
   my $tbnm = shift; # Table name
   my $nday = shift; # Expiry age in number of days

   ## Date based expiry is only possible if the table has an insertion
   ## date field with insertion trigger
   if ($self->{'ctbl'}->{$tbnm}->{'dtrg'}) {
     $self->remove($tbnm,{'Where' =>
                          "julianday('NOW') - julianday(InsertDate) > $nday"});
   }
}


# ----------------------------------------------------------------------------
# Get (or set) cache persistent metadata
# ----------------------------------------------------------------------------
sub cmetadata {
  my $self = shift;
  my $atrb = shift; # Attribute name

  # Attempt to retrieve the cache persistent metadata table entry
  # corresponding to the specified attribute name
  my $row = $self->retrieve('FilePropertiesCacheMetaData',
			    {'Where' => {'Attribute' => $atrb},
			     'FirstRow' => 1, 'ReturnType' => 'Array'});
  ## If a second argument is provided to the method, it is used as a
  ## new attribute value for the specified attribute name
  if (@_) {
    ## The second argument for the method is used as a new attribute
    ## value for the specified attribute name. If the table row for the
    ## attribute name exists, update the row, otherwise insert a new
    ## row.
    if (defined $row) {
      $self->update('FilePropertiesCacheMetaData',
		    {'Data' => {'Attribute' => $atrb, 'Value' => shift}});
    } else {
      $self->insert('FilePropertiesCacheMetaData',
		    {'Data' => {'Attribute' => $atrb, 'Value' => shift}});
    }
  } else {
    # If a new attribute value is not specified, return the current
    # value of the specified attribute, or undef if the attribute
    # entry does not exist
    return (defined $row)?$row->[1]:undef;
  }
}


# ----------------------------------------------------------------------------
# Determine whether array includes the specified value
# ----------------------------------------------------------------------------
sub _inarray {
  my $aref = shift;
  my $eval = shift;

  my $hash = {};
  my $a;
  foreach $a (@$aref) {
    $hash->{$a} = 1;
  }
  return $hash->{$eval};
}


# ----------------------------------------------------------------------------
# End of method definitions
# ----------------------------------------------------------------------------


1;
__END__