src/perl/lib/OpenSRF/Utils/Cache.pm

   1 package OpenSRF::Utils::Cache;
   2 use strict; use warnings;
   3 use base qw/OpenSRF/;
   4 use Cache::Memcached;
   5 use OpenSRF::Utils::Logger qw/:level/;
   6 use OpenSRF::Utils::Config;
   7 use OpenSRF::Utils::SettingsClient;
   8 use OpenSRF::EX qw(:try);
   9 use OpenSRF::Utils::JSON;
  10
  11 my $log = 'OpenSRF::Utils::Logger';
  12
  13 =head1 NAME
  14
  15 OpenSRF::Utils::Cache
  16
  17 =head1 SYNOPSIS
  18
  19 This class just subclasses Cache::Memcached.
  20 see Cache::Memcached for more options.
  21
  22 The value passed to the call to current is the cache type
  23 you wish to access.  The below example sets/gets data
  24 from the 'user' cache.
  25
  26 my $cache = OpenSRF::Utils::Cache->current("user");
  27 $cache->set( "key1", "value1" [, $expire_secs ] );
  28 my $val = $cache->get( "key1" );
  29
  30
  31 =cut
  32
  33 sub DESTROY {}
  34
  35 my %caches;
  36
  37 # ------------------------------------------------------
  38 # Persist methods and method names
  39 # ------------------------------------------------------
  40 my $persist_add_slot;
  41 my $persist_push_stack;
  42 my $persist_peek_stack;
  43 my $persist_destroy_slot;
  44 my $persist_slot_get_expire;
  45 my $persist_slot_find;
  46
  47 my $max_persist_time;
  48 my $persist_add_slot_name        = "opensrf.persist.slot.create_expirable";
  49 my $persist_push_stack_name      = "opensrf.persist.stack.push";
  50 my $persist_peek_stack_name      = "opensrf.persist.stack.peek";
  51 my $persist_destroy_slot_name    = "opensrf.persist.slot.destroy";
  52 my $persist_slot_get_expire_name = "opensrf.persist.slot.get_expire";
  53 my $persist_slot_find_name       = "opensrf.persist.slot.find";;
  54
  55 # ------------------------------------------------------
  56
  57 =head1 METHODS
  58
  59 =head2 current
  60
  61 Return a named cache if it exists
  62
  63 =cut
  64
  65 sub current {
  66         my ( $class, $c_type )  = @_;
  67         return undef unless $c_type;
  68         return $caches{$c_type} if exists $caches{$c_type};
  69         return $caches{$c_type} = $class->new( $c_type );
  70 }
  71
  72
  73 =head2 new
  74
  75 Create a new named memcache object.
  76
  77 =cut
  78
  79 sub new {
  80
  81         my( $class, $cache_type, $persist ) = @_;
  82         $cache_type ||= 'global';
  83         $class = ref( $class ) || $class;
  84
  85         return $caches{$cache_type} if (defined $caches{$cache_type});
  86
  87         my $conf = OpenSRF::Utils::SettingsClient->new;
  88         my $servers = $conf->config_value( cache => $cache_type => servers => 'server' );
  89         $max_persist_time = $conf->config_value( cache => $cache_type => 'max_cache_time' );
  90
  91         $servers = [ $servers ] if(!ref($servers));
  92
  93         my $self = {};
  94         $self->{persist} = $persist || 0;
  95         $self->{memcache} = Cache::Memcached->new( { servers => $servers } );
  96         if(!$self->{memcache}) {
  97                 throw OpenSRF::EX::PANIC ("Unable to create a new memcache object for $cache_type");
  98         }
  99
 100         bless($self, $class);
 101         $caches{$cache_type} = $self;
 102         return $self;
 103 }
 104
 105
 106 =head2 put_cache
 107
 108 =cut
 109
 110 sub put_cache {
 111         my($self, $key, $value, $expiretime ) = @_;
 112
 113         return undef unless( defined $key and defined $value );
 114
 115         $key = _clean_cache_key($key);
 116
 117         return undef if( $key eq '' ); # no zero-length keys
 118
 119         $value = OpenSRF::Utils::JSON->perl2JSON($value);
 120
 121         if($self->{persist}){ _load_methods(); }
 122
 123         $expiretime ||= $max_persist_time;
 124
 125         unless( $self->{memcache}->set( $key, $value, $expiretime ) ) {
 126                 $log->error("Unable to store $key => [".length($value)." bytes]  in memcached server" );
 127                 return undef;
 128         }
 129
 130         $log->debug("Stored $key => $value in memcached server", INTERNAL);
 131
 132         if($self->{"persist"}) {
 133
 134                 my ($slot) = $persist_add_slot->run("_CACHEVAL_$key", $expiretime . "s");
 135
 136                 if(!$slot) {
 137                         # slot may already exist
 138                         ($slot) = $persist_slot_find->run("_CACHEVAL_$key");
 139                         if(!defined($slot)) {
 140                                 throw OpenSRF::EX::ERROR ("Unable to create cache slot $key in persist server" );
 141                         } else {
 142                                 #XXX destroy the slot and rebuild it to prevent DOS
 143                         }
 144                 }
 145
 146                 ($slot) = $persist_push_stack->run("_CACHEVAL_$key", $value);
 147
 148                 if(!$slot) {
 149                         throw OpenSRF::EX::ERROR ("Unable to push data onto stack in persist slot _CACHEVAL_$key" );
 150                 }
 151         }
 152
 153         return $key;
 154 }
 155
 156
 157 =head2 delete_cache
 158
 159 =cut
 160
 161 sub delete_cache {
 162         my( $self, $key ) = @_;
 163         return undef unless defined $key;
 164         $key = _clean_cache_key($key);
 165         return undef if $key eq ''; # no zero-length keys
 166         if($self->{persist}){ _load_methods(); }
 167         $self->{memcache}->delete($key);
 168         if( $self->{persist} ) {
 169                 $persist_destroy_slot->run("_CACHEVAL_$key");
 170         }
 171         return $key;
 172 }
 173
 174
 175 =head2 get_cache
 176
 177 =cut
 178
 179 sub get_cache {
 180         my($self, $key ) = @_;
 181
 182         return undef unless defined $key;
 183
 184         $key = _clean_cache_key($key);
 185
 186         return undef if $key eq ''; # no zero-length keys
 187
 188         my $val = $self->{memcache}->get( $key );
 189         return OpenSRF::Utils::JSON->JSON2perl($val) if defined($val);
 190
 191         if($self->{persist}){ _load_methods(); }
 192
 193         # if not in memcache but we are persisting, the put it into memcache
 194         if( $self->{"persist"} ) {
 195                 $val = $persist_peek_stack->( "_CACHEVAL_$key" );
 196                 if(defined($val)) {
 197                         my ($expire) = $persist_slot_get_expire->run("_CACHEVAL_$key");
 198                         if($expire)     {
 199                                 $self->{memcache}->set( $key, $val, $expire);
 200                         } else {
 201                                 $self->{memcache}->set( $key, $val, $max_persist_time);
 202                         }
 203                         return OpenSRF::Utils::JSON->JSON2perl($val);
 204                 }
 205         }
 206         return undef;
 207 }
 208
 209
 210 =head2 _load_methods
 211
 212 =cut
 213
 214 sub _load_methods {
 215
 216         if(!$persist_add_slot) {
 217                 $persist_add_slot =
 218                         OpenSRF::Application->method_lookup($persist_add_slot_name);
 219                 if(!ref($persist_add_slot)) {
 220                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_add_slot_name");
 221                 }
 222         }
 223
 224         if(!$persist_push_stack) {
 225                 $persist_push_stack =
 226                         OpenSRF::Application->method_lookup($persist_push_stack_name);
 227                 if(!ref($persist_push_stack)) {
 228                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_push_stack_name");
 229                 }
 230         }
 231
 232         if(!$persist_peek_stack) {
 233                 $persist_peek_stack =
 234                         OpenSRF::Application->method_lookup($persist_peek_stack_name);
 235                 if(!ref($persist_peek_stack)) {
 236                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_peek_stack_name");
 237                 }
 238         }
 239
 240         if(!$persist_destroy_slot) {
 241                 $persist_destroy_slot =
 242                         OpenSRF::Application->method_lookup($persist_destroy_slot_name);
 243                 if(!ref($persist_destroy_slot)) {
 244                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_destroy_slot_name");
 245                 }
 246         }
 247         if(!$persist_slot_get_expire) {
 248                 $persist_slot_get_expire =
 249                         OpenSRF::Application->method_lookup($persist_slot_get_expire_name);
 250                 if(!ref($persist_slot_get_expire)) {
 251                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_get_expire_name");
 252                 }
 253         }
 254         if(!$persist_slot_find) {
 255                 $persist_slot_find =
 256                         OpenSRF::Application->method_lookup($persist_slot_find_name);
 257                 if(!ref($persist_slot_find)) {
 258                         throw OpenSRF::EX::PANIC ("Unable to retrieve method $persist_slot_find_name");
 259                 }
 260         }
 261 }
 262
 263
 264 =head2 _clean_cache_key
 265
 266 Try to make the requested cache key conform to memcached's requirements. Per
 267 https://github.com/memcached/memcached/blob/master/doc/protocol.txt:
 268
 269 """
 270 Data stored by memcached is identified with the help of a key. A key
 271 is a text string which should uniquely identify the data for clients
 272 that are interested in storing and retrieving it.  Currently the
 273 length limit of a key is set at 250 characters (of course, normally
 274 clients wouldn't need to use such long keys); the key must not include
 275 control characters or whitespace.
 276 """
 277
 278 =cut
 279
 280 sub _clean_cache_key {
 281     my $key = shift;
 282
 283     $key =~ s{(\p{Cntrl}|\s)}{}g;
 284
 285     return $key;
 286 }
 287
 288 1;
 289