File Coverage

blib/lib/CHI/Memoize.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package CHI::Memoize;
$CHI::Memoize::VERSION = '0.07';
use Carp;
use CHI;
use CHI::Memoize::Info;
use CHI::Driver;
use Hash::MoreUtils qw(slice_grep);
use strict;
use warnings;
use base qw(Exporter);

my $no_memoize = {};
sub NO_MEMOIZE { $no_memoize }

our @EXPORT      = qw(memoize);
our @EXPORT_OK   = qw(memoize memoized unmemoize NO_MEMOIZE);
our %EXPORT_TAGS = ( all => \@EXPORT_OK );

my %memoized;
my @get_set_options = qw( busy_lock expire_if expires_at expires_in expires_variance );
my %is_get_set_option = map { ( $_, 1 ) } @get_set_options;

sub memoize {
    my ( $func, %options ) = @_;

    my ( $func_name, $func_ref, $func_id ) = _parse_func_arg( $func, scalar(caller) );
    croak "'$func_id' is already memoized" if exists( $memoized{$func_id} );

    my $passed_key      = delete( $options{key} );
    my $cache           = delete( $options{cache} );
    my %compute_options = slice_grep { $is_get_set_option{$_} } \%options;
    my $prefix          = "memoize::$func_id";

    if ( !$cache ) {
        my %cache_options = slice_grep { !$is_get_set_option{$_} } \%options;
        $cache_options{namespace} ||= $prefix;
        if ( !$cache_options{driver} && !$cache_options{driver_class} ) {
            $cache_options{driver} = "Memory";
        }
        if ( $cache_options{driver} eq 'Memory' || $cache_options{driver} eq 'RawMemory' ) {
            $cache_options{global} = 1;
        }
        $cache = CHI->new(%cache_options);
    }

    my $wrapper = sub {
        my $wantarray = wantarray ? 'L' : 'S';
        my @key_parts =
          defined($passed_key)
          ? ( ( ref($passed_key) eq 'CODE' ) ? $passed_key->(@_) : ($passed_key) )
          : @_;
        if ( @key_parts == 1 && ( $key_parts[0] || 0 ) eq NO_MEMOIZE ) {
            return $func_ref->(@_);
        }
        else {
            my $key = [ $prefix, $wantarray, @key_parts ];
            my $args = \@_;
            return $cache->compute( $key, {%compute_options}, sub { $func_ref->(@$args) } );
        }
    };
    $memoized{$func_id} = CHI::Memoize::Info->new(
        orig       => $func_ref,
        wrapper    => $wrapper,
        cache      => $cache,
        key_prefix => $prefix
    );

    no strict 'refs';
    no warnings 'redefine';
    *{$func_name} = $wrapper if $func_name;

    return $wrapper;
}

sub memoized {
    my ( $func_name, $func_ref, $func_id ) = _parse_func_arg( $_[0], scalar(caller) );
    return $memoized{$func_id};
}

sub unmemoize {
    my ( $func_name, $func_ref, $func_id ) = _parse_func_arg( $_[0], scalar(caller) );
    my $info = $memoized{$func_id} or die "$func_id is not memoized";

    eval { $info->cache->clear() };
    no strict 'refs';
    no warnings 'redefine';
    *{$func_name} = $info->orig if $func_name;
    delete( $memoized{$func_id} );
    return $info->orig;
}

sub _parse_func_arg {
    my ( $func, $caller ) = @_;
    my ( $func_name, $func_ref, $func_id );
    if ( ref($func) eq 'CODE' ) {
        $func_ref = $func;
        $func_id  = "$func_ref";
    }
    else {
        $func_name = $func;
        $func_name = join( "::", $caller, $func_name ) if $func_name !~ /::/;
        $func_id   = $func_name;
        no strict 'refs';
        $func_ref = \&$func_name;
        die "no such function '$func_name'" if ref($func_ref) ne 'CODE';
    }
    return ( $func_name, $func_ref, $func_id );
}

1;

__END__