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 |