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

(-)a/Koha/Acquisition/Currencies.pm (-3 / +3 lines)
Lines 21-27 use Koha::Database; Link Here
21
21
22
use Koha::Acquisition::Currency;
22
use Koha::Acquisition::Currency;
23
23
24
use base qw(Koha::Objects);
24
use base qw(Koha::Objects::Cached);
25
25
26
=head1 NAME
26
=head1 NAME
27
27
Lines 38-45 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->SUPER::search( { active => 1 } )->next;
42
    return $self->search( { active => 1 } )->next;
43
}
43
}
44
44
45
=head3 _type
45
=head3 _type
(-)a/Koha/Acquisition/Currency.pm (-1 / +1 lines)
Lines 19-25 use Modern::Perl; Link Here
19
19
20
use Koha::Database;
20
use Koha::Database;
21
21
22
use base qw(Koha::Object);
22
use base qw(Koha::Object::CachedExpiration);
23
23
24
=head1 NAME
24
=head1 NAME
25
25
(-)a/Koha/ILL/Requests.pm (-1 / +1 lines)
Lines 23-29 use Koha::Database; Link Here
23
use Koha::ILL::Request;
23
use Koha::ILL::Request;
24
use Koha::ILL::Request::Config;
24
use Koha::ILL::Request::Config;
25
25
26
use base qw(Koha::Objects::Mixin::ExtendedAttributes Koha::Objects);
26
use base qw(Koha::Objects);
27
27
28
=head1 NAME
28
=head1 NAME
29
29
(-)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 22-28 use C4::Languages; Link Here
22
use Koha::Database;
22
use Koha::Database;
23
use Koha::ItemType;
23
use Koha::ItemType;
24
24
25
use base qw(Koha::Objects Koha::Objects::Limit::Library);
25
use base qw(Koha::Objects::Cached Koha::Objects::Limit::Library);
26
26
27
=head1 NAME
27
=head1 NAME
28
28
(-)a/Koha/Libraries.pm (-1 / +1 lines)
Lines 28-34 use Koha::Items; Link Here
28
use Koha::Library;
28
use Koha::Library;
29
use Koha::Patrons;
29
use Koha::Patrons;
30
30
31
use base qw(Koha::Objects::Mixin::AdditionalFields Koha::Objects);
31
use base qw(Koha::Objects::Mixin::AdditionalFields Koha::Objects::Cached);
32
32
33
=head1 NAME
33
=head1 NAME
34
34
(-)a/Koha/Library.pm (-1 / +1 lines)
Lines 28-34 use Koha::StockRotationStages; Link Here
28
use Koha::SMTP::Servers;
28
use Koha::SMTP::Servers;
29
use Koha::Library::Hours;
29
use Koha::Library::Hours;
30
30
31
use base qw(Koha::Object::Mixin::AdditionalFields Koha::Object);
31
use base qw(Koha::Object::Mixin::AdditionalFields Koha::Object::CachedExpiration);
32
32
33
my $cache = Koha::Caches->get_instance();
33
my $cache = Koha::Caches->get_instance();
34
34
(-)a/Koha/Object.pm (+3 lines)
Lines 1017-1022 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")) {
1021
                    $self->_objects_cache_expire();
1022
                }
1020
                $self->_result()->set_column( $method, @_ );
1023
                $self->_result()->set_column( $method, @_ );
1021
                return $self;
1024
                return $self;
1022
            } else {
1025
            } 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.pm (-1 / +191 lines)
Lines 22-27 use Modern::Perl; Link Here
22
use Carp            qw( carp );
22
use Carp            qw( carp );
23
use List::MoreUtils qw( none );
23
use List::MoreUtils qw( none );
24
use Class::Inspector;
24
use Class::Inspector;
25
use Scalar::Util qw( reftype );
25
26
26
use Koha::Database;
27
use Koha::Database;
27
use Koha::Exceptions::Object;
28
use Koha::Exceptions::Object;
Lines 135-146 based on the query I<$params> and I<$attributes> that are passed (like in DBIC). Link Here
135
sub search {
136
sub search {
136
    my ( $self, $params, $attributes ) = @_;
137
    my ( $self, $params, $attributes ) = @_;
137
138
139
    $self->handle_query_extended_attributes(
140
        {
141
            attributes      => $attributes,
142
            filtered_params => $params,
143
        }
144
    ) if defined $attributes;
145
146
    my $rs = $self->_resultset()->search( $params, $attributes );
138
    my $class = ref($self) ? ref($self) : $self;
147
    my $class = ref($self) ? ref($self) : $self;
139
    my $rs    = $self->_resultset()->search( $params, $attributes );
140
148
141
    return $class->_new_from_dbic($rs);
149
    return $class->_new_from_dbic($rs);
142
}
150
}
143
151
152
=head3 handle_query_extended_attributes
153
154
    Checks for the presence of extended_attributes in a query
