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

(-)a/Koha/Acquisition/Currencies.pm (-2 / +2 lines)
Lines 22-28 use Koha::Database; Link Here
22
22
23
use Koha::Acquisition::Currency;
23
use Koha::Acquisition::Currency;
24
24
25
use base qw(Koha::Objects);
25
use base qw(Koha::Objects::Cached);
26
26
27
=head1 NAME
27
=head1 NAME
28
28
Lines 40-46 Koha::Acquisition::Currencies - Koha Acquisition Currency Object set class Link Here
40
40
41
sub get_active {
41
sub get_active {
42
    my ( $self ) = @_;
42
    my ( $self ) = @_;
43
    return $self->SUPER::search( { active => 1 } )->next;
43
    return $self->search( { active => 1 } )->next;
44
}
44
}
45
45
46
=head3 _type
46
=head3 _type
(-)a/Koha/Acquisition/Currency.pm (-1 / +1 lines)
Lines 20-26 use Modern::Perl; Link Here
20
20
21
use Koha::Database;
21
use Koha::Database;
22
22
23
use base qw(Koha::Object);
23
use base qw(Koha::Object::CachedExpiration);
24
24
25
=head1 NAME
25
=head1 NAME
26
26
(-)a/Koha/ItemType.pm (-1 / +1 lines)
Lines 24-30 use Koha::Database; Link Here
24
use Koha::CirculationRules;
24
use Koha::CirculationRules;
25
use Koha::Localizations;
25
use Koha::Localizations;
26
26
27
use base qw(Koha::Object Koha::Object::Limit::Library);
27
use base qw(Koha::Object::CachedExpiration Koha::Object::Limit::Library);
28
28
29
my $cache = Koha::Caches->get_instance();
29
my $cache = Koha::Caches->get_instance();
30
30
(-)a/Koha/ItemTypes.pm (-1 / +1 lines)
Lines 23-29 use C4::Languages; Link Here
23
use Koha::Database;
23
use Koha::Database;
24
use Koha::ItemType;
24
use Koha::ItemType;
25
25
26
use base qw(Koha::Objects Koha::Objects::Limit::Library);
26
use base qw(Koha::Objects::Cached Koha::Objects::Limit::Library);
27
27
28
=head1 NAME
28
=head1 NAME
29
29
(-)a/Koha/Libraries.pm (-1 / +1 lines)
Lines 29-35 use Koha::Items; Link Here
29
use Koha::Library;
29
use Koha::Library;
30
use Koha::Patrons;
30
use Koha::Patrons;
31
31
32
use base qw(Koha::Objects);
32
use base qw(Koha::Objects::Cached);
33
33
34
=head1 NAME
34
=head1 NAME
35
35
(-)a/Koha/Library.pm (-1 / +1 lines)
Lines 27-33 use Koha::Database; Link Here
27
use Koha::StockRotationStages;
27
use Koha::StockRotationStages;
28
use Koha::SMTP::Servers;
28
use Koha::SMTP::Servers;
29
29
30
use base qw(Koha::Object);
30
use base qw(Koha::Object::CachedExpiration);
31
31
32
my $cache = Koha::Caches->get_instance();
32
my $cache = Koha::Caches->get_instance();
33
33
(-)a/Koha/Object.pm (+3 lines)
Lines 945-950 sub AUTOLOAD { Link Here
945
        my $accessor = sub {
945
        my $accessor = sub {
946
            my $self = shift;
946
            my $self = shift;
947
            if (@_) {
947
            if (@_) {
948
                if ($self->isa("Koha::Object::CachedExpiration")) {
949
                    $self->_objects_cache_expire();
950
                }
948
                $self->_result()->set_column( $method, @_ );
951
                $self->_result()->set_column( $method, @_ );
949
                return $self;
952
                return $self;
950
            } else {
953
            } else {
(-)a/Koha/Object/CachedExpiration.pm (+68 lines)
Line 0 Link Here
1
package Koha::Object::CachedExpiration;
2
3
use parent qw( Koha::Object Koha::Objects::Cached::Base );
4
use Modern::Perl;
5
use Data::Dumper;
6
7
=head1 NAME
8
9
Koha::Object::CachedExpiration
10
11
=head1 SYNOPSIS
12
13
    package Koha::Foo;
14
15
    use parent qw( Koha::Object::CachedExpiration );
16
17
=head1 API
18
19
=head2 Class Methods
20
21
=cut
22
23
=head3 delete
24
25
Overloaded I<delete> method for cache expiration
26
27
=cut
28
29
sub delete {
30
    my ($self) = @_;
31
    $self->_objects_cache_expire();
32
    $self->SUPER::delete();
33
}
34
35
=head3 store
36
37
Overloaded I<store> method for cache expiration
38
39
=cut
40
41
sub store {
42
    my ($self) = @_;
43
    $self->_objects_cache_expire();
44
    $self->SUPER::store();
45
}
46
47
=head2 Internal methods
48
49
=head3 _objects_cache_expire
50
51
=cut
52
53
sub _objects_cache_expire {
54
    my ($self) = @_;
55
    if ($self->_result->in_storage) {
56
        my @primary_keys = $self->_result->id;
57
        my $ids_cache_key = $self->_objects_cache_cache_key('find', @primary_keys);
58
        $self->_objects_cache_clear($ids_cache_key);
59
    }
60
}
61
62
=head1 AUTHOR
63
64
David Gustafsson <david.gustafsson@ub.gu.se>
65
66
=cut
67
68
1;
(-)a/Koha/Objects/Cached.pm (+92 lines)
Line 0 Link Here
1
package Koha::Objects::Cached;
2
3
use parent qw( Koha::Objects Koha::Objects::Cached::Base );
4
use Modern::Perl;
5
6
=head1 NAME
7
8
Koha::Object::Cached
9
10
=head1 SYNOPSIS
11
12
    package Koha::Foo;
13
14
    use parent qw( Koha:Objects::Cached );
15
16
=head1 API
17
18
=head2 Class Methods
19
20
=cut
21
22
=head3 find
23
24
Overloaded I<find> method that provides in memory caching by arguments.
25
26
=cut
27
28
sub find {
29
    my ($class, @args) = @_;
30
    my $object;
31
    my $cache_key = $class->_objects_cache_cache_key('find', @args);
32
33
    # Store in the args bucket if has column value condiditions
34
    # or for some reason the attributes argument is provided
35
    if (ref $args[0] eq 'HASH' || @args > 1 && ref $args[$#args] eq 'HASH') {
36
        $object = $class->_objects_cache_get($cache_key, 'args');
37
        unless ($object) {
38
            $object = $class->SUPER::find(@args);
39
            $class->_objects_cache_set($cache_key, $object, 'args');
40
        }
41
    }
42
    else {
43
        $object = $class->_objects_cache_get($cache_key, 'ids');
44
        unless ($object) {
45
            $object = $class->SUPER::find(@args);
46
            $class->_objects_cache_set($cache_key, $object, 'ids');
47
        }
48
    }
49
    return $object;
50
}
51
52
=head3 search
53
54
Overloaded I<search> method that provides in memory caching by arguments.
55
56
=cut
57
58
sub search {
59
    my ($class, $cond, $attrs) = @_;
60
    my $has_resultset = ref($class) && $class->{_resultset};
61
    $attrs //= {};
62
    $attrs->{cache} //= 1 unless $has_resultset;
63
64
65
    if ($has_resultset || !$attrs->{cache}) {
66
        return $class->SUPER::search($cond, $attrs);
67
    }
68
    else {
69
        my @args;
70
        push(@args , $cond) if defined $cond;
71
        # Don't include if only contains "cache" key
72
        push(@args, $attrs) unless keys %{$attrs} == 1;
73
        my $cache_key = $class->_objects_cache_cache_key('search', @args);
74
        my $objects = $class->_objects_cache_get($cache_key, 'args');
75
        if ($objects) {
76
            $objects->reset;
77
        }
78
        else {
79
            $objects = $class->SUPER::search($cond, $attrs);
80
            $class->_objects_cache_set($cache_key, $objects, 'args');
81
        }
82
        return $objects;
83
    }
84
}
85
86
=head1 AUTHOR
87
88
David Gustafsson <david.gustafsson@ub.gu.se>
89
90
=cut
91
92
1;
(-)a/Koha/Objects/Cached/Base.pm (+119 lines)
Line 0 Link Here
1
package Koha::Objects::Cached::Base;
2
3
use Modern::Perl;
4
use Digest::MD5 qw( md5_hex );
5
use JSON;
6
use Data::Dumper;
7
8
use Koha::Cache::Memory::Lite;
9
10
=head1 NAME
11
12
Koha::Objects::Cached::Base
13
14
=head2 Internal methods
15
16
=head3 _objects_cache_cache_key
17
18
=cut
19
20
sub _objects_cache_cache_key {
21
    my ($self, @args) = @_;
22
    if (@args == 2 && !ref $args[1]) {
23
        return join(':', @args);
24
    }
25
    # JSON is much faster than Data::Dumper but throws
26
    # an exception for certain perl data strucures
27
    # (non boolean scalar refs for example which can
28
    # be used in DBIx conditions)
29
    my $cache_key = eval { md5_hex(JSON->new->canonical(1)->encode(\@args)) };
30
    if ($cache_key) {
31
        return $cache_key;
32
    } else {
33
        local $Data::Dumper::Sortkeys = 1;
34
        return md5_hex(Dumper(\@args));
35
    }
36
}
37
38
=head3 _objects_cache_bucket_key
39
40
=cut
41
42
sub _objects_cache_bucket_key {
43
    my ($self, $bucket) = @_;
44
    my %buckets = (
45
        'ids' => 'ObjectsCachedIds',
46
        'args' => 'ObjectsCachedArgs'
47
    );
48
    unless (exists $buckets{$bucket}) {
49
        croak "Invalid cache bucket $bucket";
50
    }
51
    return $self->_type . $buckets{$bucket};
52
53
54
}
55
56
=head3 _objects_cache_bucket
57
58
=cut
59
60
sub _objects_cache_bucket {
61
    my ($self, $bucket) = @_;
62
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
63
    my $bucket_key = $self->_objects_cache_bucket_key($bucket);
64
    my $cache = $memory_cache->get_from_cache($bucket_key);
65
    unless ($cache) {
66
        $cache = {};
67
        $memory_cache->set_in_cache($bucket_key, $cache);
68
    }
69
    return $cache;
70
}
71
72
=head3 _objects_cache_get
73
74
=cut
75
76
sub _objects_cache_get {
77
    my ($self, $cache_key, $bucket) = @_;
78
    my $cache = $self->_objects_cache_bucket($bucket);
79
    return exists $cache->{$cache_key} ? $cache->{$cache_key} : undef;
80
}
81
82
=head3 _objects_cache_set
83
84
=cut
85
86
sub _objects_cache_set {
87
    my ($self, $cache_key, $object, $bucket) = @_;
88
    my $cache = $self->_objects_cache_bucket($bucket);
89
    $cache->{$cache_key} = $object;
90
}
91
92
=head3 _objects_cache_clear
93
94
=cut
95
96
sub _objects_cache_clear {
97
    my ($self, $ids_cache_key) = @_;
98
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
99
    if ($ids_cache_key) {
100
        my $cache = $self->_objects_cache_bucket('ids');
101
        delete $cache->{$ids_cache_key};
102
    }
103
    else {
104
        $memory_cache->clear_from_cache(
105
            $self->_objects_cache_bucket_key('ids')
106
        );
107
    }
108
    $memory_cache->clear_from_cache(
109
        $self->_objects_cache_bucket_key('args')
110
    );
111
}
112
113
=head1 AUTHOR
114
115
David Gustafsson <david.gustafsson@ub.gu.se>
116
117
=cut
118
119
1;
(-)a/Koha/Patron.pm (-1 / +1 lines)
Lines 66-72 use Koha::Subscription::Routinglists; Link Here
66
use Koha::Token;
66
use Koha::Token;
67
use Koha::Virtualshelves;
67
use Koha::Virtualshelves;
68
68
69
use base qw(Koha::Object);
69
use base qw(Koha::Object::CachedExpiration);
70
70
71
use constant ADMINISTRATIVE_LOCKOUT => -1;
71
use constant ADMINISTRATIVE_LOCKOUT => -1;
72
72
(-)a/Koha/Patrons.pm (-1 / +1 lines)
Lines 29-35 use Koha::Patron; Link Here
29
use Koha::Exceptions::Patron;
29
use Koha::Exceptions::Patron;
30
use Koha::Patron::Categories;
30
use Koha::Patron::Categories;
31
31
32
use base qw(Koha::Objects);
32
use base qw(Koha::Objects::Cached);
33
33
34
=head1 NAME
34
=head1 NAME
35
35
(-)a/t/db_dependent/Koha/Libraries.t (-2 / +202 lines)
Lines 19-25 Link Here
19
19
20
use Modern::Perl;
20
use Modern::Perl;
21
21
22
use Test::More tests => 13;
22
use Test::More tests => 14;
23
23
24
use C4::Biblio;
24
use C4::Biblio;
25
use C4::Context;
25
use C4::Context;
Lines 32-37 use Koha::Library; Link Here
32
use Koha::Libraries;
32
use Koha::Libraries;
33
use Koha::Database;
33
use Koha::Database;
34
use Koha::CirculationRules;
34
use Koha::CirculationRules;
35
use Koha::Cache::Memory::Lite;
35
36
36
use t::lib::Mocks;
37
use t::lib::Mocks;
37
use t::lib::TestBuilder;
38
use t::lib::TestBuilder;
Lines 413-415 subtest 'outgoing_transfers' => sub { Link Here
413
414
414
    $schema->storage->txn_rollback;
415
    $schema->storage->txn_rollback;
415
};
416
};
416
- 
417
418
subtest 'cache tests' => sub {
419
    plan tests => 24;
420
421
    $schema->storage->txn_begin;
422
423
    my $library1 = $builder->build_object(
424
        {
425
            class => 'Koha::Libraries',
426
            value  => {
427
                branchname => 'My library'
428
            }
429
        }
430
    );
431
    my $library2 = $builder->build_object(
432
        {
433
            class => 'Koha::Libraries',
434
            value  => {
435
                branchname => 'My other library'
436
            }
437
        }
438
    );
439
440
    # Since build_object calls find internally
441
    # we first have to flush the cache since these
442
    # objects are now already cached
443
    Koha::Cache::Memory::Lite->get_instance()->flush();
444
445
    my $ids_bucket = Koha::Libraries->_objects_cache_bucket('ids');
446
    ok(!%{$ids_bucket}, 'Find cache has been cleared after flushing memory cache');
447
448
    my $cached_library = Koha::Libraries->find($library1->branchcode);
449
    Koha::Libraries->find($library2->branchcode);
450
451
    my $cached_library_ids_bucket = Koha::Libraries->_objects_cache_get(
452
        Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode),
453
        'ids'
454
    );
455
    is (ref($cached_library_ids_bucket), 'Koha::Library', 'Library should be cached after previously have been fetched');
456
    is ($cached_library_ids_bucket->branchcode, $library1->branchcode, 'The cashed library should be the expected library');
457
458
    # Set property of library by-passing the cache expiration logic
459
    # so we can veriy library is not only present in cache by also
460
    # properly retrieved in find
461
    $cached_library->_result->set_column('branchname', 'My library in cache');
462
    $cached_library = Koha::Libraries->find($library1->branchcode);
463
    is (
464
        $cached_library->branchname,
465
        'My library in cache',
466
        'The cashed library returned by find should be the cached library'
467
    );
468
469
    $library1->branchname('My expired library');
470
    $cached_library_ids_bucket = Koha::Libraries->_objects_cache_get(
471
        Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode),
472
        'ids'
473
    );
474
    is (
475
        $cached_library_ids_bucket,
476
        undef,
477
        'Cache has been expired after changing library property'
478
    );
479
480
    $cached_library = Koha::Libraries->_objects_cache_get(
481
        Koha::Libraries->_objects_cache_cache_key('find', $library2->branchcode),
482
        'ids'
483
    );
484
    is (
485
        ref($cached_library),
486
        'Koha::Library', 'Cache should still contain other cached libraries'
487
    );
488
489
    my $stored_library = Koha::Libraries->find($library1->branchcode);
490
    is (
491
        $stored_library->branchname,
492
        'My library',
493
        'Library is fetched from database after cache has been expired'
494
    );
495
496
    $cached_library = Koha::Libraries->_objects_cache_get(
497
        Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode),
498
        'ids'
499
    );
500
    is (
501
        ref($cached_library),
502
        'Koha::Library',
503
        'Library should be cached after previously have been fetched'
504
    );
505
506
    $library1->store();
507
    $cached_library = Koha::Libraries->_objects_cache_get(
508
        Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode),
509
        'ids'
510
    );
511
    is ($cached_library, undef, 'Cache has been expired after saving library to database');
512
513
    Koha::Libraries->find($library1->branchcode, { key => 'primary' });
514
    $cached_library = Koha::Libraries->_objects_cache_get(
515
        Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode, { key => 'primary' }),
516
        'args'
517
    );
518
    is (
519
        ref($cached_library),
520
        'Koha::Library',
521
        'The args cache bucket should be used if find is called with the attrs argument'
522
    );
523
    my $cached_value;
524
525
    for my $method ('find', 'search') {
526
527
        Koha::Libraries->$method({ branchcode => $library1->branchcode });
528
        Koha::Libraries->$method({ branchcode => $library2->branchcode });
529
530
        $cached_value = Koha::Libraries->_objects_cache_get(
531
            Koha::Libraries->_objects_cache_cache_key($method, { branchcode => $library1->branchcode }),
532
            'args'
533
        );
534
        $cached_library = $method eq 'search' ? $cached_value->next : $cached_value;
535
        is (
536
            ref($cached_library),
537
            'Koha::Library',
538
            'Library should be cached after previously have been fetched, and use the args cache bucket ' . ($method eq 'find' ? 'if find was called with column conditions' : 'if search was called')
539
        );
540
541
        $cached_library->_result->set_column('branchname', 'My library in cache');
542
        $cached_value = Koha::Libraries->$method({ branchcode => $library1->branchcode });
543
        $cached_library = $method eq 'search' ? $cached_value->next : $cached_value;
544
        is (
545
            $cached_library->branchname,
546
            'My library in cache',
547
            "The cashed library returned by $method should be the cached library, using the args cache bucket"
548
        );
549
550
        $cached_library->branchname('My expired library');
551
        $cached_value = Koha::Libraries->_objects_cache_get(
552
            Koha::Libraries->_objects_cache_cache_key($method, { branchcode => $library1->branchcode }),
553
            'args'
554
        );
555
        is (
556
            $cached_value,
557
            undef,
558
            'Cache has been expired after changing branchname, using the args cache bucket'
559
        );
560
561
        $cached_value = Koha::Libraries->_objects_cache_get(
562
            Koha::Libraries->_objects_cache_cache_key($method, { branchcode => $library2->branchcode }),
563
            'args'
564
        );
565
        is (
566
            $cached_value,
567
            undef,
568
            'The whole args cache bucket has been emptied after triggering cache expiration'
569
        );
570
    }
571
572
    Koha::Libraries->find($library2->branchcode);
573
574
    my $libraries = Koha::Libraries->search({ branchcode => $library1->branchcode });
575
    $libraries->next;
576
    is($libraries->next, undef, 'Cached libraries search result iterator has been exhausted');
577
578
    $libraries = Koha::Libraries->search({ branchcode => $library1->branchcode });
579
    is(ref($libraries->next), 'Koha::Library', 'Cached libraries search result iterator has been reset');
580
581
582
    my $cached_libraries = Koha::Libraries->_objects_cache_get(
583
        Koha::Libraries->_objects_cache_cache_key('search', { 'branchcode' => $library1->branchcode }),
584
        'args'
585
    );
586
    is (
587
        ref($cached_libraries),
588
        'Koha::Libraries',
589
        'Libraries should be cached after previously have been fetched'
590
    );
591
592
    $library1->delete();
593
    $cached_libraries = Koha::Libraries->_objects_cache_get(
594
        Koha::Libraries->_objects_cache_cache_key('search', { 'branchcode' => $library1->branchcode }),
595
        'args'
596
    );
597
    is ($cached_libraries, undef, 'Search cache has been expired after deleting library');
598
599
    $cached_library = Koha::Libraries->_objects_cache_get(
600
        Koha::Libraries->_objects_cache_cache_key('find', $library2->branchcode),
601
        'ids'
602
    );
603
    is (
604
        ref($cached_library),
605
        'Koha::Library',
606
        'Library should be cached after previously have been fetched'
607
    );
608
    $library2->delete();
609
    $cached_library = Koha::Libraries->_objects_cache_get(
610
        Koha::Libraries->_objects_cache_cache_key('find', $library2->branchcode),
611
        'ids'
612
    );
613
    is ($cached_library, undef, 'Find cache has been expired after deleting library');
614
615
    $schema->storage->txn_rollback;
616
}

Return to bug 36350