File Coverage

blib/lib/Memoize/Memcached.pm

Criterion	Covered	Total	%
statement	36	141	25.5
branch	3	50	6.0
condition	2	7	28.5
subroutine	10	27	37.0
pod	2	2	100.0
total	53	227	23.3

package Memoize::Memcached;

use strict;
use warnings;

use Carp qw( carp croak );
use Memoize qw( unmemoize );
use Cache::Memcached;

our $VERSION = '0.04';

use Data::Dumper;
$Data::Dumper::Sortkeys = 1;


use base 'Exporter';

our @EXPORT = qw( memoize_memcached );
our @EXPORT_OK = qw( unmemoize flush_cache );
our %EXPORT_TAGS = (
  all => [ @EXPORT, @EXPORT_OK ],
);


use fields qw(
  key_prefix
  expire_time
  memcached_obj
  key_error
  scalar_error
);



my %memo_data;
my %memcached_config;


sub memoize_memcached {
  # Be sure to leave @_ intact in case we need to redirect to
  # 'Memoize::memoize'.
  my ($function, %args) = @_;

  if (exists $args{LIST_CACHE} or exists $args{ARRAY_CACHE}) {
    carp "Call to 'memoize_memcached' with a cache option passed to 'memoize'";
    goto &Memoize::memoize;
  }

  my $memcached_args = delete $args{memcached} || {};
  croak "Invalid memcached argument (expected a hash)"
    unless ref $memcached_args eq 'HASH';

  _memcached_setup(
    %{$memcached_args},
    memoized_function => $function,
  );
  $args{LIST_CACHE} = [ HASH => $memo_data{$function}{list_cache} ];
  $args{SCALAR_CACHE} = [ HASH => $memo_data{$function}{scalar_cache} ];

  # If we are passed a normalizer, we need to keep a version of it
  # around for flush_cache to use.  This breaks encapsulation.  And it
  # is just plain ugly.
  $memo_data{$function}{normalizer} = Memoize::_make_cref($args{NORMALIZER}, scalar caller)
    if defined $args{NORMALIZER};

  # Rebuild @_ since there is a good probability we have removed some
  # arguments meant for us and added the cache arguments.
  @_ = ($function, %args);
  goto &Memoize::memoize;
}


# Unfortunately, we need to do some magic to make flush_cache sorta
# work.  I don't think this is enough magic yet.

sub flush_cache {
  # If we have exactly 1 argument then we are probably expected to
  # clear the cache for a single function.  Pass this along to
  # Memoize, even though it cannot be handled correctly at this time
  # (whatever we do will be wrong, anyway).

  goto &Memoize::flush_cache if @_ == 1;


  # If we have more than 1 argument, we are probably expected to clear
  # a single call signature for a function.  This we can almost do
  # properly.

  # Even though we can do this "properly", it is still very bad.  This
  # breaks encapsulation pretty disgustingly. With any luck Memoize
  # will eventually be patched to do this for us...

  if (@_ > 1) {
    my ($function, @args) = @_;
    my $cur_memo = $memo_data{$function};
    my $normalizer = $memo_data{$function}{normalizer};
    my $array_argstr;
    my $scalar_argstr;
    if (defined $normalizer) {
      ($array_argstr) = $normalizer->(@_);
      $scalar_argstr = $normalizer->(@_);
    }
    else { # Default normalizer
      local $^W = 0;
      $array_argstr = $scalar_argstr = join chr(28), @args;
    }
    for my $cache (qw( list_cache scalar_cache )) {
      for my $argstr ($scalar_argstr, $array_argstr) {
        delete $cur_memo->{$cache}{$argstr};
      }
    }
    return 1;
  }


  # Currently all memoized functions share memcached config, so just
  # find the first valid object and flush cache.

  for my $function (keys %memo_data) {
    next unless $memo_data{$function}{list_obj};
    $memo_data{$function}{list_obj}{memcached_obj}->flush_all;
    last;
  }

  return 1;
}