155
    If present, it builds the dynamic extended attributes relations and rewrites the query to include the extended_attributes relation
156
157
=cut
158
159
sub handle_query_extended_attributes {
160
    my ( $self, $args ) = @_;
161
162
    my $attributes      = $args->{attributes};
163
    my $filtered_params = $args->{filtered_params};
164
165
    if (   reftype( $attributes->{prefetch} )
166
        && reftype( $attributes->{prefetch} ) eq 'ARRAY'
167
        && grep ( /extended_attributes/, @{ $attributes->{prefetch} } ) )
168
    {
169
170
        my @array = $self->_get_extended_attributes_entries($filtered_params);
171
172
        # Calling our private method to build the extended attributes relations
173
        my @joins = $self->_build_extended_attributes_relations( \@array );
174
        push @{ $attributes->{join} }, @joins;
175
176
    }
177
}
178
179
=head3 _get_extended_attributes_entries
180
181
    $self->_get_extended_attributes_entries( $filtered_params, 0 )
182
183
Recursive function that returns the rewritten extended_attributes query entries.
184
185
Given:
186
[
187
    '-and',
188
    [
189
        {
190
            'extended_attributes.code'      => 'CODE_1',
191
            'extended_attributes.attribute' => { 'like' => '%Bar%' }
192
        },
193
        {
194
            'extended_attributes.attribute' => { 'like' => '%Bar%' },
195
            'extended_attributes.code'      => 'CODE_2'
196
        }
197
    ]
198
];
199
200
Returns :
201
202
[
203
    'CODE_1',
204
    'CODE_2'
205
]
206
207
=cut
208
209
sub _get_extended_attributes_entries {
210
    my ( $self, $params, @array ) = @_;
211
212
    if ( reftype($params) && reftype($params) eq 'HASH' ) {
213
214
        # rewrite additional_field_values table query params
215
        @array = _rewrite_related_metadata_query( $params, 'field_id', 'value', @array )
216
            if $params->{'extended_attributes.field_id'};
217
218
        # rewrite borrower_attributes table query params
219
        @array = _rewrite_related_metadata_query( $params, 'code', 'attribute', @array )
220
            if $params->{'extended_attributes.code'};
221
222
        # rewrite illrequestattributes table query params
223
        @array = _rewrite_related_metadata_query( $params, 'type', 'value', @array )
224
            if $params->{'extended_attributes.type'};
225
226
        foreach my $key ( keys %{$params} ) {
227
            return $self->_get_extended_attributes_entries( $params->{$key}, @array );
228
        }
229
    } elsif ( reftype($params) && reftype($params) eq 'ARRAY' ) {
230
        foreach my $ea_instance (@$params) {
231
            @array = $self->_get_extended_attributes_entries( $ea_instance, @array );
232
        }
233
        return @array;
234
    } else {
235
        return @array;
236
    }
237
}
238
239
=head3 _rewrite_related_metadata_query
240
241
        $extended_attributes_entries =
242
            _rewrite_related_metadata_query( $params, 'field_id', 'value', @array )
243
244
Helper function that rewrites all subsequent extended_attributes queries to match the alias generated by the dbic self left join
245
Take the below example (patrons):
246
        [
247
            {
248
                "extended_attributes.attribute":{"like":"%123%"},
249
                "extended_attributes.code":"CODE_1"
250
            }
251
        ],
252
        [
253
            {
254
                "extended_attributes.attribute":{"like":"%abc%" },
255
                "extended_attributes.code":"CODE_2"
256
            }
257
        ]
258
259
It'll be rewritten as:
260
        [
261
            {
262
                'extended_attributes_CODE_1.attribute' => { 'like' => '%123%' },
263
                'extended_attributes_CODE_1.code' => 'CODE_1'
264
            }
265
        ],
266
            [
267
            {
268
                'extended_attributes_CODE_2.attribute' => { 'like' => '%abc%' },
269
                'extended_attributes_CODE_2.code' => 'CODE_2'
270
            }
271
        ]
272
273
=cut
274
275
sub _rewrite_related_metadata_query {
276
    my ( $params, $key, $value, @array ) = @_;
277
278
    if ( ref \$params->{ 'extended_attributes.' . $key } eq 'SCALAR' ) {
279
        my $old_key_value = delete $params->{ 'extended_attributes.' . $key };
280
        my $new_key_value = "extended_attributes_$old_key_value" . "." . $key;
281
        $params->{$new_key_value} = $old_key_value;
282
283
        my $old_value_value = delete $params->{ 'extended_attributes.' . $value };
284
        my $new_value_value = "extended_attributes_$old_key_value" . "." . $value;
285
        $params->{$new_value_value} = $old_value_value;
286
        push @array, $old_key_value;
287
    }
288
289
    return @array;
290
}
291
292
=head3 _build_extended_attributes_relations
293
294
    Method to dynamically add has_many relations for Koha classes that support extended_attributes.
