View | Details | Raw Unified | Return to bug 16088
Collapse All | Expand All

(-)a/C4/Languages.pm (-10 / +20 lines)
Lines 26-31 use Carp; Link Here
26
use CGI;
26
use CGI;
27
use List::MoreUtils qw( any );
27
use List::MoreUtils qw( any );
28
use C4::Context;
28
use C4::Context;
29
use Koha::Cache::Memory::Lite;
29
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
30
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
30
31
31
eval {
32
eval {
Lines 569-574 sub accept_language { Link Here
569
sub getlanguage {
570
sub getlanguage {
570
    my ($cgi) = @_;
571
    my ($cgi) = @_;
571
572
573
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
574
    my $cache_key = "getlanguage";
575
    unless ( $cgi and $cgi->param('language') ) {
576
        my $cached = $memory_cache->get_from_cache($cache_key);
577
        return $cached if $cached;
578
    }
579
572
    $cgi //= new CGI;
580
    $cgi //= new CGI;
573
    my $interface = C4::Context->interface;
581
    my $interface = C4::Context->interface;
574
    my $theme = C4::Context->preference( ( $interface eq 'opac' ) ? 'opacthemes' : 'template' );
582
    my $theme = C4::Context->preference( ( $interface eq 'opac' ) ? 'opacthemes' : 'template' );
Lines 584-597 sub getlanguage { Link Here
584
    }
592
    }
585
593
586
    # Chose language from the URL
594
    # Chose language from the URL
587
    $language = $cgi->param( 'language' );
595
    my $cgi_param_language = $cgi->param( 'language' );
588
    if ( defined $language && any { $_ eq $language } @languages) {
596
    if ( defined $cgi_param_language && any { $_ eq $cgi_param_language } @languages) {
589
        return $language;
597
        $language = $cgi_param_language;
590
    }
598
    }
591
599
592
    # cookie
600
    # cookie
593
    if ($language = $cgi->cookie('KohaOpacLanguage') ) {
601
    if (not $language and my $cgi_cookie_language = $cgi->cookie('KohaOpacLanguage') ) {
594
        $language =~ s/[^a-zA-Z_-]*//; # sanitize cookie
602
        ( $language = $cgi_cookie_language ) =~ s/[^a-zA-Z_-]*//; # sanitize cookie
595
    }
603
    }
596
604
597
    # HTTP_ACCEPT_LANGUAGE
605
    # HTTP_ACCEPT_LANGUAGE
Lines 601-616 sub getlanguage { Link Here
601
    }
609
    }
602
610
603
    # Ignore a lang not selected in sysprefs
611
    # Ignore a lang not selected in sysprefs
604
    if ( $language && any { $_ eq $language } @languages ) {
612
    if ( $language && not any { $_ eq $language } @languages ) {
605
        return $language;
613
        $language = undef;
606
    }
614
    }
607
615
608
    # Pick the first selected syspref language
616
    # Pick the first selected syspref language
609
    $language = shift @languages;
617
    $language = shift @languages unless $language;
610
    return $language if $language;
611
618
612
    # Fall back to English if necessary
619
    # Fall back to English if necessary
613
    return 'en';
620
    $language ||= 'en';
621
622
    $memory_cache->set_in_cache( $cache_key, $language );
623
    return $language;
614
}
624
}
615
625
616
1;
626
1;
(-)a/C4/Templates.pm (-6 / +8 lines)
Lines 36-41 use C4::Languages qw(getTranslatedLanguages get_bidi regex_lang_subtags language Link Here
36
36
37
use C4::Context;
37
use C4::Context;
38
38
39
use Koha::Cache::Memory::Lite;
40
39
__PACKAGE__->mk_accessors(qw( theme activethemes preferredtheme lang filename htdocs interface vars));
41
__PACKAGE__->mk_accessors(qw( theme activethemes preferredtheme lang filename htdocs interface vars));
40
42
41
43
Lines 273-284 sub themelanguage { Link Here
273
sub setlanguagecookie {
275
sub setlanguagecookie {
274
    my ( $query, $language, $uri ) = @_;
276
    my ( $query, $language, $uri ) = @_;
275
277
276
    my $cookie = $query->cookie(
278
    my $cookie = getlanguagecookie( $query, $language );
277
        -name    => 'KohaOpacLanguage',
279
278
        -value   => $language,
280
    # We do not want to set getlanguage in cache, some additional checks are
279
        -HttpOnly => 1,
281
    # done in C4::Languages::getlanguage
280
        -expires => '+3y'
282
    Koha::Cache::Memory::Lite->get_instance()->clear_from_cache( 'getlanguage' );
281
    );
283
282
    print $query->redirect(
284
    print $query->redirect(
283
        -uri    => $uri,
285
        -uri    => $uri,
284
        -cookie => $cookie
286
        -cookie => $cookie
(-)a/Koha/Cache/Memory/Lite.pm (+72 lines)
Line 0 Link Here
1
package Koha::Cache::Memory::Lite;
2
3
# Copyright 2016 Koha Development Team
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::Memory::Lite - Handling caching of objects in memory *only* for Koha
23
24
=head1 SYNOPSIS
25
26
  use Koha::Cache::Memory::Lite;
27
  my $cache = Koha::Cache::Memory::Lite->get_instance();
28
  $cache->set($key, $value);
29
  my $retrieved_from_cache_value = $cache->get($key);
30
  $cache->clear_from_cache($key);
31
  $cache->flush();
32
33
=head1 DESCRIPTION
34
35
Koha in memory only caching routines.
36
37
=cut
38
39
use Modern::Perl;
40
41
use base qw(Class::Accessor);
42
43
our %L1_cache;
44
45
our $singleton_cache;
46
sub get_instance {
47
    my ($class) = @_;
48
    $singleton_cache = $class->new() unless $singleton_cache;
49
    return $singleton_cache;
50
}
51
52
sub get_from_cache {
53
    my ( $self, $key ) = @_;
54
    return $L1_cache{$key};
55
}
56
57
sub set_in_cache {
58
    my ( $self, $key, $value ) = @_;
59
    $L1_cache{$key} = $value;
60
}
61
62
sub clear_from_cache {
63
    my ( $self, $key ) = @_;
64
    delete $L1_cache{$key};
65
}
66
67
sub flush {
68
    my ( $self ) = @_;
69
    %L1_cache = ();
70
}
71
72
1;
(-)a/debian/templates/plack.psgi (+3 lines)
Lines 34-39 use C4::Languages; Link Here
34
use C4::Letters;
34
use C4::Letters;
35
use C4::Members;
35
use C4::Members;
36
use C4::XSLT;
36
use C4::XSLT;
37
use Koha::Cache;
38
use Koha::Cache::Memory::Lite;
37
use Koha::Database;
39
use Koha::Database;
38
use Koha::DateUtils;
40
use Koha::DateUtils;
39
41
Lines 45-50 use CGI qw(-utf8 ); # we will loose -utf8 under plack, otherwise Link Here
45
        my $q = $old_new->( @_ );
47
        my $q = $old_new->( @_ );
46
        $CGI::PARAM_UTF8 = 1;
48
        $CGI::PARAM_UTF8 = 1;
47
        Koha::Cache->flush_L1_cache();
49
        Koha::Cache->flush_L1_cache();
50
        Koha::Cache::Memory::Lite->flush();
48
        return $q;
51
        return $q;
49
    };
52
    };
50
}
53
}
(-)a/misc/plack/koha.psgi (+2 lines)
Lines 13-18 use CGI qw(-utf8 ); # we will lose -utf8 under plack Link Here
13
        my $q = $old_new->( @_ );
13
        my $q = $old_new->( @_ );
14
        $CGI::PARAM_UTF8 = 1;
14
        $CGI::PARAM_UTF8 = 1;
15
        Koha::Cache->flush_L1_cache();
15
        Koha::Cache->flush_L1_cache();
16
        Koha::Cache::Memory::Lite->flush();
16
        return $q;
17
        return $q;
17
    };
18
    };
18
}
19
}
Lines 46-51 use C4::Branch; Link Here
46
use C4::Category;
47
use C4::Category;
47
use Koha::DateUtils;
48
use Koha::DateUtils;
48
use Koha::Cache;
49
use Koha::Cache;
50
use Koha::Cache::Memory::Lite;
49
=for preload
51
=for preload
50
use C4::Tags; # FIXME
52
use C4::Tags; # FIXME
51
=cut
53
=cut
(-)a/t/Cache.t (-2 / +39 lines)
Lines 17-23 Link Here
17
17
18
use Modern::Perl;
18
use Modern::Perl;
19
19
20
use Test::More tests => 41;
20
use Test::More tests => 43;
21
use Test::Warn;
21
use Test::Warn;
22
22
23
my $destructorcount = 0;
23
my $destructorcount = 0;
Lines 25-30 my $destructorcount = 0; Link Here
25
BEGIN {
25
BEGIN {
26
    use_ok('Koha::Cache');
26
    use_ok('Koha::Cache');
27
    use_ok('Koha::Cache::Object');
27
    use_ok('Koha::Cache::Object');
28
    use_ok('Koha::Cache::Memory::Lite');
28
    use_ok('C4::Context');
29
    use_ok('C4::Context');
29
}
30
}
30
31
Lines 221-226 SKIP: { Link Here
221
    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');
222
    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');
222
}
223
}
223
224
225
subtest 'Koha::Cache::Memory::Lite' => sub {
226
    plan tests => 6;
227
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
228
229
    # test fetching an item that isnt in the cache
230
    is( $memory_cache->get_from_cache("not in here"),
231
        undef, "fetching item NOT in cache" );
232
233
    # test fetching a valid item from cache
234
    $memory_cache->set_in_cache( "clear_me", "I AM MORE DATA" );
235
    $memory_cache->set_in_cache( "dont_clear_me", "I AM MORE DATA22" );
236
      ;    # overly large expiry time, clear below
237
    is(
238
        $memory_cache->get_from_cache("clear_me"),
239
        "I AM MORE DATA",
240
        "fetching valid item from cache"
241
    );
242
243
    # test clearing from cache
244
    $memory_cache->clear_from_cache("clear_me");
245
    is( $memory_cache->get_from_cache("clear_me"),
246
        undef, "fetching cleared item from cache" );
247
    is(
248
        $memory_cache->get_from_cache("dont_clear_me"),
249
        "I AM MORE DATA22",
250
        "fetching valid item from cache (after clearing another item)"
251
    );
252
253
    #test flushing from cache
254
    $memory_cache->set_in_cache( "flush_me", "testing 1 data" );
255
    $memory_cache->flush;
256
    is( $memory_cache->get_from_cache("flush_me"),
257
        undef, "fetching flushed item from cache" );
258
    is( $memory_cache->get_from_cache("dont_clear_me"),
259
        undef, "fetching flushed item from cache" );
260
};
261
224
END {
262
END {
225
  SKIP: {
263
  SKIP: {
226
        $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
264
        $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
227
- 

Return to bug 16088