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
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  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                 { expiry => $self->{'timeout'} } );
  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'} = $self->{'cache'}->get_from_cache( $self->{'key'} );
  94         $self->{'lastupdate'} = $now;
  95     }
  96
  97     if (   !defined $self->{'value'}
  98         || ( defined $index && !exists $self->{'value'}->{$index} )
  99         || !defined $self->{'lastupdate'}
 100         || ( $now - $self->{'lastupdate'} > $self->{'timeout'} ) )
 101     {
 102         $self->{'value'} =
 103           &{ $self->{'constructor'} }( @{ $self->{'arguments'} },
 104             $self->{'value'}, $index );
 105         if ( defined( $self->{'cache'} ) ) {
 106             $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
 107                 { expiry => $self->{'timeout'} } );
 108         }
 109         $self->{'lastupdate'} = $now;
 110     }
 111     if ( $self->{'datatype'} eq 'HASH' && defined $index ) {
 112         return $self->{'value'}->{$index};
 113     }
 114     return $self->{'value'};
 115 }
 116
 117 sub STORE {
 118     my $value = pop @_;
 119     my ( $self, $index ) = @_;
 120
 121     if ( $self->{'datatype'} eq 'HASH' && defined($index) ) {
 122         $self->{'value'}->{$index} = $value;
 123     }
 124     else {
 125         $self->{'value'} = $value;
 126     }
 127     if (   defined( $self->{'allowupdate'} )
 128         && $self->{'allowupdate'}
 129         && defined( $self->{'cache'} ) )
 130     {
 131         $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
 132             { expiry => $self->{'timeout'} },
 133         );
 134     }
 135
 136     return $self->{'value'};
 137 }
 138
 139 sub DESTROY {
 140     my ($self) = @_;
 141
 142     if ( defined( $self->{'destructor'} ) ) {
 143         &{ $self->{'destructor'} }( @{ $self->{'arguments'} } );
 144     }
 145
 146     if (   defined( $self->{'unset'} )
 147         && $self->{'unset'}
 148         && defined( $self->{'cache'} ) )
 149     {
 150         $self->{'cache'}->clear_from_cache( $self->{'key'} );
 151     }
 152
 153     undef $self->{'value'};
 154
 155     return $self;
 156 }
 157
 158 # HASH-specific routines
 159
 160 sub TIEHASH {
 161     my ( $class, $self, @args ) = @_;
 162     $self->{'datatype'} = 'HASH';
 163     return TIESCALAR( $class, $self, @args );
 164 }
 165
 166 sub DELETE {
 167     my ( $self, $index ) = @_;
 168     delete $self->{'value'}->{$index};
 169     return $self->STORE( $self->{'value'} );
 170 }
 171
 172 sub EXISTS {
 173     my ( $self, $index ) = @_;
 174     $self->FETCH($index);
 175     return exists $self->{'value'}->{$index};
 176 }
 177
 178 sub FIRSTKEY {
 179     my ($self) = @_;
 180     $self->FETCH;
 181     $self->{'iterator'} = [ keys %{ $self->{'value'} } ];
 182     return $self->NEXTKEY;
 183 }
 184
 185 sub NEXTKEY {
 186     my ($self) = @_;
 187     return shift @{ $self->{'iterator'} };
 188 }
 189
 190 sub SCALAR {
 191     my ($self) = @_;
 192     $self->FETCH;
 193     return scalar %{ $self->{'value'} }
 194       if ( ref( $self->{'value'} ) eq 'HASH' );
 195     return;
 196 }
 197
 198 sub CLEAR {
 199     my ($self) = @_;
 200     return $self->DESTROY;
 201 }
 202
 203 # ARRAY-specific routines
 204
 205 =head1 SEE ALSO
 206
 207 Koha::Cache, tie, perltie
 208
 209 =head1 AUTHOR
 210
 211 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
 212
 213 =cut
 214
 215 1;
 216
 217 __END__