View | Details | Raw Unified | Return to bug 7844
Collapse All | Expand All

(-)a/misc/plack/lib/Memoize/Memcached.pm (+530 lines)
Line 0 Link Here
1
package Memoize::Memcached;
2
3
use strict;
4
use warnings;
5
6
use UNIVERSAL qw( isa );
7
use Carp qw( carp croak );
8
use Memoize qw( unmemoize );
9
use Cache::Memcached;
10
11
our $VERSION = '0.03';
12
13
use Data::Dumper;
14
$Data::Dumper::Sortkeys = 1;
15
16
warn "## FIXME ",__PACKAGE__, " patched with in-memory cache for fetch!";
17
18
use base 'Exporter';
19
20
our @EXPORT = qw( memoize_memcached );
21
our @EXPORT_OK = qw( unmemoize flush_cache );
22
our %EXPORT_TAGS = (
23
  all => [ @EXPORT, @EXPORT_OK ],
24
);
25
26
27
use fields qw(
28
  key_prefix
29
  expire_time
30
  memcached_obj
31
  key_error
32
  scalar_error
33
);
34
35
36
37
my %memo_data;
38
my %memcached_config;
39
40
41
sub memoize_memcached {
42
  # Be sure to leave @_ intact in case we need to redirect to
43
  # 'Memoize::memoize'.
44
  my ($function, %args) = @_;
45
46
  if (exists $args{LIST_CACHE} or exists $args{ARRAY_CACHE}) {
47
    carp "Call to 'memoize_memcached' with a cache option passed to 'memoize'";
48
    goto &Memoize::memoize;
49
  }
50
51
  my $memcached_args = delete $args{memcached} || {};
52
  croak "Invalid memcached argument (expected a hash)"
53
    unless isa($memcached_args, 'HASH');
54
55
  _memcached_setup(
56
    %{$memcached_args},
57
    memoized_function => $function,
58
  );
59
  $args{LIST_CACHE} = [ HASH => $memo_data{$function}{list_cache} ];
60
  $args{SCALAR_CACHE} = [ HASH => $memo_data{$function}{scalar_cache} ];
61
62
  # If we are passed a normalizer, we need to keep a version of it
63
  # around for flush_cache to use.  This breaks encapsulation.  And it
64
  # is just plain ugly.
65
  $memo_data{$function}{normalizer} = Memoize::_make_cref($args{NORMALIZER}, scalar caller)
66
    if defined $args{NORMALIZER};
67
68
  # Rebuild @_ since there is a good probability we have removed some
69
  # arguments meant for us and added the cache arguments.
70
  @_ = ($function, %args);
71
  goto &Memoize::memoize;
72
}
73
74
75
# Unfortunately, we need to do some magic to make flush_cache sorta
76
# work.  I don't think this is enough magic yet.
77
78
sub flush_cache {
79
  # If we have exactly 1 argument then we are probably expected to
80
  # clear the cache for a single function.  Pass this along to
81
  # Memoize, even though it cannot be handled correctly at this time
82
  # (whatever we do will be wrong, anyway).
83
84
warn "## flush_cache";
85
86
  goto &Memoize::flush_cache if @_ == 1;
87
88
89
  # If we have more than 1 argument, we are probably expected to clear
90
  # a single call signature for a function.  This we can almost do
91
  # properly.
92
93
  # Even though we can do this "properly", it is still very bad.  This
94
  # breaks encapsulation pretty disgustingly. With any luck Memoize
95
  # will eventually be patched to do this for us...
96
97
  if (@_ > 1) {
98
    my ($function, @args) = @_;
99
    my $cur_memo = $memo_data{$function};
100
    my $normalizer = $memo_data{$function}{normalizer};
101
    my $array_argstr;
102
    my $scalar_argstr;
103
    if (defined $normalizer) { 
104
      ($array_argstr) = $normalizer->(@_);
105
      $scalar_argstr = $normalizer->(@_);
106
    }
107
    else { # Default normalizer
108
      local $^W = 0;
109
      $array_argstr = $scalar_argstr = join chr(28), @args;
110
    }
111
    for my $cache (qw( list_cache scalar_cache )) {
112
      for my $argstr ($scalar_argstr, $array_argstr) {
113
        delete $cur_memo->{$cache}{$argstr};
114
      }
115
    }
116
    return 1;
117
  }
118
119
120
  # Currently all memoized functions share memcached config, so just
121
  # find the first valid object and flush cache.
122
123
  for my $function (keys %memo_data) {
124
    next unless $memo_data{$function}{list_obj};
125
    $memo_data{$function}{list_obj}{memcached_obj}->flush_all;
126
    last;
127
  }
128
129
  return 1;
130
}
131
132
133
sub import {
134
  my ($class) = @_;
135
136
  # Search through the arg list for the 'memcached' arg, process it,
137
  # and remove it (and its associated value) from the arg list in
138
  # anticipation of passing off to Exporter.
139
  for my $idx ($[ + 1 .. $#_) {
140
    my $arg = $_[$idx] || q();
141
    next unless $arg eq 'memcached';
142
    (undef, my $memcached_config) = splice @_, $idx, 2;
143
    croak "Invalid memcached config (expected a hash ref)"
144
      unless isa($memcached_config, 'HASH');
145
    %memcached_config = %{$memcached_config};
146
  }
147
148
  return $class->export_to_level(1, @_);
149
}
150
151
152
sub _memcached_setup {
153
  my %args = %memcached_config;
154
  while (@_) {
155
    my $key = shift;
156
    my $value = shift;
157
    $args{$key} = $value;
158
  }
159
160
  my $function = delete $args{memoized_function};
161
  my $list_key_prefix = delete $args{list_key_prefix};
162
  my $scalar_key_prefix = delete $args{scalar_key_prefix};
163
164
  $args{key_prefix} = 'memoize-' unless defined $args{key_prefix};
165
166
  croak "Missing function name for memcached setup"
167
    unless defined $function;
168
  my $tie_data = $memo_data{$function} = {
169
    list_obj => undef,
170
    list_cache => {},
171
    scalar_obj => undef,
172
    scalar_cache => {},
173
  };
174
175
  my %cur_args = %args;
176
  $cur_args{key_prefix}
177
    .= (defined $function ? "$function-" : '-')
178
    .  (defined $list_key_prefix ? $list_key_prefix : 'list-')
179
    ;
180
  $tie_data->{list_obj} = tie %{$tie_data->{list_cache}}, __PACKAGE__, %cur_args
181
    or die "Error creating list cache";
182
183
  %cur_args = %args;
184
  $cur_args{key_prefix}
185
    .= (defined $function ? "$function-" : '-')
186
    .  (defined $scalar_key_prefix ? $scalar_key_prefix : 'scalar-')
187
    ;
188
  $tie_data->{scalar_obj} = tie %{$tie_data->{scalar_cache}}, __PACKAGE__, %cur_args
189
    or die "Error creating scalar cache";
190
191
  return 1;
192
}
193
194
195
sub _new {
196
  my $class = shift;
197
  croak "Called new in object context" if ref $class;
198
  my $self = fields::new($class);
199
  $self->_init(@_);
200
  return $self;
201
}
202
203
204
sub _init {
205
  my $self = shift;
206
  my %args = @_;
207
  %{$self} = ();
208
209
  $self->{key_prefix} = delete $args{key_prefix};
210
  $self->{key_prefix} = q() unless defined $self->{key_prefix};
211
  $self->{expire_time} = exists $args{expire_time} ? delete $args{expire_time} : undef;
212
213
  # Default these to false so that we can use Data::Dumper on tied
214
  # hashes by default.  Yes, it will show them as empty, but I doubt
215
  # someone running Dumper on this tied hash would really want to dump
216
  # the contents of the memcached cache (and they can't anyway).
217
218
  $self->{$_} = exists $args{$_} ? delete $args{$_} : !1
219
    for qw( key_error scalar_error );
220
221
  $self->{memcached_obj} = Cache::Memcached->new(\%args);
222
223
  return $self;
224
}
225
226
227
sub _get_key {
228
  my $self = shift;
229
  my $key = shift;
230
  return $self->{key_prefix} . $key;
231
}
232
233
234
sub _key_lookup_error {
235
  croak "Key lookup functionality is not implemented by memcached";
236
}
237
238
239
sub TIEHASH {
240
  my $class = shift;
241
  return $class->_new(@_);
242
}
243
244
245
sub STORE {
246
  my $self = shift;
247
  my $key = $self->_get_key(shift);
248
  my $value = shift;
249
  my @args = ($key, $value);
250
  push @args, $self->{expire_time} if defined $self->{expire_time};
251
  $self->{memcached_obj}->set(@args);
252
warn "## STORE $key $value";
253
  return $self;
254
}
255
256
our $cache;
257
258
sub FETCH {
259
  my $self = shift;
260
  my $key = $self->_get_key(shift);
261
  if ( exists $cache->{$key} ) {
262
	$Koha::Persistant::stats->{memcache_FETCH}->[0]++;
263
	return $cache->{$key};
264
  }
265
  $Koha::Persistant::stats->{memcache_FETCH}->[1]++;
266
warn "## FETCH $key";
267
  my $v = $self->{memcached_obj}->get($key);
268
  $cache->{$key} = $v;
269
  return $v;
270
}
271
272
sub EXISTS {
273
  my $self = shift;
274
warn "## EXISTS @_";
275
  return defined $self->FETCH(@_);
276
}
277
278
279
sub DELETE {
280
  my $self = shift;
281
  my $key = $self->_get_key(shift);
282
  $self->{memcached_obj}->delete($key);
283
warn "## DELETE $key";
284
  return $self;
285
}
286
287
288
sub CLEAR {
289
  my $self = shift;
290
  # This is not safe because all object share memcached setup.
291
  $self->{memcached_obj}->flush_all;
292
warn "## CLEAR";
293
  return $self;
294
}
295
296
297
sub FIRSTKEY {
298
  my $self = shift;
299
  return unless $self->{key_error};
300
  $self->_key_lookup_error;
301
}
302
303
304
sub NEXTKEY {
305
  my $self = shift;
306
  return unless $self->{key_error};
307
  $self->_key_lookup_error;
308
}
309
310
311
sub SCALAR {
312
  my $self = shift;
313
  return unless $self->{scalar_error};
314
  # I think this error still makes sense, since to determine if the
315
  # cache has content one would need to first determine if the cache
316
  # contains keys.
317
  $self->_key_lookup_error;
318
}
319
320
321
sub UNTIE {
322
  my $self = shift;
323
  $self->{memcached_obj}->disconnect_all;
324
  return $self;
325
}
326
327
328
329
1;
330
331
__END__
332
333
=head1 NAME
334
335
Memoize::Memcached - use a memcached cache to memoize functions
336
337
338
=head1 SYNOPSIS
339
340
    use Memoize::Memcached
341
      memcached => {
342
        servers => [ '127.0.0.1:11211' ],
343
      };
344
345
    memoize_memcached('foo');
346
347
    # Function 'foo' is now memoized using the memcached server
348
    # running on 127.0.0.1:11211 as the cache.
349
350
351
=head1 WARNING
352
353
The way C<flush_cache> works with memcached can be dangerous.  Please
354
read the documentation below on C<flush_cache>.
355
356
357
=head1 EXPORT
358
359
This module exports C<memoize_memcached>, C<flush_cache>, and
360
C<unmemoize>.  The C<unmemoize> function is just the one from Memoize,
361
and is made available for convenience.
362
363
364
=head1 FUNCTIONS
365
366
=head2 memoize_memcached
367
368
This is the memcached equivalent of C<memoize>.  It works very
369
similarly, except for some difference in options.
370
371
If the C<LIST_CACHE> or C<SCALAR_CACHE> options are passed in,
372
C<memoize_memcached> will complain and then pass the request along to
373
C<memoize>.  The result will be a memoized function, but using
374
whatever cache you specified and NOT using memcached at all.
375
376
This function also accepts a C<memcached> option, which expects a
377
hashref.  This is de-referenced and passed directly into an internal
378
function which sets up the memcached configuration for that function.
379
This contents of this hashref are mostly options passed to
380
C<Cache::Memcached>, with a few exceptions.
381
382
The actual key used to look up memoize data in memcached is formed
383
from the function name, the normalized arguments, and some additional
384
prefixes which can be set via the C<memcached> option.  These prefixes
385
are C<key_prefix>, C<list_key_prefix>, and C<scalar_key_prefix>.
386
387
The C<key_prefix> defaults to "memoize-" if it's not passed in, or an
388
undefined value is passed in.
389
390
The C<list_key_prefix> and C<scalar_key_prefix> options default to
391
"list-" and "scalar-" respectively, by the same criteria.
392
393
So, the default way the key is generated is:
394
395
  "memoize-<function>-list-<normalized args>"
396
397
or
398
399
  "memoize-<function>-scalar-<normalized args>"
400
401
The function and normalized args portion of this key are set
402
internally, but the "memoize-" prefix and the context portion can be
403
configured with memcached options as follows:
404
405
  "<key_prefix>-function-<list_key_prefix|scalar_key_prefix>-args"
406
407
Examples:
408
409
  memoize_memcached('foo');
410
411
  # keys generated will look like this:
412
  #  list context:   memoize-foo-list-<argument signature>
413
  #  scalar context: memoize-foo-scalar-<argument signature>
414
415
  memoize_memcached('foo',
416
    memcached => {
417
      servers => [ ... ],
418
      key_prefix        => '_M-',
419
      list_key_prefix   => 'L-',
420
      scalar_key_prefix => 'S-',
421
    },
422
    ;
423
424
  # keys generated will look like this:
425
  #  list context:   _M-foo-L-<argument signature>
426
  #  scalar context: _M-foo-S-<argument signature>
427
428
=head2 flush_cache
429
430
The behavior documented in C<Memoize> is sort of implemented.  A call
431
to C<flush_cache('memoized_function')> will indeed clear the cache of
432
all cached return values for that function, BUT it will also clear the
433
entire memcached cache, including all other memoized functions using
434
the same memcached cache, and even data unrelated to
435
C<Memoize::Memcached> in the same cache.  It will flush the entire
436
cache.
437
438
There are 2 new ways to call this function:
439
440
    flush_cache();
441
442
and
443
444
    flush_cache(memoized_function => qw( an argument signature ));
445
446
The call without arguments will flush the entire memcached cache, just
447
like the 1 argument version.  This includes unrelated data.  Be
448
careful.
449
450
The call with 2 or more arguments will flush only the cached return
451
values (array and scalar contexts) for a call to the function named
452
by the first argument with an argument signature matching the second
453
argument to the end.  Unlike the other 2 ways to call this function,
454
when called this way only the specified part of the cache is flushed.
455
456
I would recommended that only the 2 or more argument version of
457
C<flush_cache> be called unless you are very sure of what you are
458
doing.
459
460
461
=head1 GOTCHAS
462
463
The biggest gotcha is that you probably never want to call
464
C<flush_cache('memoized_function')>.  Because of the way C<CLEAR> is
465
implemented against memcached, this call will flush the entire
466
memcached cache.  Everything.  Even stuff having nothing to do with
467
C<Memoize::Memcached>.  You are warned.
468
469
470
=head1 TO-DO
471
472
A more intuitive interface for handling different memcached server
473
configurations would probably be useful.
474
475
476
=head1 AUTHOR
477
478
David Trischuk, C<< <trischuk at gmail.com> >>
479
480
481
=head1 BUGS
482
483
Please report any bugs or feature requests to C<bug-memoize-memcached at rt.cpan.org>, or through
484
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Memoize-Memcached>.  I will be notified, and then you'll
485
automatically be notified of progress on your bug as I make changes.
486
487
488
=head1 SUPPORT
489
490
You can find documentation for this module with the perldoc command.
491
492
    perldoc Memoize::Memcached
493
494
You can also look for information at:
495
496
=over 4
497
498
=item * RT: CPAN's request tracker
499
500
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Memoize-Memcached>
501
502
=item * AnnoCPAN: Annotated CPAN documentation
503
504
L<http://annocpan.org/dist/Memoize-Memcached>
505
506
=item * CPAN Ratings
507
508
L<http://cpanratings.perl.org/d/Memoize-Memcached>
509
510
=item * Search CPAN
511
512
L<http://search.cpan.org/dist/Memoize-Memcached>
513
514
=back
515
516
517
=head1 ACKNOWLEDGMENTS
518
519
The tied hash portion of this module is heavily based on
520
C<Cache::Memcached::Tie> by Andrew Kostenko.
521
522
523
=head1 COPYRIGHT & LICENSE
524
525
Copyright 2008 David Trischuk, all rights reserved.
526
527
This program is free software; you can redistribute it and/or modify it
528
under the same terms as Perl itself.
529
530
=cut
(-)a/misc/plack/lib/Plack/Middleware/Debug/Devel/Size.pm (+1 lines)
Line 0 Link Here
1
../../../../../p5-plack-devel-debug-devel-size/lib/Plack/Middleware/Debug/Devel/Size.pm
(-)a/misc/plack/lib/Plack/Middleware/Debug/Koha.pm (+22 lines)
Line 0 Link Here
1
package Plack::Middleware::Debug::Koha;
2
use Modern::Perl;
3
use parent 'Plack::Middleware::Debug::Base';
4
5
use Data::Dump qw(dump);
6
7
sub run {
8
	my ( $self, $env, $panel ) = @_;
9
	sub {
10
		my @evals = qw(
11
			C4::Context::ismemcached
12
		);
13
14
		my $res = shift;
15
		$panel->content( $self->render_list_pairs( [
16
			map { $_ => eval "$_" } @evals
17
		] ) );
18
	        $panel->nav_subtitle("eval");
19
	}
20
}
21
22
1;
(-)a/misc/plack/lib/Plack/Middleware/Debug/Persistant.pm (+26 lines)
Line 0 Link Here
1
package Plack::Middleware::Debug::Persistant;
2
use Modern::Perl;
3
use Plack::Util::Accessor qw(for);
4
use parent 'Plack::Middleware::Debug::Base';
5
6
use Data::Dump qw(dump);
7
8
sub run {
9
	my ( $self, $env, $panel ) = @_;
10
	sub {
11
		my $res = shift;
12
		my $stats = $Koha::Persistant::stats;
13
		my ( $hit, $miss ) = ( 0, 0 );
14
		$panel->content( $self->render_list_pairs( [
15
			map {
16
				$hit  += $stats->{$_}->[0];
17
				$miss += $stats->{$_}->[1];
18
				$_ => join('/', @{ $stats->{$_} })
19
			} keys %$stats
20
		] ) );
21
	        $panel->nav_subtitle(sprintf("%d/%d %.2f%%",$hit,$miss,$hit * 100/($hit+$miss || 1)));
22
		$Koha::Persistant::stats = {} if $ENV{PROFILE_PER_PAGE};
23
	}
24
}
25
26
1;
(-)a/misc/plack/lib/Plack/Middleware/Profiler/NYTProf.pm (-1 / +1 lines)
Line 0 Link Here
0
- 
1
../../../../p5-plack-middleware-profiler-nytprof/lib/Plack/Middleware/Profiler/NYTProf.pm

Return to bug 7844