Koha/Cache/Object.pm

   1 package Koha::Cache::Object;
   2
   3 # Copyright 2013 C & P Bibliography Services
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 3 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along
  17 # with Koha; if not, write to the Free Software Foundation, Inc.,
  18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 =head1 NAME
  21
  22 Koha::Cache::Object - Tie-able class for caching objects
  23
  24 =head1 SYNOPSIS
  25
  26     my $cache = Koha::Cache->new();
  27     my $scalar = Koha::Cache->create_scalar(
  28         {
  29             'key'         => 'whatever',
  30             'timeout'     => 2,
  31             'constructor' => sub { return 'stuff'; },
  32         }
  33     );
  34     my %hash = Koha::Cache->create_hash(
  35         {
  36             'key'         => 'whateverelse',
  37             'timeout'     => 2,
  38             'constructor' => sub { return { 'stuff' => 'nonsense' }; },
  39         }
  40     );
  41
  42 =head1 DESCRIPTION
  43
  44 Do not use this class directly. It is tied to variables by Koha::Cache
  45 for transparent cache access. If you choose to ignore this warning, you
  46 should be aware that it is disturbingly polymorphic and supports both
  47 scalars and hashes, with arrays a potential future addition.
  48
  49 =head1 TIE METHODS
  50
  51 =cut
  52
  53 use strict;
  54 use warnings;
  55 use Carp;
  56
  57 use base qw(Class::Accessor);
  58
  59 __PACKAGE__->mk_ro_accessors(
  60     qw( allowupdate arguments cache cache_type constructor destructor inprocess key lastupdate timeout unset value )
  61 );
  62
  63 # General/SCALAR routines
  64
  65 sub TIESCALAR {
  66     my ( $class, $self ) = @_;
  67
  68     $self->{'datatype'}  ||= 'SCALAR';
  69     $self->{'arguments'} ||= [];
  70     if ( defined $self->{'preload'} ) {
  71         $self->{'value'} = &{ $self->{'preload'} }( @{ $self->{'arguments'} } );
  72         if ( defined( $self->{'cache'} ) ) {
  73             $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
  74                 $self->{'timeout'}, $self->{'cache_type'} . '_cache' );
  75         }
  76         $self->{'lastupdate'} = time;
  77     }
  78     return bless $self, $class;
  79 }
  80
  81 sub FETCH {
  82     my ( $self, $index ) = @_;
  83
  84     $ENV{DEBUG}
  85       && $index
  86       && carp "Retrieving cached hash member $index of $self->{'key'}";
  87
  88     my $now = time;
  89
  90     if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
  91         && $self->{'cache'} )
  92     {
  93         $self->{'value'} =
  94           $self->{'cache'}
  95           ->get_from_cache( $self->{'key'}, $self->{'cache_type'} . '_cache' );
  96         $self->{'lastupdate'} = $now;
  97     }
  98
  99     if (   !defined $self->{'value'}
 100         || ( defined $index && !exists $self->{'value'}->{$index} )
 101         || !defined $self->{'lastupdate'}
 102         || ( $now - $self->{'lastupdate'} > $self->{'timeout'} ) )
 103     {
 104         $self->{'value'} =
 105           &{ $self->{'constructor'} }( @{ $self->{'arguments'} },
 106             $self->{'value'}, $index );
 107         if ( defined( $self->{'cache'} ) ) {
 108             $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
 109                 $self->{'timeout'}, $self->{'cache_type'} . '_cache' );
 110         }
 111         $self->{'lastupdate'} = $now;
 112     }
 113     if ( $self->{'datatype'} eq 'HASH' && defined $index ) {
 114         return $self->{'value'}->{$index};
 115     }
 116     return $self->{'value'};
 117 }
 118
 119 sub STORE {
 120     my $value = pop @_;
 121     my ( $self, $index ) = @_;
 122
 123     if ( $self->{'datatype'} eq 'HASH' && defined($index) ) {
 124         $self->{'value'}->{$index} = $value;
 125     }
 126     else {
 127         $self->{'value'} = $value;
 128     }
 129     if (   defined( $self->{'allowupdate'} )
 130         && $self->{'allowupdate'}
 131         && defined( $self->{'cache'} ) )
 132     {
 133         $self->{'cache'}
 134           ->set_in_cache( $self->{'key'}, $self->{'value'}, $self->{'timeout'},
 135             $self->{'cache_type'} . '_cache' );
 136     }
 137
 138     return $self->{'value'};
 139 }
 140
 141 sub DESTROY {
 142     my ($self) = @_;
 143
 144     if ( defined( $self->{'destructor'} ) ) {
 145         &{ $self->{'destructor'} }( @{ $self->{'arguments'} } );
 146     }
 147
 148     if (   defined( $self->{'unset'} )
 149         && $self->{'unset'}
 150         && defined( $self->{'cache'} ) )
 151     {
 152         $self->{'cache'}->clear_from_cache( $self->{'key'},
 153             $self->{'cache_type'} . '_cache' );
 154     }
 155
 156     undef $self->{'value'};
 157
 158     return $self;
 159 }
 160
 161 # HASH-specific routines
 162
 163 sub TIEHASH {
 164     my ( $class, $self, @args ) = @_;
 165     $self->{'datatype'} = 'HASH';
 166     return TIESCALAR( $class, $self, @args );
 167 }
 168
 169 sub DELETE {
 170     my ( $self, $index ) = @_;
 171     delete $self->{'value'}->{$index};
 172     return $self->STORE( $self->{'value'} );
 173 }
 174
 175 sub EXISTS {
 176     my ( $self, $index ) = @_;
 177     $self->FETCH($index);
 178     return exists $self->{'value'}->{$index};
 179 }
 180
 181 sub FIRSTKEY {
 182     my ($self) = @_;
 183     $self->FETCH;
 184     $self->{'iterator'} = [ keys %{ $self->{'value'} } ];
 185     return $self->NEXTKEY;
 186 }
 187
 188 sub NEXTKEY {
 189     my ($self) = @_;
 190     return shift @{ $self->{'iterator'} };
 191 }
 192
 193 sub SCALAR {
 194     my ($self) = @_;
 195     $self->FETCH;
 196     return scalar %{ $self->{'value'} }
 197       if ( ref( $self->{'value'} ) eq 'HASH' );
 198     return;
 199 }
 200
 201 sub CLEAR {
 202     my ($self) = @_;
 203     return $self->DESTROY;
 204 }
 205
 206 # ARRAY-specific routines
 207
 208 =head1 SEE ALSO
 209
 210 Koha::Cache, tie, perltie
 211
 212 =head1 AUTHOR
 213
 214 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
 215
 216 =cut
 217
 218 1;
 219
 220 __END__