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.pm (+5 lines)
Lines 287-292 sub set_in_cache { Link Here
287
    }
287
    }
288
}
288
}
289
289
290
sub set_in_L1_cache_only {
291
    my ( $self, $key, $value ) = @_;
292
    $L1_cache{ $key } = $value;
293
}
294
290
=head2 get_from_cache
295
=head2 get_from_cache
291
296
292
    my $value = $cache->get_from_cache($key, [ $options ]);
297
    my $value = $cache->get_from_cache($key, [ $options ]);
(-)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-29 Link Here
17
17
18
use Modern::Perl;
18
use Modern::Perl;
19
19
20
use Test::More tests => 40;
20
use Test::More tests => 42;
21
21
22
my $destructorcount = 0;
22
my $destructorcount = 0;
23
23
24
BEGIN {
24
BEGIN {
25
    use_ok('Koha::Cache');
25
    use_ok('Koha::Cache');
26
    use_ok('Koha::Cache::Object');
26
    use_ok('Koha::Cache::Object');
27
    use_ok('Koha::Cache::Memory::Lite');
27
    use_ok('C4::Context');
28
    use_ok('C4::Context');
28
}
29
}
29
30
Lines 210-215 SKIP: { Link Here
210
    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');
211
    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');
211
}
212
}
212
213
214
subtest 'Koha::Cache::Memory::Lite' => sub {
215
    plan tests => 6;
216
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
217
218
    # test fetching an item that isnt in the cache
219
    is( $memory_cache->get_from_cache("not in here"),
220
        undef, "fetching item NOT in cache" );
221
222
    # test fetching a valid item from cache
223
    $memory_cache->set_in_cache( "clear_me", "I AM MORE DATA" );
224
    $memory_cache->set_in_cache( "dont_clear_me", "I AM MORE DATA22" );
225
      ;    # overly large expiry time, clear below
226
    is(
227
        $memory_cache->get_from_cache("clear_me"),
228
        "I AM MORE DATA",
229
        "fetching valid item from cache"
230
    );
231
232
    # test clearing from cache
233
    $memory_cache->clear_from_cache("clear_me");
234
    is( $memory_cache->get_from_cache("clear_me"),
235
        undef, "fetching cleared item from cache" );
236
    is(
237
        $memory_cache->get_from_cache("dont_clear_me"),
238
        "I AM MORE DATA22",
239
        "fetching valid item from cache (after clearing another item)"
240
    );
241
242
    #test flushing from cache
243
    $memory_cache->set_in_cache( "flush_me", "testing 1 data" );
244
    $memory_cache->flush;
245
    is( $memory_cache->get_from_cache("flush_me"),
246
        undef, "fetching flushed item from cache" );
247
    is( $memory_cache->get_from_cache("dont_clear_me"),
248
        undef, "fetching flushed item from cache" );
249
};
250
213
END {
251
END {
214
  SKIP: {
252
  SKIP: {
215
        $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
253
        $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
216
- 

Return to bug 16088