cache FETCH in memory to demonstrate preformance improvement

[koha.git] / misc / plack / lib / Memoize / Memcached.pm

package Memoize::Memcached;

use strict;
use warnings;

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

our $VERSION = '0.03';

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

warn "## FIXME ",__PACKAGE__, " patched with in-memory cache for fetch!";

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 isa($memcached_args, '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).

warn "## flush_cache";

  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 isa($memcached_config, '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);
warn "## STORE $key $value";
  return $self;
}

our $cache;

sub FETCH {
  my $self = shift;
  my $key = $self->_get_key(shift);
  if ( exists $cache->{$key} ) {
        $Koha::Persistant::stats->{memcache_FETCH}->[0]++;
        return $cache->{$key};
  }
  $Koha::Persistant::stats->{memcache_FETCH}->[1]++;
warn "## FETCH $key";
  my $v = $self->{memcached_obj}->get($key);
  $cache->{$key} = $v;
  return $v;
}

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


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


sub CLEAR {
  my $self = shift;
  # This is not safe because all object share memcached setup.
  $self->{memcached_obj}->flush_all;
warn "## CLEAR";
  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__

=head1 NAME

Memoize::Memcached - use a memcached cache to memoize functions


=head1 SYNOPSIS

    use Memoize::Memcached
      memcached => {
        servers => [ '127.0.0.1:11211' ],
      };

    memoize_memcached('foo');

    # Function 'foo' is now memoized using the memcached server
    # running on 127.0.0.1:11211 as the cache.


=head1 WARNING

The way C<flush_cache> works with memcached can be dangerous.  Please
read the documentation below on C<flush_cache>.


=head1 EXPORT

This module exports C<memoize_memcached>, C<flush_cache>, and
C<unmemoize>.  The C<unmemoize> function is just the one from Memoize,
and is made available for convenience.


=head1 FUNCTIONS

=head2 memoize_memcached

This is the memcached equivalent of C<memoize>.  It works very
similarly, except for some difference in options.

If the C<LIST_CACHE> or C<SCALAR_CACHE> options are passed in,
C<memoize_memcached> will complain and then pass the request along to
C<memoize>.  The result will be a memoized function, but using
whatever cache you specified and NOT using memcached at all.

This function also accepts a C<memcached> option, which expects a
hashref.  This is de-referenced and passed directly into an internal
function which sets up the memcached configuration for that function.
This contents of this hashref are mostly options passed to
C<Cache::Memcached>, with a few exceptions.

The actual key used to look up memoize data in memcached is formed
from the function name, the normalized arguments, and some additional
prefixes which can be set via the C<memcached> option.  These prefixes
are C<key_prefix>, C<list_key_prefix>, and C<scalar_key_prefix>.

The C<key_prefix> defaults to "memoize-" if it's not passed in, or an
undefined value is passed in.

The C<list_key_prefix> and C<scalar_key_prefix> options default to
"list-" and "scalar-" respectively, by the same criteria.

So, the default way the key is generated is:

  "memoize-<function>-list-<normalized args>"

or

  "memoize-<function>-scalar-<normalized args>"

The function and normalized args portion of this key are set
internally, but the "memoize-" prefix and the context portion can be
configured with memcached options as follows:

  "<key_prefix>-function-<list_key_prefix|scalar_key_prefix>-args"

Examples:

  memoize_memcached('foo');

  # keys generated will look like this:
  #  list context:   memoize-foo-list-<argument signature>
  #  scalar context: memoize-foo-scalar-<argument signature>

  memoize_memcached('foo',
    memcached => {
      servers => [ ... ],
      key_prefix        => '_M-',
      list_key_prefix   => 'L-',
      scalar_key_prefix => 'S-',
    },
    ;

  # keys generated will look like this:
  #  list context:   _M-foo-L-<argument signature>
  #  scalar context: _M-foo-S-<argument signature>

=head2 flush_cache

The behavior documented in C<Memoize> is sort of implemented.  A call
to C<flush_cache('memoized_function')> will indeed clear the cache of
all cached return values for that function, BUT it will also clear the
entire memcached cache, including all other memoized functions using
the same memcached cache, and even data unrelated to
C<Memoize::Memcached> in the same cache.  It will flush the entire
cache.

There are 2 new ways to call this function:

    flush_cache();

and

    flush_cache(memoized_function => qw( an argument signature ));

The call without arguments will flush the entire memcached cache, just
like the 1 argument version.  This includes unrelated data.  Be
careful.

The call with 2 or more arguments will flush only the cached return
values (array and scalar contexts) for a call to the function named
by the first argument with an argument signature matching the second
argument to the end.  Unlike the other 2 ways to call this function,
when called this way only the specified part of the cache is flushed.

I would recommended that only the 2 or more argument version of
C<flush_cache> be called unless you are very sure of what you are
doing.


=head1 GOTCHAS

The biggest gotcha is that you probably never want to call
C<flush_cache('memoized_function')>.  Because of the way C<CLEAR> is
implemented against memcached, this call will flush the entire
memcached cache.  Everything.  Even stuff having nothing to do with
C<Memoize::Memcached>.  You are warned.


=head1 TO-DO

A more intuitive interface for handling different memcached server
configurations would probably be useful.


=head1 AUTHOR

David Trischuk, C<< <trischuk at gmail.com> >>


=head1 BUGS

Please report any bugs or feature requests to C<bug-memoize-memcached at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Memoize-Memcached>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Memoize::Memcached

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Memoize-Memcached>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Memoize-Memcached>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Memoize-Memcached>

=item * Search CPAN

L<http://search.cpan.org/dist/Memoize-Memcached>

=back


=head1 ACKNOWLEDGMENTS

The tied hash portion of this module is heavily based on
C<Cache::Memcached::Tie> by Andrew Kostenko.


=head1 COPYRIGHT & LICENSE

Copyright 2008 David Trischuk, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut