1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
|
package LXRng::Cached;
use strict;
use LXRng;
require Exporter;
use vars qw($memcached @ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(cached);
BEGIN {
eval { require Cache::Memcached;
require Storable;
require Digest::SHA1;
};
if ($@ eq '') {
my $nspace = substr(Digest::SHA1::sha1_hex($LXRng::ROOT), 0, 8);
$memcached = Cache::Memcached->new({
'servers' => ['127.0.0.1:11211'],
'namespace' => 'lxrng:$nspace'});
$memcached = undef
unless ($memcached->set(':caching' => 1))
}
}
# Caches result from block enclosed by cache { ... }. File/linenumber
# of the "cache" keyword is used as the caching key. If additional
# arguments are given after the sub to cache, they are used to further
# specify the caching key. Otherwise, the arguments supplied to the
# function containing the call to cached are used.
sub cached(&;@);
*cached = \&DB::LXRng_Cached_cached;
package DB;
sub LXRng_Cached_cached(&;@) {
my ($func, @args) = @_;
if ($LXRng::Cached::memcached) {
my ($pkg, $file, $line) = caller(0);
my $params;
unless (@args > 0) {
my @caller = caller(1);
@args = map { UNIVERSAL::can($_, 'cache_key') ? $_->cache_key : $_
} @DB::args;
}
$params = Storable::freeze(\@args);
my $key = Digest::SHA1::sha1_hex(join("\0", $file, $line, $params));
my $val = $LXRng::Cached::memcached->get($key);
unless ($val) {
$val = [$func->()];
$LXRng::Cached::memcached->set($key, $val, 3600);
# warn "cache miss for $key (".join(":", $file, $line, @args).")\n";
}
else {
# warn "cache hit for $key\n";
}
return @$val;
}
else {
return $func->();
}
}
1;
|
