Bug 16088: Introduce Koha::Cache::Memory::Lite to cache the language

The goal of this patch is to avoid unecessary flush of the L1 cache on
creating a new CGI object each time C4::Languages::getlanguage is called
without a CGI object.

The new class Koha::Cache::Memory::Lite must be flushed by the CGI
constructor overide done in the psgi file. This new class will ease
caching of specific stuffs used by running script.

Test plan:
At the OPAC and the intranet interfaces:
Open 2 different browser session to simulate several users
- Clear the cookies of the browsers
- User 1 (U1) an User 2 (U2) should be set to the default language
  (depending on the browser settings)
- U1 chooses another language
- U2 refreshes and the language used must be the default one
- U2 chooses a third language
- U1 refreshes and must be still using the one he has choosen.

Try to use a language which is not defined:
Add &language=es-ES (if es-ES is not translated) to the url, you should
not see the Spanish interface.

Signed-off-by: Jacek Ablewicz <abl@biblos.pk.edu.pl>

Signed-off-by: Jesse Weaver <jweaver@bywatersolutions.com>

Signed-off-by: Brendan Gallagher <brendan@bywatersolutions.com>

C4/Languages.pm

@@ -26,6 +26,7 @@ use Carp;
 use CGI;
 use List::MoreUtils qw( any );
 use C4::Context;
