@@ -, +, @@ --- misc/plack/lib/Memoize/Memcached.pm | 530 ++++++++++++++++++++ .../plack/lib/Plack/Middleware/Debug/Devel/Size.pm | 1 + misc/plack/lib/Plack/Middleware/Debug/Koha.pm | 22 + .../plack/lib/Plack/Middleware/Debug/Persistant.pm | 26 + .../plack/lib/Plack/Middleware/Profiler/NYTProf.pm | 1 + 5 files changed, 580 insertions(+), 0 deletions(-) create mode 100644 misc/plack/lib/Memoize/Memcached.pm create mode 120000 misc/plack/lib/Plack/Middleware/Debug/Devel/Size.pm create mode 100644 misc/plack/lib/Plack/Middleware/Debug/Koha.pm create mode 100644 misc/plack/lib/Plack/Middleware/Debug/Persistant.pm create mode 120000 misc/plack/lib/Plack/Middleware/Profiler/NYTProf.pm --- a/misc/plack/lib/Memoize/Memcached.pm +++ a/misc/plack/lib/Memoize/Memcached.pm @@ -0,0 +1,530 @@ +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 works with memcached can be dangerous. Please +read the documentation below on C. + + +=head1 EXPORT + +This module exports C, C, and +C. The C 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. It works very +similarly, except for some difference in options. + +If the C or C options are passed in, +C will complain and then pass the request along to +C. 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 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, 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 option. These prefixes +are C, C, and C. + +The C defaults to "memoize-" if it's not passed in, or an +undefined value is passed in. + +The C and C options default to +"list-" and "scalar-" respectively, by the same criteria. + +So, the default way the key is generated is: + + "memoize--list-" + +or + + "memoize--scalar-" + +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: + + "-function--args" + +Examples: + + memoize_memcached('foo'); + + # keys generated will look like this: + # list context: memoize-foo-list- + # scalar context: memoize-foo-scalar- + + 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- + # scalar context: _M-foo-S- + +=head2 flush_cache + +The behavior documented in C is sort of implemented. A call +to C 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 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 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. Because of the way C is +implemented against memcached, this call will flush the entire +memcached cache. Everything. Even stuff having nothing to do with +C. 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<< >> + + +=head1 BUGS + +Please report any bugs or feature requests to C, or through +the web interface at L. 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 + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + + +=head1 ACKNOWLEDGMENTS + +The tied hash portion of this module is heavily based on +C 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 --- a/misc/plack/lib/Plack/Middleware/Debug/Devel/Size.pm +++ a/misc/plack/lib/Plack/Middleware/Debug/Devel/Size.pm @@ -0,0 +1, @@ +../../../../../p5-plack-devel-debug-devel-size/lib/Plack/Middleware/Debug/Devel/Size.pm --- a/misc/plack/lib/Plack/Middleware/Debug/Koha.pm +++ a/misc/plack/lib/Plack/Middleware/Debug/Koha.pm @@ -0,0 +1,22 @@ +package Plack::Middleware::Debug::Koha; +use Modern::Perl; +use parent 'Plack::Middleware::Debug::Base'; + +use Data::Dump qw(dump); + +sub run { + my ( $self, $env, $panel ) = @_; + sub { + my @evals = qw( + C4::Context::ismemcached + ); + + my $res = shift; + $panel->content( $self->render_list_pairs( [ + map { $_ => eval "$_" } @evals + ] ) ); + $panel->nav_subtitle("eval"); + } +} + +1; --- a/misc/plack/lib/Plack/Middleware/Debug/Persistant.pm +++ a/misc/plack/lib/Plack/Middleware/Debug/Persistant.pm @@ -0,0 +1,26 @@ +package Plack::Middleware::Debug::Persistant; +use Modern::Perl; +use Plack::Util::Accessor qw(for); +use parent 'Plack::Middleware::Debug::Base'; + +use Data::Dump qw(dump); + +sub run { + my ( $self, $env, $panel ) = @_; + sub { + my $res = shift; + my $stats = $Koha::Persistant::stats; + my ( $hit, $miss ) = ( 0, 0 ); + $panel->content( $self->render_list_pairs( [ + map { + $hit += $stats->{$_}->[0]; + $miss += $stats->{$_}->[1]; + $_ => join('/', @{ $stats->{$_} }) + } keys %$stats + ] ) ); + $panel->nav_subtitle(sprintf("%d/%d %.2f%%",$hit,$miss,$hit * 100/($hit+$miss || 1))); + $Koha::Persistant::stats = {} if $ENV{PROFILE_PER_PAGE}; + } +} + +1; --- a/misc/plack/lib/Plack/Middleware/Profiler/NYTProf.pm +++ a/misc/plack/lib/Plack/Middleware/Profiler/NYTProf.pm @@ -0,0 +1, @@ +../../../../p5-plack-middleware-profiler-nytprof/lib/Plack/Middleware/Profiler/NYTProf.pm --