1 package OpenSRF::Utils::Cache;
2 use strict; use warnings;
5 use Digest::MD5 qw(md5_hex);
6 use OpenSRF::Utils::Logger qw/:level/;
7 use OpenSRF::Utils::Config;
8 use OpenSRF::Utils::SettingsClient;
9 use OpenSRF::EX qw(:try);
10 use OpenSRF::Utils::JSON;
12 my $log = 'OpenSRF::Utils::Logger';
20 This class just subclasses Cache::Memcached.
21 see Cache::Memcached for more options.
23 The value passed to the call to current is the cache type
24 you wish to access. The below example sets/gets data
25 from the 'user' cache.
27 my $cache = OpenSRF::Utils::Cache->current("user");
28 $cache->set( "key1", "value1" [, $expire_secs ] );
29 my $val = $cache->get( "key1" );
38 # ------------------------------------------------------
39 # Persist methods and method names
40 # ------------------------------------------------------
42 my $persist_push_stack;
43 my $persist_peek_stack;
44 my $persist_destroy_slot;
45 my $persist_slot_get_expire;
46 my $persist_slot_find;
49 my $persist_add_slot_name = "opensrf.persist.slot.create_expirable";
50 my $persist_push_stack_name = "opensrf.persist.stack.push";
51 my $persist_peek_stack_name = "opensrf.persist.stack.peek";
52 my $persist_destroy_slot_name = "opensrf.persist.slot.destroy";
53 my $persist_slot_get_expire_name = "opensrf.persist.slot.get_expire";
54 my $persist_slot_find_name = "opensrf.persist.slot.find";;
56 # ------------------------------------------------------
62 Return a named cache if it exists
67 my ( $class, $c_type ) = @_;
68 return undef unless $c_type;
69 return $caches{$c_type} if exists $caches{$c_type};
70 return $caches{$c_type} = $class->new( $c_type );
76 Create a new named memcache object.
82 my( $class, $cache_type, $persist ) = @_;
83 $cache_type ||= 'global';
84 $class = ref( $class ) || $class;
86 return $caches{$cache_type} if (defined $caches{$cache_type});
88 my $conf = OpenSRF::Utils::SettingsClient->new;
89 my $servers = $conf->config_value( cache => $cache_type => servers => 'server' );
90 $max_persist_time = $conf->config_value( cache => $cache_type => 'max_cache_time' );
92 $servers = [ $servers ] if(!ref($servers));
95 $self->{persist} = $persist || 0;
96 $self->{memcache} = Cache::Memcached->new( { servers => $servers } );
97 if(!$self->{memcache}) {
98 throw OpenSRF::EX::PANIC ("Unable to create a new memcache object for $cache_type");
101 bless($self, $class);
102 $caches{$cache_type} = $self;
112 my($self, $key, $value, $expiretime ) = @_;
114 return undef unless( defined $key and defined $value );
116 $key = _clean_cache_key($key);
118 return undef if( $key eq '' ); # no zero-length keys
120 $value = OpenSRF::Utils::JSON->perl2JSON($value);
122 if($self->{persist}){ _load_methods(); }
124 $expiretime ||= $max_persist_time;
126 unless( $self->{memcache}->set( $key, $value, $expiretime ) ) {
127 $log->error("Unable to store $key => [".length($value)." bytes] in memcached server" );
131 $log->debug("Stored $key => $value in memcached server", INTERNAL);
133 if($self->{"persist"}) {
135 my ($slot) = $persist_add_slot->run("_CACHEVAL_$key", $expiretime . "s");
138 # slot may already exist
139 ($slot) = $persist_slot_find->run("_CACHEVAL_$key");
140 if(!defined($slot)) {
141 throw OpenSRF::EX::ERROR ("Unable to create cache slot $key in persist server" );
143 #XXX destroy the slot and rebuild it to prevent DOS
147 ($slot) = $persist_push_stack->run("_CACHEVAL_$key", $value);
150 throw OpenSRF::EX::ERROR ("Unable to push data onto stack in persist slot _CACHEVAL_$key" );
163 my( $self, $key ) = @_;
164 return undef unless defined $key;
165 $key = _clean_cache_key($key);
166 return undef if $key eq ''; # no zero-length keys
167 if($self->{persist}){ _load_methods(); }
168 $self->{memcache}->delete($key);
169 if( $self->{persist} ) {
170 $persist_destroy_slot->run("_CACHEVAL_$key");
181 my($self, $key ) = @_;
183 return undef unless defined $key;
185 $key = _clean_cache_key($key);
187 return undef if $key eq ''; # no zero-length keys
189 my $val = $self->{memcache}->get( $key );
190 return OpenSRF::Utils::JSON->JSON2perl($val) if defined($val);
192 if($self->{persist}){ _load_methods(); }
194 # if not in memcache but we are persisting, the put it into memcache
195 if( $self->{"persist"} ) {
196 $val = $persist_peek_stack->( "_CACHEVAL_$key" );
198 my ($expire) = $persist_slot_get_expire->run("_CACHEVAL_$key");
200 $self->{memcache}->set( $key, $val, $expire);
202 $self->{memcache}->set( $key, $val, $max_persist_time);
204 return OpenSRF::Utils::JSON->JSON2perl($val);
217 if(!$persist_add_slot) {
219 OpenSRF::Application->method_lookup($persist_add_slot_name);
220 if(!ref($persist_add_slot)) {
221 throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_add_slot_name");
225 if(!$persist_push_stack) {
226 $persist_push_stack =
227 OpenSRF::Application->method_lookup($persist_push_stack_name);
228 if(!ref($persist_push_stack)) {
229 throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_push_stack_name");
233 if(!$persist_peek_stack) {
234 $persist_peek_stack =
235 OpenSRF::Application->method_lookup($persist_peek_stack_name);
236 if(!ref($persist_peek_stack)) {
237 throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_peek_stack_name");
241 if(!$persist_destroy_slot) {
242 $persist_destroy_slot =
243 OpenSRF::Application->method_lookup($persist_destroy_slot_name);
244 if(!ref($persist_destroy_slot)) {
245 throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_destroy_slot_name");
248 if(!$persist_slot_get_expire) {
249 $persist_slot_get_expire =
250 OpenSRF::Application->method_lookup($persist_slot_get_expire_name);
251 if(!ref($persist_slot_get_expire)) {
252 throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_get_expire_name");
255 if(!$persist_slot_find) {
257 OpenSRF::Application->method_lookup($persist_slot_find_name);
258 if(!ref($persist_slot_find)) {
259 throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_find_name");
265 =head2 _clean_cache_key
267 Try to make the requested cache key conform to memcached's requirements. Per
268 https://github.com/memcached/memcached/blob/master/doc/protocol.txt:
271 Data stored by memcached is identified with the help of a key. A key
272 is a text string which should uniquely identify the data for clients
273 that are interested in storing and retrieving it. Currently the
274 length limit of a key is set at 250 characters (of course, normally
275 clients wouldn't need to use such long keys); the key must not include
276 control characters or whitespace.
281 sub _clean_cache_key {
284 $key =~ s{(\p{Cntrl}|\s)}{}g;
285 if (length($key) > 250) { # max length of memcahed key
286 $key = 'shortened_' . md5_hex($key);