sub import {
  my ($class) = @_;

  # Search through the arg list for the 'memcached' arg, process it,
  # and remove it (and its associated value) from the arg list in
  # anticipation of passing off to Exporter.
  for my $idx ($[ + 1 .. $#_) {
    my $arg = $_[$idx] || q();
    next unless $arg eq 'memcached';
    (undef, my $memcached_config) = splice @_, $idx, 2;
    croak "Invalid memcached config (expected a hash ref)"
      unless ref $memcached_config eq 'HASH';
    %memcached_config = %{$memcached_config};
  }

  return $class->export_to_level(1, @_);
}


sub _memcached_setup {
  my %args = %memcached_config;
  while (@_) {
    my $key = shift;
    my $value = shift;
    $args{$key} = $value;
  }

  my $function = delete $args{memoized_function};
  my $list_key_prefix = delete $args{list_key_prefix};
  my $scalar_key_prefix = delete $args{scalar_key_prefix};

  $args{key_prefix} = 'memoize-' unless defined $args{key_prefix};

  croak "Missing function name for memcached setup"
    unless defined $function;
  my $tie_data = $memo_data{$function} = {
    list_obj => undef,
    list_cache => {},
    scalar_obj => undef,
    scalar_cache => {},
  };

  my %cur_args = %args;
  $cur_args{key_prefix}
    .= (defined $function ? "$function-" : '-')
    .  (defined $list_key_prefix ? $list_key_prefix : 'list-')
    ;
  $tie_data->{list_obj} = tie %{$tie_data->{list_cache}}, __PACKAGE__, %cur_args
    or die "Error creating list cache";

  %cur_args = %args;
  $cur_args{key_prefix}
    .= (defined $function ? "$function-" : '-')
    .  (defined $scalar_key_prefix ? $scalar_key_prefix : 'scalar-')
    ;
  $tie_data->{scalar_obj} = tie %{$tie_data->{scalar_cache}}, __PACKAGE__, %cur_args
    or die "Error creating scalar cache";

  return 1;
}


sub _new {
  my $class = shift;
  croak "Called new in object context" if ref $class;
  my $self = fields::new($class);
  $self->_init(@_);
  return $self;
}


sub _init {
  my $self = shift;
  my %args = @_;
  %{$self} = ();

  $self->{key_prefix} = delete $args{key_prefix};
  $self->{key_prefix} = q() unless defined $self->{key_prefix};
  $self->{expire_time} = exists $args{expire_time} ? delete $args{expire_time} : undef;

  # Default these to false so that we can use Data::Dumper on tied
  # hashes by default.  Yes, it will show them as empty, but I doubt
  # someone running Dumper on this tied hash would really want to dump
  # the contents of the memcached cache (and they can't anyway).

  $self->{$_} = exists $args{$_} ? delete $args{$_} : !1
    for qw( key_error scalar_error );

  $self->{memcached_obj} = Cache::Memcached->new(\%args);

  return $self;
}


sub _get_key {
  my $self = shift;
  my $key = shift;
  return $self->{key_prefix} . $key;
}


sub _key_lookup_error {
  croak "Key lookup functionality is not implemented by memcached";
}


sub TIEHASH {
  my $class = shift;
  return $class->_new(@_);
}


sub STORE {
  my $self = shift;
  my $key = $self->_get_key(shift);
  my $value = shift;
  my @args = ($key, $value);
  push @args, $self->{expire_time} if defined $self->{expire_time};
  $self->{memcached_obj}->set(@args);
  return $self;
}


sub FETCH {
  my $self = shift;
  my $key = $self->_get_key(shift);
  return $self->{memcached_obj}->get($key);
}


sub EXISTS {
  my $self = shift;
  return defined $self->FETCH(@_);
}


sub DELETE {
  my $self = shift;
  my $key = $self->_get_key(shift);
  $self->{memcached_obj}->delete($key);
  return $self;
}


sub CLEAR {
  my $self = shift;
  # This is not safe because all object share memcached setup.
  $self->{memcached_obj}->flush_all;
  return $self;
}


sub FIRSTKEY {
  my $self = shift;
  return unless $self->{key_error};
  $self->_key_lookup_error;
}


sub NEXTKEY {
  my $self = shift;
  return unless $self->{key_error};
  $self->_key_lookup_error;
}


sub SCALAR {
  my $self = shift;
  return unless $self->{scalar_error};
  # I think this error still makes sense, since to determine if the
  # cache has content one would need to first determine if the cache
  # contains keys.
  $self->_key_lookup_error;
}


sub UNTIE {
  my $self = shift;
  $self->{memcached_obj}->disconnect_all;
  return $self;
}



1;

__END__