—# @(#)$Id: Cache.pm 351 2012-03-28 23:57:08Z pjf $
package
File::DataClass::Cache;
use
strict;
use
namespace::autoclean;
use
Moose;
use
CHI;
has
'cache'
=>
is
=>
'ro'
,
isa
=>
'Object'
,
lazy_build
=> TRUE;
has
'cache_attributes'
=>
is
=>
'ro'
,
isa
=>
'HashRef'
,
default
=>
sub
{
return
{} };
has
'cache_class'
=>
is
=>
'ro'
,
isa
=>
'ClassName'
,
default
=>
q(CHI)
;
has
'debug'
=>
is
=>
'ro'
,
isa
=>
'Bool'
,
default
=> FALSE;
has
'log'
=>
is
=>
'ro'
,
isa
=>
'Object'
,
default
=>
sub
{ Class::Null->new };
has
'_mtimes_key'
=>
is
=>
'ro'
,
isa
=>
'Str'
,
default
=>
q(_mtimes)
;
around
BUILDARGS
=>
sub
{
my
(
$next
,
$class
,
@rest
) =
@_
;
my
$attrs
=
$class
->
$next
(
@rest
);
exists
$attrs
->{ioc_obj} or
return
$attrs
;
my
$ioc
=
delete
$attrs
->{ioc_obj};
my
@attrs
= (
qw(debug log)
);
$attrs
->{
$_
} ||=
$ioc
->
$_
()
for
(
grep
{
$ioc
->can(
$_
) }
@attrs
);
return
$attrs
;
};
sub
get {
my
(
$self
,
$key
) =
@_
;
$key
.= NUL;
my
$cached
=
$key
?
$self
->cache->get(
$key
) : FALSE;
my
$data
=
$cached
?
$cached
->{data} :
undef
;
my
$meta
=
$cached
?
$cached
->{meta} : {
mtime
=>
undef
};
return
(
$data
,
$meta
);
}
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 ) || {};
return
$mtimes
->{
$k
};
}
sub
remove {
my
(
$self
,
$key
) =
@_
;
$key
or
return
;
$key
.= NUL;
$self
->cache->remove(
$key
);
$self
->set_mtime(
$key
,
undef
);
return
;
}
sub
set {
my
(
$self
,
$key
,
$data
,
$meta
) =
@_
;
my
$mt_key
=
$self
->_mtimes_key;
$key
.= NUL;
$meta
||= {};
$meta
->{mtime} ||=
undef
;
$key
eq
$mt_key
and
$self
->throw(
error
=>
'Cache key "[_1]" not allowed'
,
args
=> [
$mt_key
] );
if
(
$key
and
defined
$data
) {
$self
->cache->set(
$key
, {
data
=>
$data
,
meta
=>
$meta
} );
$self
->set_mtime(
$key
,
$meta
->{mtime} );
}
return
(
$data
,
$meta
);
}
sub
set_by_paths {
my
(
$self
,
$paths
,
$data
,
$meta
) =
@_
;
$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
) =
@_
;
my
$mtimes
=
$self
->cache->get(
$self
->_mtimes_key ) || {};
if
(
defined
$v
) {
$mtimes
->{
$k
} =
$v
}
else
{
delete
$mtimes
->{
$k
} }
return
$self
->cache->set(
$self
->_mtimes_key,
$mtimes
);
}
# Private methods
sub
_build_cache {
my
$self
=
shift
;
my
$attrs
=
$self
->cache_attributes;
my
$log
=
$self
->
log
;
my
$class
=
delete
$attrs
->{cache_class} ||
$self
->cache_class;
$attrs
->{on_set_error} =
sub
{
$log
->error(
$_
[ 0 ] ) };
return
$class
->new( %{
$attrs
} );
}
sub
_get_key_and_newest {
my
(
$self
,
$paths
) =
@_
;
my
$newest
= 0;
my
$valid
= TRUE;
my
$key
;
for
my
$path
(
grep
{
length
}
map
{ NUL.
$_
} @{
$paths
}) {
$key
.=
$key
?
q(~)
.
$path
:
$path
;
my
$mtime
=
$self
->get_mtime(
$path
);
if
(
$mtime
) {
$mtime
>
$newest
and
$newest
=
$mtime
}
else
{
$valid
= FALSE }
}
return
(
$key
,
$valid
?
$newest
:
undef
);
}
__PACKAGE__->meta->make_immutable;
no
Moose;
1;
__END__
=pod
=head1 Name
File::DataClass::Cache - Adds extra methods to the CHI API
=head1 Version
0.8.$Revision: 351 $
=head1 Synopsis
package File::DataClass::Schema;
use File::DataClass::Cache;
use Moose;
extends qw(File::DataClass);
with qw(File::DataClass::Util);
has 'cache' => is => 'ro', isa => 'F_DC_Cache',
lazy_build => TRUE;
has 'cache_attributes' => is => 'ro', isa => 'HashRef',
default => sub { return {} };
sub _build_cache {
my $self = shift;
$self->Cache and return $self->Cache;
my $attrs = {}; (my $ns = lc __PACKAGE__) =~ s{ :: }{-}gmx;
$attrs->{cache_attributes} = $self->cache_attributes;
$attrs->{cache_attributes}->{driver } ||= q(FastMmap);
$attrs->{cache_attributes}->{root_dir } ||= NUL.$self->tempdir;
$attrs->{cache_attributes}->{namespace} ||= $ns;
return $self->Cache( File::DataClass::Cache->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 B<cache>
An instance of the L<CHI> cache object
=item B<cache_attributes>
A hash ref passed to the L<CHI> constructor
=item B<cache_class>
The class name of the cache object, defaults to L<CHI>
=back
=head1 Subroutines/Methods
=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
with a key of C<mtime> and a value of C<0>
=head2 get_by_paths
($data, $meta, $newest) = $schema->cache->get_by_paths( $paths );
The paths passed in the array ref are concatenated to form a compound key.
The L<CHI> cache entry is fetched and the data and meta data returned along
with the modification time of the newest file in the list of paths
=head2 get_mtime
$mod_time = $schema->cache->get_mtime( $key );
Returns the mod time of a file if it's in the cache. Returns undef if it is not.
Returns zero if the filesystem was checked and the file did not exist
=head2 remove
$schema->cache->remove( $key );
Removes the L<CHI> cache entry for the given key
=head2 set
($data, $meta) = $schema->cache->set( $key, $data, $meta );
Sets the L<CHI> cache entry for the given key
=head2 set_by_paths
($data, $meta) = $schema->cache->set_by_paths( $paths, $data, $meta );
Set the L<CHI> cache entry for the compound key formed from the array ref
C<$paths>
=head2 set_mtime
$schema->cache->set_mtime( $key, $value );
Sets the mod time in the cache for the given key. Setting the mod time to
zero means the filesystem was checked and the file did not exist
=head2 _get_key_and_newest
($key, $newest) = $schema->cache->_get_key_and_newest( $paths );
Creates a key from the array ref of path names and also returns the most
recent mod time. Will return undef for newest if the cache entry is invalid
=head1 Diagnostics
None
=head1 Dependencies
=over 3
=item L<CHI>
=back
=head1 Incompatibilities
There are no known incompatibilities in this module
=head1 Bugs and Limitations
There are no known bugs in this module.
Please report problems to the address below.
Patches are welcome
=head1 Acknowledgements
Larry Wall - For the Perl programming language
=head1 Author
Peter Flanigan, C<< <Support at RoxSoft.co.uk> >>
=head1 License and Copyright
Copyright (c) 2012 Peter Flanigan. All rights reserved
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>
This program is distributed in the hope that it will be useful,
but WITHOUT WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
=cut
# Local Variables:
# mode: perl
# tab-width: 3
# End: