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
  56 use base qw(Class::Accessor);
  57
  58 __PACKAGE__->mk_ro_accessors(
  59     qw( allowupdate arguments cache cache_type constructor destructor inprocess key lastupdate timeout unset value )
  60 );
  61
  62 # General/SCALAR routines
  63
  64 sub TIESCALAR {
  65     my ( $class, $self ) = @_;
  66
  67     $self->{'datatype'}  ||= 'SCALAR';
  68     $self->{'arguments'} ||= [];
  69     if ( defined $self->{'preload'} ) {
  70         $self->{'value'} = &{ $self->{'preload'} }( @{ $self->{'arguments'} } );
  71         if ( defined( $self->{'cache'} ) ) {
  72             $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
  73                 { expiry => $self->{'timeout'} } );
  74         }
  75         $self->{'lastupdate'} = time;
  76     }
  77     return bless $self, $class;
  78 }
  79
  80 sub FETCH {
  81     my ( $self, $index ) = @_;
  82
  83     my $now = time;
  84
  85     if ( !( $self->{'inprocess'} && defined( $self->{'value'} ) )
  86         && $self->{'cache'} )
  87     {
  88         $self->{'value'} = $self->{'cache'}->get_from_cache( $self->{'key'} );
  89         $self->{'lastupdate'} = $now;
  90     }
  91
  92     if (   !defined $self->{'value'}
  93         || ( defined $index && !exists $self->{'value'}->{$index} )
  94         || !defined $self->{'lastupdate'}
  95         || ( $now - $self->{'lastupdate'} > $self->{'timeout'} ) )
  96     {
  97         $self->{'value'} =
  98           &{ $self->{'constructor'} }( @{ $self->{'arguments'} },
  99             $self->{'value'}, $index );
 100         if ( defined( $self->{'cache'} ) ) {
 101             $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
 102                 { expiry => $self->{'timeout'} } );
 103         }
 104         $self->{'lastupdate'} = $now;
 105     }
 106     if ( $self->{'datatype'} eq 'HASH' && defined $index ) {
 107         return $self->{'value'}->{$index};
 108     }
 109     return $self->{'value'};
 110 }
 111
 112 sub STORE {
 113     my $value = pop @_;
 114     my ( $self, $index ) = @_;
 115
 116     if ( $self->{'datatype'} eq 'HASH' && defined($index) ) {
 117         $self->{'value'}->{$index} = $value;
 118     }
 119     else {
 120         $self->{'value'} = $value;
 121     }
 122     if (   defined( $self->{'allowupdate'} )
 123         && $self->{'allowupdate'}
 124         && defined( $self->{'cache'} ) )
 125     {
 126         $self->{'cache'}->set_in_cache( $self->{'key'}, $self->{'value'},
 127             { expiry => $self->{'timeout'} },
 128         );
 129     }
 130
 131     return $self->{'value'};
 132 }
 133
 134 sub DESTROY {
 135     my ($self) = @_;
 136
 137     if ( defined( $self->{'destructor'} ) ) {
 138         &{ $self->{'destructor'} }( @{ $self->{'arguments'} } );
 139     }
 140
 141     if (   defined( $self->{'unset'} )
 142         && $self->{'unset'}
 143         && defined( $self->{'cache'} ) )
 144     {
 145         $self->{'cache'}->clear_from_cache( $self->{'key'} );
 146     }
 147
 148     undef $self->{'value'};
 149
 150     return $self;
 151 }
 152
 153 # HASH-specific routines
 154
 155 sub TIEHASH {
 156     my ( $class, $self, @args ) = @_;
 157     $self->{'datatype'} = 'HASH';
 158     return TIESCALAR( $class, $self, @args );
 159 }
 160
 161 sub DELETE {
 162     my ( $self, $index ) = @_;
 163     delete $self->{'value'}->{$index};
 164     return $self->STORE( $self->{'value'} );
 165 }
 166
 167 sub EXISTS {
 168     my ( $self, $index ) = @_;
 169     $self->FETCH($index);
 170     return exists $self->{'value'}->{$index};
 171 }
 172
 173 sub FIRSTKEY {
 174     my ($self) = @_;
 175     $self->FETCH;
 176     $self->{'iterator'} = [ keys %{ $self->{'value'} } ];
 177     return $self->NEXTKEY;
 178 }
 179
 180 sub NEXTKEY {
 181     my ($self) = @_;
 182     return shift @{ $self->{'iterator'} };
 183 }
 184
 185 sub SCALAR {
 186     my ($self) = @_;
 187     $self->FETCH;
 188     return scalar %{ $self->{'value'} }
 189       if ( ref( $self->{'value'} ) eq 'HASH' );
 190     return;
 191 }
 192
 193 sub CLEAR {
 194     my ($self) = @_;
 195     return $self->DESTROY;
 196 }
 197
 198 # ARRAY-specific routines
 199
 200 =head1 SEE ALSO
 201
 202 Koha::Cache, tie, perltie
 203
 204 =head1 AUTHOR
 205
 206 Jared Camins-Esakov, E<lt>jcamins@cpbibliography.comE<gt>
 207
 208 =cut
 209
 210 1;
 211
 212 __END__