File Coverage

blib/lib/Gantry/Plugins/Cache/Storable.pm

Criterion	Covered	Total	%
statement	15	100	15.0
branch	0	46	0.0
condition	0	12	0.0
subroutine	5	17	29.4
pod	12	12	100.0
total	32	187	17.1

package Gantry::Plugins::Cache::Storable;

use strict;
use warnings;

use Storable qw(store nstore_fd fd_retrieve retrieve freeze thaw dclone);
use Gantry::Plugins::Cache;

use base 'Exporter';
our @EXPORT = qw(
    cache_clear
    cache_del
    cache_get
    cache_set
    cache_keys
    cache_init
    cache_purge
    cache_handle
    cache_inited
    cache_expires
    cache_namespace
    cache_filename
);

sub cache_init {
    my ($gobj) = @_;

    #my $num_pages   = $gobj->fish_config('cache_pages') || '256';
    #my $page_size   = $gobj->fish_config('cache_pagesize') || '256k';
    #my $expire_time = $gobj->fish_config('cache_expires') || '1h';

    my $test_sets  = $gobj->fish_config('cache_test_sets') || 0;
    my $share_file = $gobj->fish_config('cache_filename')
        || '/tmp/gantry.storable.cache';

    $gobj->cache_filename( $share_file );
    $gobj->cache_inited(1);

    # If requested, test cache sets to see if they are successful.
    if ($test_sets) {
        eval {
            # Set test.
            $gobj->cache_set('test-ns:test-var', 1, 120);

            # Get test.
            my $data = $gobj->cache_get('test-ns:test-var');

            # Die if set failed.
            unless ($data) {
                die "Test cache set failed. Please check cache configuration parameters.\n";
            }
        };

        if ($@) {
            die('Unable to use - Gantry::Cache::Storable ' . $@ );
        }
    }
}

sub cache_inited {
    my ($gobj, $p) = @_;

    $$gobj{__CACHE_INITED__} = $p if defined $p;
    return($$gobj{__CACHE_INITED__});

}

sub cache_filename {
    my ($gobj, $p) = @_;

    $$gobj{__CACHE_FILENAME__} = $p if defined $p;
    return($$gobj{__CACHE_FILENAME__});

}

sub cache_handle {
    my ($gobj, $p) = @_;

    $$gobj{__CACHE_HANDLE__} = $p if defined $p;
    return($$gobj{__CACHE_HANDLE__});

}

sub cache_namespace {
    my ($gobj, $p) = @_;

    $$gobj{__CACHE_NAMESPACE__} = $p if defined $p;
    return($$gobj{__CACHE_NAMESPACE__});

}

sub cache_expires {
    my ($gobj, $p) = @_;

    $$gobj{__CACHE_EXPIRES__} = $p if defined $p;
    return($$gobj{__CACHE_EXPIRES__});

}

sub cache_get {
    my ($gobj, $key) = @_;

    my $namespace   = $gobj->cache_namespace() || '';
    my $skey        = $namespace . ':' . $key;
    my $file        = $gobj->cache_filename;

    if ( -e $file ) {

        open( CACHE, $file ) or die "$!";
        my $serialized = fd_retrieve( \*CACHE ) or die "retrieve error $!";
        close( CACHE );

        my $storable = thaw( $$serialized );

        if ( defined $storable->{$skey} ) {
            return( $storable->{$skey} );
        }
        else {
            return;
        }
    }

}

sub cache_set {
    my ($gobj, $key, $val, $expires) = @_;

    my $namespace = $gobj->cache_namespace() || '';
    my $skey      = $namespace . ':' . $key;
    my $file      = $gobj->cache_filename;

    my $serialized;

    if ( ! -e $file ) {

        my $storable = {
            $skey => $val
        };

        $serialized = freeze( $storable );
    }
    else {
        my $tmp_serialized = retrieve( $file ) or die "retrieve error $!";
        my $storable       = thaw( $$tmp_serialized );
        $storable->{$skey} = $val;
        $serialized        = freeze( $storable );
    }

    open( CACHE, ">", $file ) or die "$!";
    nstore_fd( \$serialized, \*CACHE ) or die "Can't store $key!\n";
    close( CACHE );
}

sub cache_clear {
    my($gobj) = @_;

    my $file =  $gobj->cache_filename();

    if ( -e $file ) {
        unlink( $file );
    }
}

sub cache_keys {
    my($gobj ) = @_;

    my $file        = $gobj->cache_filename();
    my $namespace   = $gobj->cache_namespace() || '';

    my @keys_new;

    if ( -e $file ) {

        my $tmp_serialized = retrieve( $file ) or die "retrieve error $!";
        my $storable = thaw( $$tmp_serialized );

        foreach my $k ( keys %{ $storable } ) {
            $k =~ s/^$namespace\://;
            push( @keys_new, $k );
        }
    }

    return \@keys_new;
}

sub cache_del {
    my ($gobj, $key) = @_;

    my $namespace = $gobj->cache_namespace() || '';
    my $skey      = $namespace . ':' . $key;
    my $file      = $gobj->cache_filename();

    if ( -e $file ) {
        my $tmp_serialized = retrieve( $file ) or die "retrieve error $!";
        my $storable         = thaw( $$tmp_serialized );
        delete( $storable->{$skey} );
        my $serialized      = freeze( $storable );

        open( CACHE, ">", $file ) or die "$!";
        nstore_fd( \$serialized, \*CACHE ) or die "Can't store $key!\n";
        close( CACHE );
    }
}

sub cache_purge {
    my ($gobj) = @_;

    return;

}

1;

__END__