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

(-)a/Koha/Acquisition/Currencies.pm (-1 / +1 lines)
Lines 38-44 Koha::Acquisition::Currencies - Koha Acquisition Currency Object set class Link Here
38
=cut
38
=cut
39
39
40
sub get_active {
40
sub get_active {
41
    my ( $self ) = @_;
41
    my ($self) = @_;
42
    return $self->search( { active => 1 } )->next;
42
    return $self->search( { active => 1 } )->next;
43
}
43
}
44
44
(-)a/Koha/Object.pm (-1 / +1 lines)
Lines 1017-1023 sub AUTOLOAD { Link Here
1017
        my $accessor = sub {
1017
        my $accessor = sub {
1018
            my $self = shift;
1018
            my $self = shift;
1019
            if (@_) {
1019
            if (@_) {
1020
                if ($self->isa("Koha::Object::CachedExpiration")) {
1020
                if ( $self->isa("Koha::Object::CachedExpiration") ) {
1021
                    $self->_objects_cache_expire();
1021
                    $self->_objects_cache_expire();
1022
                }
1022
                }
1023
                $self->_result()->set_column( $method, @_ );
1023
                $self->_result()->set_column( $method, @_ );
(-)a/Koha/Object/CachedExpiration.pm (-3 / +3 lines)
Lines 52-60 sub store { Link Here
52
52
53
sub _objects_cache_expire {
53
sub _objects_cache_expire {
54
    my ($self) = @_;
54
    my ($self) = @_;
55
    if ($self->_result->in_storage) {
55
    if ( $self->_result->in_storage ) {
56
        my @primary_keys = $self->_result->id;
56
        my @primary_keys  = $self->_result->id;
57
        my $ids_cache_key = $self->_objects_cache_cache_key('find', @primary_keys);
57
        my $ids_cache_key = $self->_objects_cache_cache_key( 'find', @primary_keys );
58
        $self->_objects_cache_clear($ids_cache_key);
58
        $self->_objects_cache_clear($ids_cache_key);
59
    }
59
    }
60
}
60
}
(-)a/Koha/Objects.pm (-1 / +1 lines)
Lines 143-149 sub search { Link Here
143
        }
143
        }
144
    ) if defined $attributes;
144
    ) if defined $attributes;
145
145
146
    my $rs = $self->_resultset()->search( $params, $attributes );
146
    my $rs    = $self->_resultset()->search( $params, $attributes );
147
    my $class = ref($self) ? ref($self) : $self;
147
    my $class = ref($self) ? ref($self) : $self;
148
148
149
    return $class->_new_from_dbic($rs);
149
    return $class->_new_from_dbic($rs);
(-)a/Koha/Objects/Cached.pm (-22 / +22 lines)
Lines 26-48 Overloaded I<find> method that provides in memory caching by arguments. Link Here
26
=cut
26
=cut
27
27
28
sub find {
28
sub find {
29
    my ($class, @args) = @_;
29
    my ( $class, @args ) = @_;
30
    my $cache_key = $class->_objects_cache_cache_key('find', @args);
30
    my $cache_key = $class->_objects_cache_cache_key( 'find', @args );
31
31
    # Store in the args bucket if has column value condiditions
32
    # Store in the args bucket if has column value condiditions
32
    # or for some reason the attributes argument is provided
33
    # or for some reason the attributes argument is provided
33
    my $has_options = @args > 1 && ref $args[$#args] eq 'HASH';
34
    my $has_options  = @args > 1 && ref $args[$#args] eq 'HASH';
34
    my $cache = !($has_options && defined $args[$#args]->{cache} && !$args[$#args]->{cache});
35
    my $cache        = !( $has_options && defined $args[$#args]->{cache} && !$args[$#args]->{cache} );
35
    my $cache_bucket = ref $args[0] eq 'HASH' || $has_options ? 'args' : 'ids';
36
    my $cache_bucket = ref $args[0] eq 'HASH' || $has_options ? 'args' : 'ids';
36
    my $object;
37
    my $object;
37
    if ($cache) {
38
    if ($cache) {
38
        $object = $class->_objects_cache_get($cache_key, $cache_bucket);
39
        $object = $class->_objects_cache_get( $cache_key, $cache_bucket );
39
    }
40
    }
40
    if (!defined $object) {
41
    if ( !defined $object ) {
41
        $object = $class->SUPER::find(@args);
42
        $object = $class->SUPER::find(@args);
42
        $object //= 'undef';
43
        $object //= 'undef';
43
        $class->_objects_cache_set($cache_key, $object, $cache_bucket) if $cache;
44
        $class->_objects_cache_set( $cache_key, $object, $cache_bucket ) if $cache;
44
    }
45
    } elsif ( $object ne 'undef' && defined $object->{'_cache'} ) {
45
    elsif ($object ne 'undef' && defined $object->{'_cache'}) {
46
46
        # Clear object cache if set
47
        # Clear object cache if set
47
        delete $object->{'_cache'};
48
        delete $object->{'_cache'};
48
    }
49
    }
Lines 56-82 Overloaded I<search> method that provides in memory caching by arguments. Link Here
56
=cut
57
=cut
57
58
58
sub search {
59
sub search {
59
    my ($class, $cond, $attrs) = @_;
60
    my ( $class, $cond, $attrs ) = @_;
60
    my $has_resultset = ref($class) && $class->{_resultset};
61
    my $has_resultset = ref($class) && $class->{_resultset};
61
    $attrs //= {};
62
    $attrs //= {};
62
    $attrs->{cache} //= 1 unless $has_resultset;
63
    $attrs->{cache} //= 1 unless $has_resultset;
63
64
64
    if ($has_resultset || !$attrs->{cache}) {
65
    if ( $has_resultset || !$attrs->{cache} ) {
65
        return $class->SUPER::search($cond, $attrs);
66
        return $class->SUPER::search( $cond, $attrs );
66
    }
67
    } else {
67
    else {
68
        my @args;
68
        my @args;
69
        push(@args , $cond) if defined $cond;
69
        push( @args, $cond ) if defined $cond;
70
70
        # Don't include if only contains "cache" key
71
        # Don't include if only contains "cache" key
71
        push(@args, $attrs) unless keys %{$attrs} == 1 && defined $attrs->{cache};
72
        push( @args, $attrs ) unless keys %{$attrs} == 1 && defined $attrs->{cache};
72
        my $cache_key = $class->_objects_cache_cache_key('search', @args);
73
        my $cache_key = $class->_objects_cache_cache_key( 'search', @args );
73
        my $objects = $class->_objects_cache_get($cache_key, 'args');
74
        my $objects   = $class->_objects_cache_get( $cache_key, 'args' );
74
        if ($objects) {
75
        if ($objects) {
75
            $objects->reset;
76
            $objects->reset;
76
        }
77
        } else {
77
        else {
78
            $objects = $class->SUPER::search( $cond, $attrs );
78
            $objects = $class->SUPER::search($cond, $attrs);
79
            $class->_objects_cache_set( $cache_key, $objects, 'args' );
79
            $class->_objects_cache_set($cache_key, $objects, 'args');
80
        }
80
        }
81
        return $objects;
81
        return $objects;
82
    }
82
    }
(-)a/Koha/Objects/Cached/Base.pm (-26 / +78 lines)
Lines 2-8 package Koha::Objects::Cached::Base; Link Here
2
2
3
use Modern::Perl;
3
use Modern::Perl;
4
use Digest::MD5 qw( md5_hex );
4
use Digest::MD5 qw( md5_hex );
5
use Carp qw( croak );
5
use Carp        qw( croak );
6
use JSON;
6
use JSON;
7
use Data::Dumper;
7
use Data::Dumper;
8
8
Lines 16-114 Koha::Objects::Cached::Base Link Here
16
16
17
=head3 _objects_cache_cache_key
17
=head3 _objects_cache_cache_key
18
18
19
my $cache_key = $self->_objects_cache_cache_key($method, @args);
20
21
Get the object/objects cache key for a particular method based on the method arguments.
22
23
=over 8
24
25
=item B<$method>
26
27
The current method, for example "find" or "search".
28
29
=item B<@args>
30
31
The method arguments.
32
33
=back
34
19
=cut
35
=cut
20
36
21
sub _objects_cache_cache_key {
37
sub _objects_cache_cache_key {
22
    my ($self, @args) = @_;
38
    my ( $self, @args ) = @_;
23
    if (@args == 2 && !ref $args[1]) {
39
    if ( @args == 2 && !ref $args[1] ) {
24
        return join(':', @args);
40
        return join( ':', @args );
25
    }
41
    }
42
26
    # JSON is much faster than Data::Dumper but throws
43
    # JSON is much faster than Data::Dumper but throws
27
    # an exception for certain perl data strucures
44
    # an exception for certain perl data structures
28
    # (non boolean scalar refs for example which can
45
    # (non boolean scalar refs for example which can
29
    # be used in DBIx conditions)
46
    # be used in DBIx conditions)
30
    my $cache_key = eval { md5_hex(JSON->new->canonical(1)->encode(\@args)) };
47
    my $cache_key = eval { md5_hex( JSON->new->canonical(1)->encode( \@args ) ) };
31
    if ($cache_key) {
48
    if ($cache_key) {
32
        return $cache_key;
49
        return $cache_key;
33
    } else {
50
    } else {
34
        local $Data::Dumper::Sortkeys = 1;
51
        local $Data::Dumper::Sortkeys = 1;
35
        return md5_hex(Dumper(\@args));
52
        return md5_hex( Dumper( \@args ) );
36
    }
53
    }
37
}
54
}
38
55
39
=head3 _objects_cache_bucket_key
56
=head3 _objects_cache_bucket_key
40
57
58
my $bucket_key = $self->_objects_cache_bucket_key($bucket);
59
60
Get the full cache bucket key of the short hand C<$bucket> name for this object type.
61
62
=over 8
63
64
=item B<$bucket>
65
66
The bucket name, "ids" for the bucket key where objects retrieved by ids are stored,
67
or "args" for the bucket key where objects retrieved by more complex conditions are
68
stored.
69
70
=back
71
41
=cut
72
=cut
42
73
43
sub _objects_cache_bucket_key {
74
sub _objects_cache_bucket_key {
44
    my ($self, $bucket) = @_;
75
    my ( $self, $bucket ) = @_;
45
    my %buckets = (
76
    my %buckets = (
46
        'ids' => 'ObjectsCachedIds',
77
        'ids'  => 'ObjectsCachedIds',
47
        'args' => 'ObjectsCachedArgs'
78
        'args' => 'ObjectsCachedArgs'
48
    );
79
    );
49
    unless (exists $buckets{$bucket}) {
80
    unless ( exists $buckets{$bucket} ) {
50
        croak "Invalid cache bucket $bucket";
81
        croak "Invalid cache bucket $bucket";
51
    }
82
    }
52
    return $self->_type . $buckets{$bucket};
83
    return $self->_type . $buckets{$bucket};
53
84
54
55
}
85
}
56
86
57
=head3 _objects_cache_bucket
87
=head3 _objects_cache_bucket
58
88
89
my $cache = _objects_cache_bucket($bucket);
90
91
Get the memory cache of the short hand C<$bucket> name for this object type.
92
93
=over 8
94
95
=item B<$bucket>
96
97
The bucket name, "ids" for the bucket key where objects retrieved by ids are stored,
98
or "args" for the bucket key where objects retrieved by more complex conditions are
99
stored.
100
101
=back
102
59
=cut
103
=cut
60
104
61
sub _objects_cache_bucket {
105
sub _objects_cache_bucket {
62
    my ($self, $bucket) = @_;
106
    my ( $self, $bucket ) = @_;
63
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
107
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
64
    my $bucket_key = $self->_objects_cache_bucket_key($bucket);
108
    my $bucket_key   = $self->_objects_cache_bucket_key($bucket);
65
    my $cache = $memory_cache->get_from_cache($bucket_key);
109
    my $cache        = $memory_cache->get_from_cache($bucket_key);
66
    unless ($cache) {
110
    unless ($cache) {
67
        $cache = {};
111
        $cache = {};
68
        $memory_cache->set_in_cache($bucket_key, $cache);
112
        $memory_cache->set_in_cache( $bucket_key, $cache );
69
    }
113
    }
70
    return $cache;
114
    return $cache;
71
}
115
}
72
116
73
=head3 _objects_cache_get
117
=head3 _objects_cache_get
74
118
119
my $objects = $self->_objects_cache_get($cache_key, $bucket);
120
121
Get the cached object or objects for the C<$cache_key> and C<$bucket>
122
75
=cut
123
=cut
76
124
77
sub _objects_cache_get {
125
sub _objects_cache_get {
78
    my ($self, $cache_key, $bucket) = @_;
126
    my ( $self, $cache_key, $bucket ) = @_;
79
    my $cache = $self->_objects_cache_bucket($bucket);
127
    my $cache = $self->_objects_cache_bucket($bucket);
80
    return exists $cache->{$cache_key} ? $cache->{$cache_key} : undef;
128
    return exists $cache->{$cache_key} ? $cache->{$cache_key} : undef;
81
}
129
}
82
130
83
=head3 _objects_cache_set
131
=head3 _objects_cache_set
84
132
133
$self->_objects_cache_set($cache_key, $bucket, $object);
134
135
Set the cached object or objects for the C<$cache_key> and C<$bucket>
136
85
=cut
137
=cut
86
138
87
sub _objects_cache_set {
139
sub _objects_cache_set {
88
    my ($self, $cache_key, $object, $bucket) = @_;
140
    my ( $self, $cache_key, $object, $bucket ) = @_;
89
    my $cache = $self->_objects_cache_bucket($bucket);
141
    my $cache = $self->_objects_cache_bucket($bucket);
90
    $cache->{$cache_key} = $object;
142
    $cache->{$cache_key} = $object;
91
}
143
}
92
144
93
=head3 _objects_cache_clear
145
=head3 _objects_cache_clear
94
146
147
$self->_objects_cache_clear($ids_cache_key);
148
149
Clear objects cache, if $ids_cache_key is provided only that
150
key will be purged from the 'ids' cache bucket.
151
95
=cut
152
=cut
96
153
97
sub _objects_cache_clear {
154
sub _objects_cache_clear {
98
    my ($self, $ids_cache_key) = @_;
155
    my ( $self, $ids_cache_key ) = @_;
99
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
156
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
100
    if ($ids_cache_key) {
157
    if ($ids_cache_key) {
101
        my $cache = $self->_objects_cache_bucket('ids');
158
        my $cache = $self->_objects_cache_bucket('ids');
102
        delete $cache->{$ids_cache_key};
159
        delete $cache->{$ids_cache_key};
160
    } else {
161
        $memory_cache->clear_from_cache( $self->_objects_cache_bucket_key('ids') );
103
    }
162
    }
104
    else {
163
    $memory_cache->clear_from_cache( $self->_objects_cache_bucket_key('args') );
105
        $memory_cache->clear_from_cache(
106
            $self->_objects_cache_bucket_key('ids')
107
        );
108
    }
109
    $memory_cache->clear_from_cache(
110
        $self->_objects_cache_bucket_key('args')
111
    );
112
}
164
}
113
165
114
=head1 AUTHOR
166
=head1 AUTHOR
(-)a/acqui/acqui-home.pl (-2 / +1 lines)
Lines 88-94 foreach my $budget ( @{$budget_arr} ) { Link Here
88
    next unless ( CanUserUseBudget( $loggedinpatron, $budget, $userflags ) );
88
    next unless ( CanUserUseBudget( $loggedinpatron, $budget, $userflags ) );
89
89
90
    if ( $budget->{budget_owner_id} ) {
90
    if ( $budget->{budget_owner_id} ) {
91
        $budget->{budget_owner} = Koha::Patrons->find($budget->{budget_owner_id});
91
        $budget->{budget_owner} = Koha::Patrons->find( $budget->{budget_owner_id} );
92
    }
92
    }
93
93
94
    if ( !defined $budget->{budget_amount} ) {
94
    if ( !defined $budget->{budget_amount} ) {
95
- 

Return to bug 36350