view release on metacpan or  search on metacpan

lib/App/Cache.pm  view on Meta::CPAN

package App::Cache;
use strict;
use warnings;
use File::Find::Rule;
use File::HomeDir;
use File::Path qw( mkpath );
use File::stat;
use HTTP::Cookies;
use LWP::UserAgent;
use Path::Class;
use Storable qw(nstore retrieve);
use base qw( Class::Accessor::Chained::Fast );
__PACKAGE__->mk_accessors(qw( application directory ttl enabled ));
our $VERSION = '0.37';

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new(@_);

    unless ( $self->application ) {
        my $caller = (caller)[0];
        $self->application($caller);
    }

    unless ( $self->directory ) {
        my $dir = dir( home(), "." . $self->_clean( $self->application ),
            "cache" );
        $self->directory($dir);
    }
    my $dir = $self->directory;
    unless ( -d "$dir" ) {
        mkpath("$dir")
            || die "Error mkdiring " . $self->directory . ": $!";
    }

    unless ( defined $self->enabled ) {
        $self->enabled(1);
    }

    return $self;
}

sub clear {
    my $self = shift;
    foreach
        my $filename ( File::Find::Rule->new->file->in( $self->directory ) )
    {
        unlink($filename) || die "Error unlinking $filename: $!";
    }
    foreach my $dirname ( sort { length($b) <=> length($a) }
        File::Find::Rule->new->directory->in( $self->directory ) )
    {
        next if $dirname eq $self->directory;
        rmdir($dirname) || die "Error unlinking $dirname: $!";
    }
}

sub delete {
    my ( $self, $key ) = @_;
    my $filename = $self->_clean_filename($key);
    return unless -f $filename;
    unlink($filename) || die "Error unlinking $filename: $!";
}

sub get {
    my ( $self, $key ) = @_;
    return unless $self->enabled;
    my $ttl = $self->ttl || 60 * 30;               # default ttl of 30 minutes
    my $filename = $self->_clean_filename($key);
    return undef unless -f $filename;
    my $now   = time;
    my $stat  = stat($filename) || die "Error stating $filename: $!";
    my $ctime = $stat->ctime;
    my $age   = $now - $ctime;
    if ( $age < $ttl ) {
        my $value = retrieve("$filename")
            || die "Error reading from $filename: $!";
        return $value->{value};