|
Lines 2-8
package Koha::Objects::Cached::Base;
Link Here
|
| 2 |
|
2 |
|
| 3 |
use Modern::Perl; |
3 |
use Modern::Perl; |
| 4 |
use Digest::MD5 qw( md5_hex ); |
4 |
use Digest::MD5 qw( md5_hex ); |
| 5 |
use Carp qw( croak ); |
5 |
use Carp qw( croak ); |
| 6 |
use JSON; |
6 |
use JSON; |
| 7 |
use Data::Dumper; |
7 |
use Data::Dumper; |
| 8 |
|
8 |
|
|
Lines 16-114
Koha::Objects::Cached::Base
Link Here
|
| 16 |
|
16 |
|
| 17 |
=head3 _objects_cache_cache_key |
17 |
=head3 _objects_cache_cache_key |
| 18 |
|
18 |
|
|
|
19 |
my $cache_key = $self->_objects_cache_cache_key($method, @args); |
| 20 |
|
| 21 |
Get the object/objects cache key for a particular method based on the method arguments. |
| 22 |
|
| 23 |
=over 8 |
| 24 |
|
| 25 |
=item B<$method> |
| 26 |
|
| 27 |
The current method, for example "find" or "search". |
| 28 |
|
| 29 |
=item B<@args> |
| 30 |
|
| 31 |
The method arguments. |
| 32 |
|
| 33 |
=back |
| 34 |
|
| 19 |
=cut |
35 |
=cut |
| 20 |
|
36 |
|
| 21 |
sub _objects_cache_cache_key { |
37 |
sub _objects_cache_cache_key { |
| 22 |
my ($self, @args) = @_; |
38 |
my ( $self, @args ) = @_; |
| 23 |
if (@args == 2 && !ref $args[1]) { |
39 |
if ( @args == 2 && !ref $args[1] ) { |
| 24 |
return join(':', @args); |
40 |
return join( ':', @args ); |
| 25 |
} |
41 |
} |
|
|
42 |
|
| 26 |
# JSON is much faster than Data::Dumper but throws |
43 |
# JSON is much faster than Data::Dumper but throws |
| 27 |
# an exception for certain perl data strucures |
44 |
# an exception for certain perl data structures |
| 28 |
# (non boolean scalar refs for example which can |
45 |
# (non boolean scalar refs for example which can |
| 29 |
# be used in DBIx conditions) |
46 |
# be used in DBIx conditions) |
| 30 |
my $cache_key = eval { md5_hex(JSON->new->canonical(1)->encode(\@args)) }; |
47 |
my $cache_key = eval { md5_hex( JSON->new->canonical(1)->encode( \@args ) ) }; |
| 31 |
if ($cache_key) { |
48 |
if ($cache_key) { |
| 32 |
return $cache_key; |
49 |
return $cache_key; |
| 33 |
} else { |
50 |
} else { |
| 34 |
local $Data::Dumper::Sortkeys = 1; |
51 |
local $Data::Dumper::Sortkeys = 1; |
| 35 |
return md5_hex(Dumper(\@args)); |
52 |
return md5_hex( Dumper( \@args ) ); |
| 36 |
} |
53 |
} |
| 37 |
} |
54 |
} |
| 38 |
|
55 |
|
| 39 |
=head3 _objects_cache_bucket_key |
56 |
=head3 _objects_cache_bucket_key |
| 40 |
|
57 |
|
|
|
58 |
my $bucket_key = $self->_objects_cache_bucket_key($bucket); |
| 59 |
|
| 60 |
Get the full cache bucket key of the short hand C<$bucket> name for this object type. |
| 61 |
|
| 62 |
=over 8 |
| 63 |
|
| 64 |
=item B<$bucket> |
| 65 |
|
| 66 |
The bucket name, "ids" for the bucket key where objects retrieved by ids are stored, |
| 67 |
or "args" for the bucket key where objects retrieved by more complex conditions are |
| 68 |
stored. |
| 69 |
|
| 70 |
=back |
| 71 |
|
| 41 |
=cut |
72 |
=cut |
| 42 |
|
73 |
|
| 43 |
sub _objects_cache_bucket_key { |
74 |
sub _objects_cache_bucket_key { |
| 44 |
my ($self, $bucket) = @_; |
75 |
my ( $self, $bucket ) = @_; |
| 45 |
my %buckets = ( |
76 |
my %buckets = ( |
| 46 |
'ids' => 'ObjectsCachedIds', |
77 |
'ids' => 'ObjectsCachedIds', |
| 47 |
'args' => 'ObjectsCachedArgs' |
78 |
'args' => 'ObjectsCachedArgs' |
| 48 |
); |
79 |
); |
| 49 |
unless (exists $buckets{$bucket}) { |
80 |
unless ( exists $buckets{$bucket} ) { |
| 50 |
croak "Invalid cache bucket $bucket"; |
81 |
croak "Invalid cache bucket $bucket"; |
| 51 |
} |
82 |
} |
| 52 |
return $self->_type . $buckets{$bucket}; |
83 |
return $self->_type . $buckets{$bucket}; |
| 53 |
|
84 |
|
| 54 |
|
|
|
| 55 |
} |
85 |
} |
| 56 |
|
86 |
|
| 57 |
=head3 _objects_cache_bucket |
87 |
=head3 _objects_cache_bucket |
| 58 |
|
88 |
|
|
|
89 |
my $cache = _objects_cache_bucket($bucket); |
| 90 |
|
| 91 |
Get the memory cache of the short hand C<$bucket> name for this object type. |
| 92 |
|
| 93 |
=over 8 |
| 94 |
|
| 95 |
=item B<$bucket> |
| 96 |
|
| 97 |
The bucket name, "ids" for the bucket key where objects retrieved by ids are stored, |
| 98 |
or "args" for the bucket key where objects retrieved by more complex conditions are |
| 99 |
stored. |
| 100 |
|
| 101 |
=back |
| 102 |
|
| 59 |
=cut |
103 |
=cut |
| 60 |
|
104 |
|
| 61 |
sub _objects_cache_bucket { |
105 |
sub _objects_cache_bucket { |
| 62 |
my ($self, $bucket) = @_; |
106 |
my ( $self, $bucket ) = @_; |
| 63 |
my $memory_cache = Koha::Cache::Memory::Lite->get_instance(); |
107 |
my $memory_cache = Koha::Cache::Memory::Lite->get_instance(); |
| 64 |
my $bucket_key = $self->_objects_cache_bucket_key($bucket); |
108 |
my $bucket_key = $self->_objects_cache_bucket_key($bucket); |
| 65 |
my $cache = $memory_cache->get_from_cache($bucket_key); |
109 |
my $cache = $memory_cache->get_from_cache($bucket_key); |
| 66 |
unless ($cache) { |
110 |
unless ($cache) { |
| 67 |
$cache = {}; |
111 |
$cache = {}; |
| 68 |
$memory_cache->set_in_cache($bucket_key, $cache); |
112 |
$memory_cache->set_in_cache( $bucket_key, $cache ); |
| 69 |
} |
113 |
} |
| 70 |
return $cache; |
114 |
return $cache; |
| 71 |
} |
115 |
} |
| 72 |
|
116 |
|
| 73 |
=head3 _objects_cache_get |
117 |
=head3 _objects_cache_get |
| 74 |
|
118 |
|
|
|
119 |
my $objects = $self->_objects_cache_get($cache_key, $bucket); |
| 120 |
|
| 121 |
Get the cached object or objects for the C<$cache_key> and C<$bucket> |
| 122 |
|
| 75 |
=cut |
123 |
=cut |
| 76 |
|
124 |
|
| 77 |
sub _objects_cache_get { |
125 |
sub _objects_cache_get { |
| 78 |
my ($self, $cache_key, $bucket) = @_; |
126 |
my ( $self, $cache_key, $bucket ) = @_; |
| 79 |
my $cache = $self->_objects_cache_bucket($bucket); |
127 |
my $cache = $self->_objects_cache_bucket($bucket); |
| 80 |
return exists $cache->{$cache_key} ? $cache->{$cache_key} : undef; |
128 |
return exists $cache->{$cache_key} ? $cache->{$cache_key} : undef; |
| 81 |
} |
129 |
} |
| 82 |
|
130 |
|
| 83 |
=head3 _objects_cache_set |
131 |
=head3 _objects_cache_set |
| 84 |
|
132 |
|
|
|
133 |
$self->_objects_cache_set($cache_key, $bucket, $object); |
| 134 |
|
| 135 |
Set the cached object or objects for the C<$cache_key> and C<$bucket> |
| 136 |
|
| 85 |
=cut |
137 |
=cut |
| 86 |
|
138 |
|
| 87 |
sub _objects_cache_set { |
139 |
sub _objects_cache_set { |
| 88 |
my ($self, $cache_key, $object, $bucket) = @_; |
140 |
my ( $self, $cache_key, $object, $bucket ) = @_; |
| 89 |
my $cache = $self->_objects_cache_bucket($bucket); |
141 |
my $cache = $self->_objects_cache_bucket($bucket); |
| 90 |
$cache->{$cache_key} = $object; |
142 |
$cache->{$cache_key} = $object; |
| 91 |
} |
143 |
} |
| 92 |
|
144 |
|
| 93 |
=head3 _objects_cache_clear |
145 |
=head3 _objects_cache_clear |
| 94 |
|
146 |
|
|
|
147 |
$self->_objects_cache_clear($ids_cache_key); |
| 148 |
|
| 149 |
Clear objects cache, if $ids_cache_key is provided only that |
| 150 |
key will be purged from the 'ids' cache bucket. |
| 151 |
|
| 95 |
=cut |
152 |
=cut |
| 96 |
|
153 |
|
| 97 |
sub _objects_cache_clear { |
154 |
sub _objects_cache_clear { |
| 98 |
my ($self, $ids_cache_key) = @_; |
155 |
my ( $self, $ids_cache_key ) = @_; |
| 99 |
my $memory_cache = Koha::Cache::Memory::Lite->get_instance(); |
156 |
my $memory_cache = Koha::Cache::Memory::Lite->get_instance(); |
| 100 |
if ($ids_cache_key) { |
157 |
if ($ids_cache_key) { |
| 101 |
my $cache = $self->_objects_cache_bucket('ids'); |
158 |
my $cache = $self->_objects_cache_bucket('ids'); |
| 102 |
delete $cache->{$ids_cache_key}; |
159 |
delete $cache->{$ids_cache_key}; |
|
|
160 |
} else { |
| 161 |
$memory_cache->clear_from_cache( $self->_objects_cache_bucket_key('ids') ); |
| 103 |
} |
162 |
} |
| 104 |
else { |
163 |
$memory_cache->clear_from_cache( $self->_objects_cache_bucket_key('args') ); |
| 105 |
$memory_cache->clear_from_cache( |
|
|
| 106 |
$self->_objects_cache_bucket_key('ids') |
| 107 |
); |
| 108 |
} |
| 109 |
$memory_cache->clear_from_cache( |
| 110 |
$self->_objects_cache_bucket_key('args') |
| 111 |
); |
| 112 |
} |
164 |
} |
| 113 |
|
165 |
|
| 114 |
=head1 AUTHOR |
166 |
=head1 AUTHOR |