295
296
    Returns a list of relation accessor names.
297
298
=cut
299
300
sub _build_extended_attributes_relations {
301
    my ( $self, $types ) = @_;
302
303
    return if ( !grep ( /extended_attributes/, keys %{ $self->_resultset->result_source->_relationships } ) );
304
305
    my $ea_config = $self->extended_attributes_config;
306
307
    my $result_source = $self->_resultset->result_source;
308
    for my $type ( @{$types} ) {
309
        $result_source->add_relationship(
310
            "extended_attributes_$type",
311
            "$ea_config->{schema_class}",
312
            sub {
313
                my $args = shift;
314
315
                return {
316
                    "$args->{foreign_alias}.$ea_config->{id_field}->{foreign}" =>
317
                        { -ident => "$args->{self_alias}.$ea_config->{id_field}->{self}" },
318
                    "$args->{foreign_alias}.$ea_config->{key_field}" => { '=', $type },
319
                };
320
            },
321
            {
322
                accessor       => 'multi',
323
                join_type      => 'LEFT',
324
                cascade_copy   => 0,
325
                cascade_delete => 0,
326
                is_depends_on  => 0
327
            },
328
        );
329
330
    }
331
    return map { 'extended_attributes_' . $_ } @{$types};
332
}
333
144
=head3 search_related
334
=head3 search_related
145
335
146
    my $objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
336
    my $objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? );
