Attachment 8894 Details for Bug 7844 – Bug 7844 - plack modified upstream modules

[patch] Bug 7844 - plack modified upstream modules

Bug-7844---plack-modified-upstream-modules.patch (text/plain), 17.25 KB, created by Dobrica Pavlinusic on 2012-04-04 22:53:50 UTC

(hide)

Description:

Filename:

MIME Type:

Creator: Dobrica Pavlinusic

Created: 2012-04-04 22:53:50 UTC

Size: 17.25 KB

patch

obsolete

>From dedaea4aff181148db2072ed3fe7f2ffed986b79 Mon Sep 17 00:00:00 2001
>From: Dobrica Pavlinusic <dpavlin@rot13.org>
>Date: Thu, 5 Apr 2012 00:37:47 +0200
>Subject: [PATCH] Bug 7844 - plack modified upstream modules
>
>---
> 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
>
>diff --git a/misc/plack/lib/Memoize/Memcached.pm b/misc/plack/lib/Memoize/Memcached.pm
>new file mode 100644
>index 0000000..9cb0fbd
>--- /dev/null
>+++ b/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<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
>diff --git a/misc/plack/lib/Plack/Middleware/Debug/Devel/Size.pm b/misc/plack/lib/Plack/Middleware/Debug/Devel/Size.pm
>new file mode 120000
>index 0000000..81e45c3
>--- /dev/null
>+++ b/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
>\ No newline at end of file
>diff --git a/misc/plack/lib/Plack/Middleware/Debug/Koha.pm b/misc/plack/lib/Plack/Middleware/Debug/Koha.pm
>new file mode 100644
>index 0000000..1d0a473
>--- /dev/null
>+++ b/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;
>diff --git a/misc/plack/lib/Plack/Middleware/Debug/Persistant.pm b/misc/plack/lib/Plack/Middleware/Debug/Persistant.pm
>new file mode 100644
>index 0000000..a71f2d0
>--- /dev/null
>+++ b/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;
>diff --git a/misc/plack/lib/Plack/Middleware/Profiler/NYTProf.pm b/misc/plack/lib/Plack/Middleware/Profiler/NYTProf.pm
>new file mode 120000
>index 0000000..aabcda6
>--- /dev/null
>+++ b/misc/plack/lib/Plack/Middleware/Profiler/NYTProf.pm
>@@ -0,0 +1 @@
>+../../../../p5-plack-middleware-profiler-nytprof/lib/Plack/Middleware/Profiler/NYTProf.pm
>\ No newline at end of file
>-- 
>1.7.2.5

Actions: View | Diff | Splinter Review

Attachments on bug 7844: 8684 | 8693 | 8731 | 8892 | 8893 | 8894 | 9113 | 9879 | 10082 | 10220 | 26148 | 26201 | 26206 | 26227 | 26275