Koha/Persistant.pm

   1 package Koha::Persistant;
   2
   3 # Copyright (c) 2012 Dobrica Pavlinusic
   4 # This file is part of Koha.
   5 #
   6 # Koha is free software; you can redistribute it and/or modify it under the
   7 # terms of the GNU General Public License as published by the Free Software
   8 # Foundation; either version 2 of the License, or (at your option) any later
   9 # version.
  10 #
  11 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  12 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  13 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License along with
  16 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  17 # Suite 330, Boston, MA  02111-1307 USA
  18
  19 use strict;
  20 use warnings;
  21
  22 use C4::Context;
  23
  24 use Data::Dump qw(dump);
  25
  26 use base 'Exporter';
  27 use version; our $VERSION = qv('1.0.0');
  28
  29 our @EXPORT = (
  30     qw( sql_cache authorised_value )
  31 );
  32
  33 =head1 Persistant
  34
  35 Koha::Persistant - make data objects in Koha persistant
  36
  37 =head1 DESCRIPTION
  38
  39 Koha needs nice centralized way to cache data for plack
  40
  41 Name of this module was choosen to be non-conflicting with possible
  42 future C<Koha::Cache>
  43
  44 =cut
  45
  46 =head2 sql_cache
  47
  48   $row = sql_cache($sql, $value1 [, $value2, ... ]);
  49
  50 Takes C<SELECT col1,col2 FROM table WHERE value1 = ? AND value2 = ?>
  51 SQL query and cache result returning cached row.
  52
  53   -- key: name-of-key
  54
  55 Syntax inside SQL query will override default cache key generation
  56 which is simple normalization of SQL strings.
  57
  58 =cut
  59
  60 sub DESTROY {
  61         warn "## Koha::Persistent::DESTROY";
  62 }
  63
  64 our $_sql_cache;
  65 our $_cache;
  66 our $stats;
  67
  68 sub _sql_cache {
  69         my $sql = shift;
  70         my @var = @_;
  71
  72         my $cache;
  73
  74         my $key = $sql;
  75         $key =~ s/\s\s+/ /gs;
  76         my $stat_key = $key;
  77
  78         my $eval;
  79
  80         if ( $key =~ s/^.*\s*--\s*key:\s*(.+)// ) {
  81                 $stat_key = $1;
  82                 $key = pop @_;
  83                 $eval = '$_cache->{';
  84                 $eval .= dump($_)."}->{" foreach @_;
  85                 $eval =~ s/\Q->{\E$//;
  86                 warn "# EVAL $eval";
  87                 eval "\$cache = $eval;";
  88                 die $! if $!;
  89         } else {
  90                 $key = join(' ', $key, @var);
  91                 $cache = $_sql_cache;
  92         }
  93
  94         if ( exists $cache->{$key} ) {
  95                 warn "### _sql_cache HIT $key\n";
  96                 $stats->{$stat_key}->[0]++;
  97                 return $cache->{$key};
  98         }
  99         warn "### _sql_cache MISS $key\n";
 100         $stats->{$stat_key}->[1]++;
 101         my $dbh = C4::Context->dbh;
 102         my $sth = $dbh->prepare( $sql );
 103         $sth->execute( @var );
 104         my $v = $sth->fetchrow_hashref;
 105         if ( $eval ) {
 106                 eval $eval.'->{'.dump($key).'} = $v;';
 107         } else {
 108                 $cache->{$key} = $v;
 109         }
 110         warn "# row $stat_key $key = ",dump($v);
 111 warn dump($_cache);
 112         return $v;
 113 }
 114
 115 =head2 autorhised_value
 116
 117   my $row = authorised_value( category => $category, $value );
 118
 119 =cut
 120
 121 sub authorised_value {
 122         shift if $_[0] eq 'category';
 123         my ( $category, $value ) = @_;
 124         my $row = _sql_cache("SELECT lib, lib_opac FROM authorised_values WHERE category = ? AND authorised_value = ? -- key:authorised_value", $category, $value);
 125         warn dump $row;
 126         return $row;
 127 }
 128
 129 1;