(-)a/Koha/Objects/Cached.pm (+91 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 $cache_key = $class->_objects_cache_cache_key('find', @args);
31
    # Store in the args bucket if has column value condiditions
32
    # or for some reason the attributes argument is provided
33
    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_bucket = ref $args[0] eq 'HASH' || $has_options ? 'args' : 'ids';
36
    my $object;
37
    if ($cache) {
38
        $object = $class->_objects_cache_get($cache_key, $cache_bucket);
39
    }
40
    if (!defined $object) {
41
        $object = $class->SUPER::find(@args);
42
        $object //= 'undef';
43
        $class->_objects_cache_set($cache_key, $object, $cache_bucket) if $cache;
44
    }
45
    elsif ($object ne 'undef' && defined $object->{'_cache'}) {
46
        # Clear object cache if set
47
        delete $object->{'_cache'};
48
    }
49
    return $object eq 'undef' ? undef : $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
    if ($has_resultset || !$attrs->{cache}) {
65
        return $class->SUPER::search($cond, $attrs);
66
    }
67
    else {
68
        my @args;
69
        push(@args , $cond) if defined $cond;
70
        # Don't include if only contains "cache" key
71
        push(@args, $attrs) unless keys %{$attrs} == 1 && defined $attrs->{cache};
72
        my $cache_key = $class->_objects_cache_cache_key('search', @args);
73
        my $objects = $class->_objects_cache_get($cache_key, 'args');
74
        if ($objects) {
75
            $objects->reset;
76
        }
77
        else {
78
            $objects = $class->SUPER::search($cond, $attrs);
79
            $class->_objects_cache_set($cache_key, $objects, 'args');
80
        }
81
        return $objects;
82
    }
83
}
84
85
=head1 AUTHOR
86
87
David Gustafsson <david.gustafsson@ub.gu.se>
88
89
=cut
90
91
1;
(-)a/Koha/Objects/Cached/Base.pm (+120 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 Carp qw( croak );
6
use JSON;
7
use Data::Dumper;
8
9
use Koha::Cache::Memory::Lite;
10
11
=head1 NAME
12
13
Koha::Objects::Cached::Base
14
15
=head2 Internal methods
16
17
=head3 _objects_cache_cache_key
18
19
=cut
20
21
sub _objects_cache_cache_key {
22
    my ($self, @args) = @_;
23
    if (@args == 2 && !ref $args[1]) {
24
        return join(':', @args);
25
    }
26
    # JSON is much faster than Data::Dumper but throws
27
    # an exception for certain perl data strucures
28
    # (non boolean scalar refs for example which can
29
    # be used in DBIx conditions)
30
    my $cache_key = eval { md5_hex(JSON->new->canonical(1)->encode(\@args)) };
31
    if ($cache_key) {
32
        return $cache_key;
33
    } else {
34
        local $Data::Dumper::Sortkeys = 1;
35
        return md5_hex(Dumper(\@args));
36
    }
37
}
38
39
=head3 _objects_cache_bucket_key
40
41
=cut
42
43
sub _objects_cache_bucket_key {
44
    my ($self, $bucket) = @_;
45
    my %buckets = (
46
        'ids' => 'ObjectsCachedIds',
47
        'args' => 'ObjectsCachedArgs'
48
    );
49
    unless (exists $buckets{$bucket}) {
50
        croak "Invalid cache bucket $bucket";
51
    }
52
    return $self->_type . $buckets{$bucket};
53
54
55
}
56
57
=head3 _objects_cache_bucket
58
59
=cut
60
61
sub _objects_cache_bucket {
62
    my ($self, $bucket) = @_;
63
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
64
    my $bucket_key = $self->_objects_cache_bucket_key($bucket);
65
    my $cache = $memory_cache->get_from_cache($bucket_key);
66
    unless ($cache) {
67
        $cache = {};
68
        $memory_cache->set_in_cache($bucket_key, $cache);
69
    }
70
    return $cache;
71
}
72
73
=head3 _objects_cache_get
74
75
=cut
76
77
sub _objects_cache_get {
78
    my ($self, $cache_key, $bucket) = @_;
79
    my $cache = $self->_objects_cache_bucket($bucket);
80
    return exists $cache->{$cache_key} ? $cache->{$cache_key} : undef;
81
}
82
83
=head3 _objects_cache_set
84
85
=cut
86
87
sub _objects_cache_set {
88
    my ($self, $cache_key, $object, $bucket) = @_;
89
    my $cache = $self->_objects_cache_bucket($bucket);
90
    $cache->{$cache_key} = $object;
91
}
92
93
=head3 _objects_cache_clear
94
95
=cut
96
97
sub _objects_cache_clear {
98
    my ($self, $ids_cache_key) = @_;
99
    my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
100
    if ($ids_cache_key) {
101
        my $cache = $self->_objects_cache_bucket('ids');
102
        delete $cache->{$ids_cache_key};
103
    }
104
    else {
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
}
113
114
=head1 AUTHOR
115
116
David Gustafsson <david.gustafsson@ub.gu.se>
117
118
=cut
119
120
1;
(-)a/Koha/Objects/Mixin/AdditionalFields.pm (-2 lines)
Lines 2-9 package Koha::Objects::Mixin::AdditionalFields; Link Here
2
2
3
use Modern::Perl;
3
use Modern::Perl;
4
4
5
use base qw(Koha::Objects::Mixin::ExtendedAttributes);
6
7
=head1 NAME
5
=head1 NAME
8
6
9
Koha::Objects::Mixin::AdditionalFields
7
Koha::Objects::Mixin::AdditionalFields
(-)a/Koha/Objects/Mixin/ExtendedAttributes.pm (-234 lines)
Lines 1-234 Link Here
1
package Koha::Objects::Mixin::ExtendedAttributes;
2
3
# Copyright 2024 PTFS Europe Ltd
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 <https://www.gnu.org/licenses>.
19
20
use Modern::Perl;
21
use Scalar::Util qw( reftype );
22
23
=head1 NAME
24
25
Koha::Objects::Mixin::ExtendedAttributes
26
27
=head2 Class methods
28
29
30
=head3 search
31
32
    Overwrites the search method to include extended attributes rewrite and dynamic relation accessors
33
34
=cut
35
36
sub search {
37
    my ( $self, $params, $attributes ) = @_;
38
39
    my $class = ref($self) ? ref($self) : $self;
40
41
    $self->handle_query_extended_attributes(
42
        {
43
            attributes      => $attributes,
44
            filtered_params => $params,
45
        }
46
    );
47
48
    my $rs = $self->_resultset()->search( $params, $attributes );
49
    return $class->_new_from_dbic($rs);
50
}
51
52
=head3 handle_query_extended_attributes
53
54
    Checks for the presence of extended_attributes in a query
55
    If present, it builds the dynamic extended attributes relations and rewrites the query to include the extended_attributes relation
56
57
=cut
58
59
sub handle_query_extended_attributes {
60
    my ( $self, $args ) = @_;
61
62
    my $attributes      = $args->{attributes};
63
    my $filtered_params = $args->{filtered_params};
64
65
    if (   reftype( $attributes->{prefetch} )
66
        && reftype( $attributes->{prefetch} ) eq 'ARRAY'
67
        && grep ( /extended_attributes/, @{ $attributes->{prefetch} } ) )
68
    {
69
70
        my @array = $self->_get_extended_attributes_entries($filtered_params);
71
72
        # Calling our private method to build the extended attributes relations
73
        my @joins = $self->_build_extended_attributes_relations( \@array );
74
        push @{ $attributes->{join} }, @joins;
75
76
    }
77
}
78
79
=head3 _get_extended_attributes_entries
80
81
    $self->_get_extended_attributes_entries( $filtered_params, 0 )
82
83
Recursive function that returns the rewritten extended_attributes query entries.
84
85
Given:
86
[
87
    '-and',
88
    [
89
        {
90
            'extended_attributes.code'      => 'CODE_1',
91
            'extended_attributes.attribute' => { 'like' => '%Bar%' }
92
        },
93
        {
94
            'extended_attributes.attribute' => { 'like' => '%Bar%' },
95
            'extended_attributes.code'      => 'CODE_2'
96
        }
97
    ]
98
];
99
100
Returns :
101
102
[
103
    'CODE_1',
104
    'CODE_2'
105
]
106
107
=cut
108
109
sub _get_extended_attributes_entries {
110
    my ( $self, $params, @array ) = @_;
111
112
    if ( reftype($params) && reftype($params) eq 'HASH' ) {
113
114
        # rewrite additional_field_values table query params
115
        @array = _rewrite_related_metadata_query( $params, 'field_id', 'value', @array )
116
            if $params->{'extended_attributes.field_id'};
117
118
        # rewrite borrower_attributes table query params
119
        @array = _rewrite_related_metadata_query( $params, 'code', 'attribute', @array )
120
            if $params->{'extended_attributes.code'};
121
122
        # rewrite illrequestattributes table query params
123
        @array = _rewrite_related_metadata_query( $params, 'type', 'value', @array )
124
            if $params->{'extended_attributes.type'};
125
126
        foreach my $key ( keys %{$params} ) {
127
            return $self->_get_extended_attributes_entries( $params->{$key}, @array );
128
        }
129
    } elsif ( reftype($params) && reftype($params) eq 'ARRAY' ) {
130
        foreach my $ea_instance (@$params) {
131
            @array = $self->_get_extended_attributes_entries( $ea_instance, @array );
132
        }
133
        return @array;
134
    } else {
135
        return @array;
136
    }
137
}
138
139
=head3 _rewrite_related_metadata_query
140
141
        $extended_attributes_entries =
142
            _rewrite_related_metadata_query( $params, 'field_id', 'value', @array )
143
144
Helper function that rewrites all subsequent extended_attributes queries to match the alias generated by the dbic self left join
145
Take the below example (patrons):
146
        [
147
            {
148
                "extended_attributes.attribute":{"like":"%123%"},
149
                "extended_attributes.code":"CODE_1"
150
            }
151
        ],
152
        [
153
            {
154
                "extended_attributes.attribute":{"like":"%abc%" },
155
                "extended_attributes.code":"CODE_2"
156
            }
157
        ]
158
159
It'll be rewritten as:
160
        [
161
            {
162
                'extended_attributes_CODE_1.attribute' => { 'like' => '%123%' },
163
                'extended_attributes_CODE_1.code' => 'CODE_1'
164
            }
165
        ],
166
            [
167
            {
168
                'extended_attributes_CODE_2.attribute' => { 'like' => '%abc%' },
169
                'extended_attributes_CODE_2.code' => 'CODE_2'
170
            }
171
        ]
172
173
=cut
174
175
sub _rewrite_related_metadata_query {
176
    my ( $params, $key, $value, @array ) = @_;
177
178
    if ( ref \$params->{ 'extended_attributes.' . $key } eq 'SCALAR' ) {
179
        my $old_key_value = delete $params->{ 'extended_attributes.' . $key };
180
        my $new_key_value = "extended_attributes_$old_key_value" . "." . $key;
181
        $params->{$new_key_value} = $old_key_value;
182
183
        my $old_value_value = delete $params->{ 'extended_attributes.' . $value };
184
        my $new_value_value = "extended_attributes_$old_key_value" . "." . $value;
185
        $params->{$new_value_value} = $old_value_value;
186
        push @array, $old_key_value;
187
    }
188
189
    return @array;
190
}
191
192
=head3 _build_extended_attributes_relations
193
194
    Method to dynamically add has_many relations for Koha classes that support extended_attributes.
195
196
    Returns a list of relation accessor names.
197
198
=cut
199
200
sub _build_extended_attributes_relations {
201
    my ( $self, $types ) = @_;
202
203
    return if ( !grep ( /extended_attributes/, keys %{ $self->_resultset->result_source->_relationships } ) );
204
205
    my $ea_config = $self->extended_attributes_config;
206
207
    my $result_source = $self->_resultset->result_source;
208
    for my $type ( @{$types} ) {
209
        $result_source->add_relationship(
210
            "extended_attributes_$type",
211
            "$ea_config->{schema_class}",
212
            sub {
213
                my $args = shift;
214
215
                return {
216
                    "$args->{foreign_alias}.$ea_config->{id_field}->{foreign}" =>
217
                        { -ident => "$args->{self_alias}.$ea_config->{id_field}->{self}" },
218
                    "$args->{foreign_alias}.$ea_config->{key_field}" => { '=', $type },
219
                };
220
            },
221
            {
222
                accessor       => 'multi',
223
                join_type      => 'LEFT',
224
                cascade_copy   => 0,
225
                cascade_delete => 0,
226
                is_depends_on  => 0
227
            },
228
        );
229
230
    }
231
    return map { 'extended_attributes_' . $_ } @{$types};
232
}
233
234
1;
(-)a/Koha/Patron.pm (-6 / +10 lines)
Lines 71-77 use Koha::Subscription::Routinglists; Link Here
71
use Koha::Token;
71
use Koha::Token;
72
use Koha::Virtualshelves;
72
use Koha::Virtualshelves;
73
73
74
use base qw(Koha::Object);
74
use base qw(Koha::Object::CachedExpiration);
75
75
76
use constant ADMINISTRATIVE_LOCKOUT => -1;
76
use constant ADMINISTRATIVE_LOCKOUT => -1;
77
77
Lines 755-761 sub merge_with { Link Here
755
        sub {
755
        sub {
756
            foreach my $patron_id (@patron_ids) {
756
            foreach my $patron_id (@patron_ids) {
757
757
758
                my $patron = Koha::Patrons->find($patron_id);
758
                # Don't use cache as this could risk deleting a patron object
759
                #  which has a reference outside of this class
760
                my $patron = Koha::Patrons->find( $patron_id, { cache => 0 } );
759
761
760
                next unless $patron;
762
                next unless $patron;
761
763
Lines 2374-2381 sub libraries_where_can_see_things { Link Here
2374
    my $subpermission = $params->{subpermission};
2376
    my $subpermission = $params->{subpermission};
2375
    my $group_feature = $params->{group_feature};
2377
    my $group_feature = $params->{group_feature};
2376
2378
2377
    return @{ $self->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} }
2379
    $self->{'_cache'} //= {};
2378
        if exists( $self->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} );
2380
2381
    return @{ $self->{'_cache'}->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} }
2382
        if exists( $self->{'_cache'}->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} );
2379
2383
2380
    my $userenv = C4::Context->userenv;
2384
    my $userenv = C4::Context->userenv;
2381
2385
Lines 2408-2415 sub libraries_where_can_see_things { Link Here
2408
    @restricted_branchcodes = uniq(@restricted_branchcodes);
2412
    @restricted_branchcodes = uniq(@restricted_branchcodes);
2409
    @restricted_branchcodes = sort(@restricted_branchcodes);
2413
    @restricted_branchcodes = sort(@restricted_branchcodes);
2410
2414
2411
    $self->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} = \@restricted_branchcodes;
2415
    $self->{'_cache'}->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} = \@restricted_branchcodes;
2412
    return @{ $self->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} };
2416
    return @{ $self->{'_cache'}->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} };
2413
}
2417
}
2414
2418
2415
=head3 has_permission
2419
=head3 has_permission
(-)a/Koha/Patrons.pm (-1 / +1 lines)
Lines 29-35 use Koha::Exceptions::Patron; Link Here
29
use Koha::Exceptions::SysPref;
29
use Koha::Exceptions::SysPref;
30
use Koha::Patron::Categories;
30
use Koha::Patron::Categories;
31
31
32
use base qw(Koha::Objects::Mixin::ExtendedAttributes Koha::Objects);
32
use base qw(Koha::Objects::Cached);
33
33
34
=head1 NAME
34
=head1 NAME
35
35
(-)a/acqui/acqui-home.pl (-7 / +3 lines)
Lines 83-98 my $totordered_active = 0; Link Here
83
my $totavail_active   = 0;
83
my $totavail_active   = 0;
84
84
85
my @budget_loop;
85
my @budget_loop;
86
my %patrons        = ( $loggedinuser => Koha::Patrons->find($loggedinuser) );
86
my $loggedinpatron = Koha::Patrons->find($loggedinuser);
87
my $loggedinpatron = $patrons{$loggedinuser}->unblessed;
88
foreach my $budget ( @{$budget_arr} ) {
87
foreach my $budget ( @{$budget_arr} ) {
89
    next unless ( CanUserUseBudget( $loggedinpatron, $budget, $userflags ) );
88
    next unless ( CanUserUseBudget( $loggedinpatron, $budget, $userflags ) );
90
89
91
    if ( my $borrowernumber = $budget->{budget_owner_id} ) {
90
    if ( $budget->{budget_owner_id} ) {
92
        unless ( exists $patrons{$borrowernumber} ) {
91
        $budget->{budget_owner} = Koha::Patrons->find($budget->{budget_owner_id});
93
            $patrons{$borrowernumber} = Koha::Patrons->find($borrowernumber);
94
        }
95
        $budget->{budget_owner} = $patrons{$borrowernumber};
96
    }
92
    }
97
93
98
    if ( !defined $budget->{budget_amount} ) {
94
    if ( !defined $budget->{budget_amount} ) {
(-)a/t/db_dependent/Koha/Libraries.t (-2 / +204 lines)
Lines 20-26 Link Here
20
use Modern::Perl;
20
use Modern::Perl;
21
21
22
use Test::NoWarnings;
22
use Test::NoWarnings;
23
use Test::More tests => 14;
23
use Test::More tests => 15;
24
24
25
use C4::Biblio;
25
use C4::Biblio;
26
use C4::Context;
26
use C4::Context;
Lines 33-38 use Koha::Library; Link Here
33
use Koha::Libraries;
33
use Koha::Libraries;
34
use Koha::Database;
34
use Koha::Database;
35
use Koha::CirculationRules;
35
use Koha::CirculationRules;
36
use Koha::Cache::Memory::Lite;
36
37
37
use t::lib::Mocks;
38
use t::lib::Mocks;
38
use t::lib::TestBuilder;
39
use t::lib::TestBuilder;
Lines 507-509 subtest 'outgoing_transfers' => sub { Link Here
507
508
508
    $schema->storage->txn_rollback;
509
    $schema->storage->txn_rollback;
509
};
510
};
510
- 
511
512
subtest 'cache tests' => sub {
513
    plan tests => 24;
514
515
    $schema->storage->txn_begin;
516
517
    my $library1 = $builder->build_object(
518
        {
519
            class => 'Koha::Libraries',
520
            value => { branchname => 'My library' }
521
        }
522
    );
523
    my $library2 = $builder->build_object(
524
        {
525
            class => 'Koha::Libraries',
526
            value => { branchname => 'My other library' }
527
        }
528
    );
529
530
    # Since build_object calls find internally
531
    # we first have to flush the cache since these
532
    # objects are now already cached
533
    Koha::Cache::Memory::Lite->get_instance()->flush();
534
535
    my $ids_bucket = Koha::Libraries->_objects_cache_bucket('ids');
536
    ok( !%{$ids_bucket}, 'Find cache has been cleared after flushing memory cache' );
537
538
    my $cached_library = Koha::Libraries->find( $library1->branchcode );
539
    Koha::Libraries->find( $library2->branchcode );
540
541
    my $cached_library_ids_bucket = Koha::Libraries->_objects_cache_get(
542
        Koha::Libraries->_objects_cache_cache_key( 'find', $library1->branchcode ),
543
        'ids'
544
    );
545
    is(
546
        ref($cached_library_ids_bucket), 'Koha::Library',
547
        'Library should be cached after previously have been fetched'
548
    );
549
    is(
550
        $cached_library_ids_bucket->branchcode, $library1->branchcode,
551
        'The cashed library should be the expected library'
552
    );
553
554
    # Set property of library by-passing the cache expiration logic
555
    # so we can veriy library is not only present in cache by also
556
    # properly retrieved in find
557
    $cached_library->_result->set_column( 'branchname', 'My library in cache' );
558
    $cached_library = Koha::Libraries->find( $library1->branchcode );
559
    is(
560
        $cached_library->branchname,
561
        'My library in cache',
562
        'The cashed library returned by find should be the cached library'
563
    );
564
565
    $library1->branchname('My expired library');
566
    $cached_library_ids_bucket = Koha::Libraries->_objects_cache_get(
567
        Koha::Libraries->_objects_cache_cache_key( 'find', $library1->branchcode ),
568
        'ids'
569
    );
570
    is(
571
        $cached_library_ids_bucket,
572
        undef,
573
        'Cache has been expired after changing library property'
574
    );
575
576
    $cached_library = Koha::Libraries->_objects_cache_get(
577
        Koha::Libraries->_objects_cache_cache_key( 'find', $library2->branchcode ),
578
        'ids'
579
    );
580
    is(
581
        ref($cached_library),
582
        'Koha::Library', 'Cache should still contain other cached libraries'
583
    );
584
585
    my $stored_library = Koha::Libraries->find( $library1->branchcode );
586
    is(
587
        $stored_library->branchname,
588
        'My library',
589
        'Library is fetched from database after cache has been expired'
590
    );
591
592
    $cached_library = Koha::Libraries->_objects_cache_get(
593
        Koha::Libraries->_objects_cache_cache_key( 'find', $library1->branchcode ),
594
        'ids'
595
    );
596
    is(
597
        ref($cached_library),
598
        'Koha::Library',
599
        'Library should be cached after previously have been fetched'
600
    );
601
602
    $library1->store();
603
    $cached_library = Koha::Libraries->_objects_cache_get(
604
        Koha::Libraries->_objects_cache_cache_key( 'find', $library1->branchcode ),
605
        'ids'
606
    );
607
    is( $cached_library, undef, 'Cache has been expired after saving library to database' );
608
609
    Koha::Libraries->find( $library1->branchcode, { key => 'primary' } );
610
    $cached_library = Koha::Libraries->_objects_cache_get(
611
        Koha::Libraries->_objects_cache_cache_key( 'find', $library1->branchcode, { key => 'primary' } ),
612
        'args'
613
    );
614
    is(
615
        ref($cached_library),
616
        'Koha::Library',
617
        'The args cache bucket should be used if find is called with the attrs argument'
618
    );
619
    my $cached_value;
620
621
    for my $method ( 'find', 'search' ) {
622
623
        Koha::Libraries->$method( { branchcode => $library1->branchcode } );
624
        Koha::Libraries->$method( { branchcode => $library2->branchcode } );
625
626
        $cached_value = Koha::Libraries->_objects_cache_get(
627
            Koha::Libraries->_objects_cache_cache_key( $method, { branchcode => $library1->branchcode } ),
628
            'args'
629
        );
630
        $cached_library = $method eq 'search' ? $cached_value->next : $cached_value;
631
        is(
632
            ref($cached_library),
633
            'Koha::Library',
634
            'Library should be cached after previously have been fetched, and use the args cache bucket '
635
                . ( $method eq 'find' ? 'if find was called with column conditions' : 'if search was called' )
636
        );
637
638
        $cached_library->_result->set_column( 'branchname', 'My library in cache' );
639
        $cached_value   = Koha::Libraries->$method( { branchcode => $library1->branchcode } );
640
        $cached_library = $method eq 'search' ? $cached_value->next : $cached_value;
641
        is(
642
            $cached_library->branchname,
643
            'My library in cache',
644
            "The cashed library returned by $method should be the cached library, using the args cache bucket"
645
        );
646
647
        $cached_library->branchname('My expired library');
648
        $cached_value = Koha::Libraries->_objects_cache_get(
649
            Koha::Libraries->_objects_cache_cache_key( $method, { branchcode => $library1->branchcode } ),
650
            'args'
651
        );
652
        is(
653
            $cached_value,
654
            undef,
655
            'Cache has been expired after changing branchname, using the args cache bucket'
656
        );
657
658
        $cached_value = Koha::Libraries->_objects_cache_get(
659
            Koha::Libraries->_objects_cache_cache_key( $method, { branchcode => $library2->branchcode } ),
660
            'args'
661
        );
662
        is(
663
            $cached_value,
664
            undef,
665
            'The whole args cache bucket has been emptied after triggering cache expiration'
666
        );
667
    }
668
669
    Koha::Libraries->find( $library2->branchcode );
670
671
    my $libraries = Koha::Libraries->search( { branchcode => $library1->branchcode } );
672
    $libraries->next;
673
    is( $libraries->next, undef, 'Cached libraries search result iterator has been exhausted' );
674
675
    $libraries = Koha::Libraries->search( { branchcode => $library1->branchcode } );
676
    is( ref( $libraries->next ), 'Koha::Library', 'Cached libraries search result iterator has been reset' );
677
678
    my $cached_libraries = Koha::Libraries->_objects_cache_get(
679
        Koha::Libraries->_objects_cache_cache_key( 'search', { 'branchcode' => $library1->branchcode } ),
680
        'args'
681
    );
682
    is(
683
        ref($cached_libraries),
684
        'Koha::Libraries',
685
        'Libraries should be cached after previously have been fetched'
686
    );
687
688
    $library1->delete();
689
    $cached_libraries = Koha::Libraries->_objects_cache_get(
690
        Koha::Libraries->_objects_cache_cache_key( 'search', { 'branchcode' => $library1->branchcode } ),
691
        'args'
692
    );
693
    is( $cached_libraries, undef, 'Search cache has been expired after deleting library' );
694
695
    $cached_library = Koha::Libraries->_objects_cache_get(
696
        Koha::Libraries->_objects_cache_cache_key( 'find', $library2->branchcode ),
697
        'ids'
698
    );
699
    is(
700
        ref($cached_library),
701
        'Koha::Library',
702
        'Library should be cached after previously have been fetched'
703
    );
704
    $library2->delete();
705
    $cached_library = Koha::Libraries->_objects_cache_get(
706
        Koha::Libraries->_objects_cache_cache_key( 'find', $library2->branchcode ),
707
        'ids'
708
    );
709
    is( $cached_library, undef, 'Find cache has been expired after deleting library' );
710
711
    $schema->storage->txn_rollback;
712
    }

Return to bug 36350