view release on metacpan or  search on metacpan

lib/File/DataClass/Cache.pm  view on Meta::CPAN

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 {

lib/File/DataClass/Cache.pm  view on Meta::CPAN

   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__

=pod

=head1 Name

File::DataClass::Cache - Accessors and mutators for the cache object

=head1 Synopsis

   package File::DataClass::Schema;

   use Moo;
   use File::DataClass::Types qw(Cache);
   use File::DataClass::Cache;

   has 'cache'            => is => 'lazy', isa => Cache;

   has 'cache_attributes' => is => 'ro', isa => 'HashRef',
      default             => sub { return {} };

   my $_cache_objects = {};

   sub _build_cache {
      my $self  = shift; (my $ns = lc __PACKAGE__) =~ s{ :: }{-}gmx; my $cache;

      my $attrs = { cache_attributes => { %{ $self->cache_attributes } },
                    builder          => $self };

      $ns    = $attrs->{cache_attributes}->{namespace} ||= $ns;
      exists $_cache_objects->{ $ns } and return $_cache_objects->{ $ns };
      $self->cache_class eq 'none' and return Class::Null->new;
      $attrs->{cache_attributes}->{share_file}
           ||= NUL.$self->tempdir->catfile( "${ns}.dat" );

      return $_cache_objects->{ $ns } = $self->cache_class->new( $attrs );
   }

=head1 Description

Adds meta data and compound keys to the L<CHI> caching API. In instance of
this class is created by L<File::DataClass::Schema>

=head1 Configuration and Environment

The class defines these attributes

=over 3

=item C<cache>

An instance of the L<CHI> cache object

=item C<cache_attributes>

A hash ref passed to the L<CHI> constructor

=item C<cache_class>

The class name of the cache object, defaults to L<CHI>

=item C<log>

Log object which defaults to L<Class::Null>

=back

=head1 Subroutines/Methods

=head2 BUILDARGS

Constructs the attribute hash passed to the constructor method.

=head2 get

   ($data, $meta) = $schema->cache->get( $key );

Returns the data and metadata associated with the given key. If no cache
entry exists the data returned is C<undef> and the metadata is a hash ref