| 1 |
package A3C::Cache; |
| 2 |
|
| 3 |
use strict; |
| 4 |
use warnings; |
| 5 |
|
| 6 |
use base qw(Jifty::Object Class::Accessor::Fast); |
| 7 |
__PACKAGE__->mk_accessors( qw(instance dir) ); |
| 8 |
use File::Slurp; |
| 9 |
use JSON::XS; |
| 10 |
use Carp qw/confess/; |
| 11 |
use Data::Dump qw/dump/; |
| 12 |
use Data::Structure::Util qw(unbless); |
| 13 |
use Clone qw/clone/; |
| 14 |
|
| 15 |
=head1 NAME |
| 16 |
|
| 17 |
A3C::Cache |
| 18 |
|
| 19 |
=head1 DESCRIPTION |
| 20 |
|
| 21 |
Fast JSON on-disk cache for long running operations |
| 22 |
|
| 23 |
B<Doesn't expire any file by itself!> |
| 24 |
|
| 25 |
=head1 METHODS |
| 26 |
|
| 27 |
=head2 new |
| 28 |
|
| 29 |
my $cache = A3C::Cache->new({ instance => 'foobar', dir => 'strix' }); |
| 30 |
|
| 31 |
=head2 cache_path |
| 32 |
|
| 33 |
Generate unique name for specified values |
| 34 |
|
| 35 |
my $path = $strix->cache_path( $var, ... ); |
| 36 |
|
| 37 |
Variables have to be path-safe (e.g. use C<uri_encode> if needed) |
| 38 |
|
| 39 |
=cut |
| 40 |
|
| 41 |
sub cache_path { |
| 42 |
my $self = shift; |
| 43 |
|
| 44 |
#warn "# cache_path",dump( @_ ); |
| 45 |
|
| 46 |
my $dir = $self->dir || 'strix'; |
| 47 |
|
| 48 |
my $path = Jifty::Util->absolute_path( "var/$dir" ); |
| 49 |
|
| 50 |
if ( ! -e $path ) { |
| 51 |
mkdir($path) || warn "can't create $path: $!"; |
| 52 |
} |
| 53 |
|
| 54 |
#warn "## caller = ",dump( (caller(2))[3] ); |
| 55 |
my $uid = (caller(2))[3] || ''; |
| 56 |
if ( $uid =~ s/^[^:]+::// ) { |
| 57 |
$uid .= '-'; |
| 58 |
} |
| 59 |
$uid .= join('-', @_) if @_; |
| 60 |
$uid .= '.js'; |
| 61 |
|
| 62 |
return $path . '/' . $self->instance . '-' . $uid; |
| 63 |
} |
| 64 |
|
| 65 |
our $json = JSON::XS->new; |
| 66 |
$json->utf8( 1 ); |
| 67 |
#$json->allow_nonref( 1 ); |
| 68 |
|
| 69 |
=head2 write_cache |
| 70 |
|
| 71 |
$self->write_cache( $data, $key_var, ... ); |
| 72 |
|
| 73 |
=cut |
| 74 |
|
| 75 |
sub write_cache { |
| 76 |
my $self = shift; |
| 77 |
my $data = shift || confess "no data?"; |
| 78 |
my $path = $self->cache_path( @_ ); |
| 79 |
#warn "# write_cache(",dump( $data )," , $path )"; |
| 80 |
if ( ref($data) ) { |
| 81 |
my $data2 = clone($data); |
| 82 |
unbless $data2; |
| 83 |
$data = $data2; |
| 84 |
} |
| 85 |
write_file( $path, $json->encode( $data )) || die "can't save into $path: $!"; |
| 86 |
} |
| 87 |
|
| 88 |
=head2 read_cache |
| 89 |
|
| 90 |
my $data = $self->read_cache( 'format-%d', $var ... ); |
| 91 |
|
| 92 |
=cut |
| 93 |
|
| 94 |
sub read_cache { |
| 95 |
my $self = shift; |
| 96 |
my $path = $self->cache_path( @_ ); |
| 97 |
return unless -e $path; |
| 98 |
#warn "# read_cache( $path )"; |
| 99 |
return $json->decode( read_file( $path ) ) || die "can't read $path: $!"; |
| 100 |
} |
| 101 |
|
| 102 |
1; |
Parent Directory
| 
Revision Log