--- /dev/null
+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;
+
+
+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).
+
+ 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);
+ 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__
+
+=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
projects / koha.git / commitdiff