+use Koha::Cache::Memory::Lite;
 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
 
 eval {
@@ -569,6 +570,13 @@ sub accept_language {
 sub getlanguage {
     my ($cgi) = @_;
 
+    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
+    my $cache_key = "getlanguage";
+    unless ( $cgi and $cgi->param('language') ) {
+        my $cached = $memory_cache->get_from_cache($cache_key);
+        return $cached if $cached;
+    }
+
     $cgi //= new CGI;
     my $interface = C4::Context->interface;
     my $theme = C4::Context->preference( ( $interface eq 'opac' ) ? 'opacthemes' : 'template' );
@@ -584,14 +592,14 @@ sub getlanguage {
     }
 
     # Chose language from the URL
-    $language = $cgi->param( 'language' );
-    if ( defined $language && any { $_ eq $language } @languages) {
-        return $language;
+    my $cgi_param_language = $cgi->param( 'language' );
+    if ( defined $cgi_param_language && any { $_ eq $cgi_param_language } @languages) {
+        $language = $cgi_param_language;
     }
 
     # cookie
-    if ($language = $cgi->cookie('KohaOpacLanguage') ) {
-        $language =~ s/[^a-zA-Z_-]*//; # sanitize cookie
+    if (not $language and my $cgi_cookie_language = $cgi->cookie('KohaOpacLanguage') ) {
+        ( $language = $cgi_cookie_language ) =~ s/[^a-zA-Z_-]*//; # sanitize cookie
     }
 
     # HTTP_ACCEPT_LANGUAGE
@@ -601,16 +609,18 @@ sub getlanguage {
     }
 
     # Ignore a lang not selected in sysprefs
-    if ( $language && any { $_ eq $language } @languages ) {
-        return $language;
+    if ( $language && not any { $_ eq $language } @languages ) {
+        $language = undef;
     }
 
     # Pick the first selected syspref language
-    $language = shift @languages;
-    return $language if $language;
+    $language = shift @languages unless $language;
 
     # Fall back to English if necessary
-    return 'en';
+    $language ||= 'en';
+
+    $memory_cache->set_in_cache( $cache_key, $language );
+    return $language;
 }
 
 1;

C4/Templates.pm

@@ -36,6 +36,8 @@ use C4::Languages qw(getTranslatedLanguages get_bidi regex_lang_subtags language
 
 use C4::Context;
 
+use Koha::Cache::Memory::Lite;
+
 __PACKAGE__->mk_accessors(qw( theme activethemes preferredtheme lang filename htdocs interface vars));
 
 
@@ -273,12 +275,12 @@ sub themelanguage {
 sub setlanguagecookie {
     my ( $query, $language, $uri ) = @_;
 
-    my $cookie = $query->cookie(
-        -name    => 'KohaOpacLanguage',
-        -value   => $language,
-        -HttpOnly => 1,
-        -expires => '+3y'
-    );
+    my $cookie = getlanguagecookie( $query, $language );
+
+    # We do not want to set getlanguage in cache, some additional checks are
+    # done in C4::Languages::getlanguage
+    Koha::Cache::Memory::Lite->get_instance()->clear_from_cache( 'getlanguage' );
+
     print $query->redirect(
         -uri    => $uri,
         -cookie => $cookie

Koha/Cache/Memory/Lite.pm

@@ -0,0 +1,72 @@
+package Koha::Cache::Memory::Lite;
+
+# Copyright 2016 Koha Development Team
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# Koha is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Koha; if not, see <http://www.gnu.org/licenses>.
+
+=head1 NAME
+
+Koha::Cache::Memory::Lite - Handling caching of objects in memory *only* for Koha
+
+=head1 SYNOPSIS
+
+  use Koha::Cache::Memory::Lite;
+  my $cache = Koha::Cache::Memory::Lite->get_instance();
+  $cache->set($key, $value);
+  my $retrieved_from_cache_value = $cache->get($key);
+  $cache->clear_from_cache($key);
+  $cache->flush();
+
+=head1 DESCRIPTION
+
+Koha in memory only caching routines.
+
+=cut
+
+use Modern::Perl;
+
+use base qw(Class::Accessor);
+
+our %L1_cache;
+
+our $singleton_cache;
+sub get_instance {
+    my ($class) = @_;
+    $singleton_cache = $class->new() unless $singleton_cache;
+    return $singleton_cache;
+}
+
+sub get_from_cache {
+    my ( $self, $key ) = @_;
+    return $L1_cache{$key};
+}
+
+sub set_in_cache {
+    my ( $self, $key, $value ) = @_;
+    $L1_cache{$key} = $value;
+}
+
+sub clear_from_cache {
+    my ( $self, $key ) = @_;
+    delete $L1_cache{$key};
+}
+
+sub flush {
+    my ( $self ) = @_;
+    %L1_cache = ();
+}
+
+1;

debian/templates/plack.psgi

@@ -34,6 +34,8 @@ use C4::Languages;
 use C4::Letters;
 use C4::Members;
 use C4::XSLT;
+use Koha::Cache;
+use Koha::Cache::Memory::Lite;
 use Koha::Database;
 use Koha::DateUtils;
 
@@ -45,6 +47,7 @@ use CGI qw(-utf8 ); # we will loose -utf8 under plack, otherwise
         my $q = $old_new->( @_ );
         $CGI::PARAM_UTF8 = 1;
         Koha::Cache->flush_L1_cache();
+        Koha::Cache::Memory::Lite->flush();
         return $q;
     };
 }

misc/plack/koha.psgi

@@ -13,6 +13,7 @@ use CGI qw(-utf8 ); # we will lose -utf8 under plack
         my $q = $old_new->( @_ );
         $CGI::PARAM_UTF8 = 1;
         Koha::Cache->flush_L1_cache();
+        Koha::Cache::Memory::Lite->flush();
         return $q;
     };
 }
@@ -46,6 +47,7 @@ use C4::Branch;
 use C4::Category;
 use Koha::DateUtils;
 use Koha::Cache;
+use Koha::Cache::Memory::Lite;
 =for preload
 use C4::Tags; # FIXME
 =cut

t/Cache.t

@@ -17,7 +17,7 @@
 
 use Modern::Perl;
 
-use Test::More tests => 41;
+use Test::More tests => 43;
 use Test::Warn;
 
 my $destructorcount = 0;
@@ -25,6 +25,7 @@ my $destructorcount = 0;
 BEGIN {
     use_ok('Koha::Cache');
     use_ok('Koha::Cache::Object');
+    use_ok('Koha::Cache::Memory::Lite');
     use_ok('C4::Context');
 }
 
@@ -221,6 +222,43 @@ SKIP: {
     is_deeply( $cache->get_from_cache('test_deep_copy_hash'), { another => 'hashref' }, 'A hash will not be deep copied if the unsafe flag is set');
 }
 
+subtest 'Koha::Cache::Memory::Lite' => sub {
+    plan tests => 6;
+    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
+
+    # test fetching an item that isnt in the cache
+    is( $memory_cache->get_from_cache("not in here"),
+        undef, "fetching item NOT in cache" );
+
+    # test fetching a valid item from cache
+    $memory_cache->set_in_cache( "clear_me", "I AM MORE DATA" );
+    $memory_cache->set_in_cache( "dont_clear_me", "I AM MORE DATA22" );
+      ;    # overly large expiry time, clear below
+    is(
+        $memory_cache->get_from_cache("clear_me"),
+        "I AM MORE DATA",
+        "fetching valid item from cache"
+    );
+
+    # test clearing from cache
+    $memory_cache->clear_from_cache("clear_me");
+    is( $memory_cache->get_from_cache("clear_me"),
+        undef, "fetching cleared item from cache" );
+    is(
+        $memory_cache->get_from_cache("dont_clear_me"),
+        "I AM MORE DATA22",
+        "fetching valid item from cache (after clearing another item)"
+    );
+
+    #test flushing from cache
+    $memory_cache->set_in_cache( "flush_me", "testing 1 data" );
+    $memory_cache->flush;
+    is( $memory_cache->get_from_cache("flush_me"),
+        undef, "fetching flushed item from cache" );
+    is( $memory_cache->get_from_cache("dont_clear_me"),
+        undef, "fetching flushed item from cache" );
+};
+
 END {
   SKIP: {
         $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';