File Coverage

lib/File/DataClass/Cache.pm

Criterion	Covered	Total	%
statement	63	63	100.0
branch	15	16	93.7
condition	2	2	100.0
subroutine	19	19	100.0
pod	7	7	100.0
total	106	107	99.0

package File::DataClass::Cache;

use 5.01;
use namespace::autoclean;

use File::DataClass::Constants qw( FALSE NUL SPC TRUE );
use File::DataClass::Functions qw( merge_attributes throw );
use File::DataClass::Types     qw( Bool Cache ClassName HashRef
                                   LoadableClass Object Str );
use Storable                   qw( freeze );
use Try::Tiny;
use Moo;

# Public attributes
has 'cache'            => is => 'lazy', isa => Object, builder => sub {
   $_[ 0 ]->cache_class->new( %{ $_[ 0 ]->cache_attributes } ) };

has 'cache_attributes' => is => 'ro',   isa => HashRef, required => TRUE;

has 'cache_class'      => is => 'lazy', isa => LoadableClass,
   default             => 'Cache::FastMmap';

has 'log'              => is => 'ro',   isa => Object, required => TRUE;

# Private attributes
has '_mtimes_key'      => is => 'ro',   isa => Str, default => '_mtimes';

# Construction
around 'BUILDARGS' => sub {
   my ($orig, $class, @args) = @_; my $attr = $orig->( $class, @args );

   $attr->{cache_attributes} //= {}; my $cache_class;

   $cache_class = delete $attr->{cache_attributes}->{cache_class}
      and $attr->{cache_class} = $cache_class;

   my $builder = delete $attr->{builder} or return $attr;

   merge_attributes $attr, $builder, [ 'log' ];

   return $attr;
};

# Private methods
my $_get_key_and_newest = sub {
   my ($self, $paths) = @_; my $newest = 0; my $is_valid = TRUE; my $key;

   for my $path (grep { defined && length "${_}" } @{ $paths }) {
      my $mtime = $self->get_mtime( "${path}" ) or $is_valid = FALSE;

      ($mtime and $path->exists and $mtime == $path->stat->{mtime})
         or $is_valid = FALSE;
      $mtime and $mtime > $newest and $newest = $mtime;
      $key .= $key ? "~${path}" : "${path}";
   }

   return ($key, $is_valid ? $newest : undef);
};

# Public methods
sub get {
   my ($self, $key) = @_; $key .= NUL;

   my $cached = $key ? $self->cache->get( $key ) : FALSE;

   $cached and return ($cached->{data}, $cached->{meta});

   return (undef, { mtime => undef });
}

sub get_by_paths {
   my ($self, $paths) = @_;
   my ($key, $newest) = $self->$_get_key_and_newest( $paths );

   return ($self->get( $key ), $newest);
}

sub get_mtime {
   my ($self, $k) = @_; $k or return;

   my $mtimes = $self->cache->get( $self->_mtimes_key ) or return;

   return $mtimes->{ $k };
}

sub remove {
   my ($self, $key) = @_; defined $key or return;

   $self->cache->remove( $key ); $self->set_mtime( $key, undef );

   return;
}

sub set {
   my ($self, $key, $data, $meta) = @_; $meta //= { mtime => undef };

   my $val = { data => $data, meta => $meta };

   try {
      $key eq $self->_mtimes_key and throw 'key not allowed';
      $self->cache->set( $key, $val ) or throw 'set operation returned false';
      $self->set_mtime( $key, $meta->{mtime} );
   }
   catch {
      my $len = length( $key ) + length( freeze $val );

      $self->log->error( "Cache key ${key}(${len}) set failed: ${_}" );
   };

   return ($data, $meta);
}

sub set_by_paths {
   my ($self, $paths, $data, $meta) = @_;

   my ($key, $newest) = $self->$_get_key_and_newest( $paths );

   $meta->{mtime} = $newest;

   return $self->set( $key, $data, $meta );
}

sub set_mtime {
   my ($self, $k, $v) = @_;

   return $self->cache->get_and_set( $self->_mtimes_key, sub {
      my (undef, $mtimes) = @_;

      if (defined $v) { $mtimes->{ $k } = $v } else { delete $mtimes->{ $k } }

      return $mtimes;
   } );
}

1;

__END__