From e77e0ad6840dd2f5105cc584c17581a0a33d3096 Mon Sep 17 00:00:00 2001 From: David Gustafsson Date: Fri, 15 Mar 2024 21:12:33 +0100 Subject: [PATCH] Bug 36350: Add caching for Objects::find and Objects::search Add subclass of Koha::Objects that provides cached find and search. To test: 1) Ensure the following tests pass: - t/db_dependent/Koha/Libraries.t - t/db_dependent/Koha/ItemTypes.t - t/db_dependent/Koha/Patrons.t - t/db_dependent/Koha/Acquisition/Currencies.t Sponsored-by: Gothenburg University Library Signed-off-by: David Nind --- Koha/Acquisition/Currencies.pm | 4 +- Koha/Acquisition/Currency.pm | 2 +- Koha/ILL/Requests.pm | 2 +- Koha/ItemType.pm | 2 +- Koha/ItemTypes.pm | 2 +- Koha/Libraries.pm | 2 +- Koha/Library.pm | 2 +- Koha/Object.pm | 3 + Koha/Object/CachedExpiration.pm | 68 +++++++ Koha/Objects.pm | 193 +++++++++++++++++++ Koha/Objects/Cached.pm | 91 +++++++++ Koha/Objects/Cached/Base.pm | 120 ++++++++++++ Koha/Objects/Mixin/AdditionalFields.pm | 2 - Koha/Objects/Mixin/ExtendedAttributes.pm | 234 ----------------------- Koha/Patron.pm | 16 +- Koha/Patrons.pm | 2 +- acqui/acqui-home.pl | 10 +- t/db_dependent/Koha/Libraries.t | 203 +++++++++++++++++++- 18 files changed, 699 insertions(+), 259 deletions(-) create mode 100644 Koha/Object/CachedExpiration.pm create mode 100644 Koha/Objects/Cached.pm create mode 100644 Koha/Objects/Cached/Base.pm delete mode 100644 Koha/Objects/Mixin/ExtendedAttributes.pm diff --git a/Koha/Acquisition/Currencies.pm b/Koha/Acquisition/Currencies.pm index 42f1d2ff20..0984868889 100644 --- a/Koha/Acquisition/Currencies.pm +++ b/Koha/Acquisition/Currencies.pm @@ -22,7 +22,7 @@ use Koha::Database; use Koha::Acquisition::Currency; -use base qw(Koha::Objects); +use base qw(Koha::Objects::Cached); =head1 NAME @@ -40,7 +40,7 @@ Koha::Acquisition::Currencies - Koha Acquisition Currency Object set class sub get_active { my ( $self ) = @_; - return $self->SUPER::search( { active => 1 } )->next; + return $self->search( { active => 1 } )->next; } =head3 _type diff --git a/Koha/Acquisition/Currency.pm b/Koha/Acquisition/Currency.pm index bf1daaf165..6e3841b31e 100644 --- a/Koha/Acquisition/Currency.pm +++ b/Koha/Acquisition/Currency.pm @@ -20,7 +20,7 @@ use Modern::Perl; use Koha::Database; -use base qw(Koha::Object); +use base qw(Koha::Object::CachedExpiration); =head1 NAME diff --git a/Koha/ILL/Requests.pm b/Koha/ILL/Requests.pm index 3f15d660f3..90ee97a39a 100644 --- a/Koha/ILL/Requests.pm +++ b/Koha/ILL/Requests.pm @@ -23,7 +23,7 @@ use Koha::Database; use Koha::ILL::Request; use Koha::ILL::Request::Config; -use base qw(Koha::Objects::Mixin::ExtendedAttributes Koha::Objects); +use base qw(Koha::Objects); =head1 NAME diff --git a/Koha/ItemType.pm b/Koha/ItemType.pm index f4c0c4aee9..7a65e251fd 100644 --- a/Koha/ItemType.pm +++ b/Koha/ItemType.pm @@ -24,7 +24,7 @@ use Koha::Database; use Koha::CirculationRules; use Koha::Localizations; -use base qw(Koha::Object Koha::Object::Limit::Library); +use base qw(Koha::Object::CachedExpiration Koha::Object::Limit::Library); my $cache = Koha::Caches->get_instance(); diff --git a/Koha/ItemTypes.pm b/Koha/ItemTypes.pm index 13caa648a8..9498a90bf9 100644 --- a/Koha/ItemTypes.pm +++ b/Koha/ItemTypes.pm @@ -23,7 +23,7 @@ use C4::Languages; use Koha::Database; use Koha::ItemType; -use base qw(Koha::Objects Koha::Objects::Limit::Library); +use base qw(Koha::Objects::Cached Koha::Objects::Limit::Library); =head1 NAME diff --git a/Koha/Libraries.pm b/Koha/Libraries.pm index 20ceb8aa34..2ec9020c1d 100644 --- a/Koha/Libraries.pm +++ b/Koha/Libraries.pm @@ -29,7 +29,7 @@ use Koha::Items; use Koha::Library; use Koha::Patrons; -use base qw(Koha::Objects); +use base qw(Koha::Objects::Cached); =head1 NAME diff --git a/Koha/Library.pm b/Koha/Library.pm index 8056c70292..73c1feda97 100644 --- a/Koha/Library.pm +++ b/Koha/Library.pm @@ -29,7 +29,7 @@ use Koha::StockRotationStages; use Koha::SMTP::Servers; use Koha::Library::Hours; -use base qw(Koha::Object); +use base qw(Koha::Object::CachedExpiration); my $cache = Koha::Caches->get_instance(); diff --git a/Koha/Object.pm b/Koha/Object.pm index 8e254623bd..e0a0b15aeb 100644 --- a/Koha/Object.pm +++ b/Koha/Object.pm @@ -1017,6 +1017,9 @@ sub AUTOLOAD { my $accessor = sub { my $self = shift; if (@_) { + if ($self->isa("Koha::Object::CachedExpiration")) { + $self->_objects_cache_expire(); + } $self->_result()->set_column( $method, @_ ); return $self; } else { diff --git a/Koha/Object/CachedExpiration.pm b/Koha/Object/CachedExpiration.pm new file mode 100644 index 0000000000..ca57ca4b5f --- /dev/null +++ b/Koha/Object/CachedExpiration.pm @@ -0,0 +1,68 @@ +package Koha::Object::CachedExpiration; + +use parent qw( Koha::Object Koha::Objects::Cached::Base ); +use Modern::Perl; +use Data::Dumper; + +=head1 NAME + +Koha::Object::CachedExpiration + +=head1 SYNOPSIS + + package Koha::Foo; + + use parent qw( Koha::Object::CachedExpiration ); + +=head1 API + +=head2 Class Methods + +=cut + +=head3 delete + +Overloaded I method for cache expiration + +=cut + +sub delete { + my ($self) = @_; + $self->_objects_cache_expire(); + $self->SUPER::delete(); +} + +=head3 store + +Overloaded I method for cache expiration + +=cut + +sub store { + my ($self) = @_; + $self->_objects_cache_expire(); + $self->SUPER::store(); +} + +=head2 Internal methods + +=head3 _objects_cache_expire + +=cut + +sub _objects_cache_expire { + my ($self) = @_; + if ($self->_result->in_storage) { + my @primary_keys = $self->_result->id; + my $ids_cache_key = $self->_objects_cache_cache_key('find', @primary_keys); + $self->_objects_cache_clear($ids_cache_key); + } +} + +=head1 AUTHOR + +David Gustafsson + +=cut + +1; diff --git a/Koha/Objects.pm b/Koha/Objects.pm index 3bd1e77886..e556719863 100644 --- a/Koha/Objects.pm +++ b/Koha/Objects.pm @@ -22,10 +22,12 @@ use Modern::Perl; use Carp qw( carp ); use List::MoreUtils qw( none ); use Class::Inspector; +use Scalar::Util qw( reftype ); use Koha::Database; use Koha::Exceptions::Object; + =head1 NAME Koha::Objects - Koha Object set base class @@ -136,11 +138,202 @@ sub search { my ( $self, $params, $attributes ) = @_; my $class = ref($self) ? ref($self) : $self; + + $self->handle_query_extended_attributes( + { + attributes => $attributes, + filtered_params => $params, + } + ) if defined $attributes; + my $rs = $self->_resultset()->search($params, $attributes); return $class->_new_from_dbic($rs); } +=head3 handle_query_extended_attributes + + Checks for the presence of extended_attributes in a query + If present, it builds the dynamic extended attributes relations and rewrites the query to include the extended_attributes relation + +=cut + +sub handle_query_extended_attributes { + my ( $self, $args ) = @_; + + my $attributes = $args->{attributes}; + my $filtered_params = $args->{filtered_params}; + + if ( reftype( $attributes->{prefetch} ) + && reftype( $attributes->{prefetch} ) eq 'ARRAY' + && grep ( /extended_attributes/, @{ $attributes->{prefetch} } ) ) + { + + my @array = $self->_get_extended_attributes_entries($filtered_params); + + # Calling our private method to build the extended attributes relations + my @joins = $self->_build_extended_attributes_relations( \@array ); + push @{ $attributes->{join} }, @joins; + + } +} + +=head3 _get_extended_attributes_entries + + $self->_get_extended_attributes_entries( $filtered_params, 0 ) + +Recursive function that returns the rewritten extended_attributes query entries. + +Given: +[ + '-and', + [ + { + 'extended_attributes.code' => 'CODE_1', + 'extended_attributes.attribute' => { 'like' => '%Bar%' } + }, + { + 'extended_attributes.attribute' => { 'like' => '%Bar%' }, + 'extended_attributes.code' => 'CODE_2' + } + ] +]; + +Returns : + +[ + 'CODE_1', + 'CODE_2' +] + +=cut + +sub _get_extended_attributes_entries { + my ( $self, $params, @array ) = @_; + + if ( reftype($params) && reftype($params) eq 'HASH' ) { + + # rewrite additional_field_values table query params + @array = _rewrite_related_metadata_query( $params, 'field_id', 'value', @array ) + if $params->{'extended_attributes.field_id'}; + + # rewrite borrower_attributes table query params + @array = _rewrite_related_metadata_query( $params, 'code', 'attribute', @array ) + if $params->{'extended_attributes.code'}; + + # rewrite illrequestattributes table query params + @array = _rewrite_related_metadata_query( $params, 'type', 'value', @array ) + if $params->{'extended_attributes.type'}; + + foreach my $key ( keys %{$params} ) { + return $self->_get_extended_attributes_entries( $params->{$key}, @array ); + } + } elsif ( reftype($params) && reftype($params) eq 'ARRAY' ) { + foreach my $ea_instance (@$params) { + @array = $self->_get_extended_attributes_entries( $ea_instance, @array ); + } + return @array; + } else { + return @array; + } +} + +=head3 _rewrite_related_metadata_query + + $extended_attributes_entries = + _rewrite_related_metadata_query( $params, 'field_id', 'value', @array ) + +Helper function that rewrites all subsequent extended_attributes queries to match the alias generated by the dbic self left join +Take the below example (patrons): + [ + { + "extended_attributes.attribute":{"like":"%123%"}, + "extended_attributes.code":"CODE_1" + } + ], + [ + { + "extended_attributes.attribute":{"like":"%abc%" }, + "extended_attributes.code":"CODE_2" + } + ] + +It'll be rewritten as: + [ + { + 'extended_attributes_CODE_1.attribute' => { 'like' => '%123%' }, + 'extended_attributes_CODE_1.code' => 'CODE_1' + } + ], + [ + { + 'extended_attributes_CODE_2.attribute' => { 'like' => '%abc%' }, + 'extended_attributes_CODE_2.code' => 'CODE_2' + } + ] + +=cut + +sub _rewrite_related_metadata_query { + my ( $params, $key, $value, @array ) = @_; + + if ( ref \$params->{ 'extended_attributes.' . $key } eq 'SCALAR' ) { + my $old_key_value = delete $params->{ 'extended_attributes.' . $key }; + my $new_key_value = "extended_attributes_$old_key_value" . "." . $key; + $params->{$new_key_value} = $old_key_value; + + my $old_value_value = delete $params->{ 'extended_attributes.' . $value }; + my $new_value_value = "extended_attributes_$old_key_value" . "." . $value; + $params->{$new_value_value} = $old_value_value; + push @array, $old_key_value; + } + + return @array; +} + +=head3 _build_extended_attributes_relations + + Method to dynamically add has_many relations for Koha classes that support extended_attributes. + + Returns a list of relation accessor names. + +=cut + +sub _build_extended_attributes_relations { + my ( $self, $types ) = @_; + + return if ( !grep ( /extended_attributes/, keys %{ $self->_resultset->result_source->_relationships } ) ); + + my $ea_config = $self->extended_attributes_config; + + my $result_source = $self->_resultset->result_source; + for my $type ( @{$types} ) { + $result_source->add_relationship( + "extended_attributes_$type", + "$ea_config->{schema_class}", + sub { + my $args = shift; + + return { + "$args->{foreign_alias}.$ea_config->{id_field}->{foreign}" => + { -ident => "$args->{self_alias}.$ea_config->{id_field}->{self}" }, + "$args->{foreign_alias}.$ea_config->{key_field}" => { '=', $type }, + }; + }, + { + accessor => 'multi', + join_type => 'LEFT', + cascade_copy => 0, + cascade_delete => 0, + is_depends_on => 0 + }, + ); + + } + return map { 'extended_attributes_' . $_ } @{$types}; +} + + =head3 search_related my $objects = Koha::Objects->search_related( $rel_name, $cond?, \%attrs? ); diff --git a/Koha/Objects/Cached.pm b/Koha/Objects/Cached.pm new file mode 100644 index 0000000000..d21530f7c3 --- /dev/null +++ b/Koha/Objects/Cached.pm @@ -0,0 +1,91 @@ +package Koha::Objects::Cached; + +use parent qw( Koha::Objects Koha::Objects::Cached::Base ); +use Modern::Perl; + +=head1 NAME + +Koha::Object::Cached + +=head1 SYNOPSIS + + package Koha::Foo; + + use parent qw( Koha:Objects::Cached ); + +=head1 API + +=head2 Class Methods + +=cut + +=head3 find + +Overloaded I method that provides in memory caching by arguments. + +=cut + +sub find { + my ($class, @args) = @_; + my $cache_key = $class->_objects_cache_cache_key('find', @args); + # Store in the args bucket if has column value condiditions + # or for some reason the attributes argument is provided + my $has_options = @args > 1 && ref $args[$#args] eq 'HASH'; + my $cache = !($has_options && defined $args[$#args]->{cache} && !$args[$#args]->{cache}); + my $cache_bucket = ref $args[0] eq 'HASH' || $has_options ? 'args' : 'ids'; + my $object; + if ($cache) { + $object = $class->_objects_cache_get($cache_key, $cache_bucket); + } + if (!defined $object) { + $object = $class->SUPER::find(@args); + $object //= 'undef'; + $class->_objects_cache_set($cache_key, $object, $cache_bucket) if $cache; + } + elsif ($object ne 'undef' && defined $object->{'_cache'}) { + # Clear object cache if set + delete $object->{'_cache'}; + } + return $object eq 'undef' ? undef : $object; +} + +=head3 search + +Overloaded I method that provides in memory caching by arguments. + +=cut + +sub search { + my ($class, $cond, $attrs) = @_; + my $has_resultset = ref($class) && $class->{_resultset}; + $attrs //= {}; + $attrs->{cache} //= 1 unless $has_resultset; + + if ($has_resultset || !$attrs->{cache}) { + return $class->SUPER::search($cond, $attrs); + } + else { + my @args; + push(@args , $cond) if defined $cond; + # Don't include if only contains "cache" key + push(@args, $attrs) unless keys %{$attrs} == 1 && defined $attrs->{cache}; + my $cache_key = $class->_objects_cache_cache_key('search', @args); + my $objects = $class->_objects_cache_get($cache_key, 'args'); + if ($objects) { + $objects->reset; + } + else { + $objects = $class->SUPER::search($cond, $attrs); + $class->_objects_cache_set($cache_key, $objects, 'args'); + } + return $objects; + } +} + +=head1 AUTHOR + +David Gustafsson + +=cut + +1; diff --git a/Koha/Objects/Cached/Base.pm b/Koha/Objects/Cached/Base.pm new file mode 100644 index 0000000000..ab5569e15c --- /dev/null +++ b/Koha/Objects/Cached/Base.pm @@ -0,0 +1,120 @@ +package Koha::Objects::Cached::Base; + +use Modern::Perl; +use Digest::MD5 qw( md5_hex ); +use Carp qw( croak ); +use JSON; +use Data::Dumper; + +use Koha::Cache::Memory::Lite; + +=head1 NAME + +Koha::Objects::Cached::Base + +=head2 Internal methods + +=head3 _objects_cache_cache_key + +=cut + +sub _objects_cache_cache_key { + my ($self, @args) = @_; + if (@args == 2 && !ref $args[1]) { + return join(':', @args); + } + # JSON is much faster than Data::Dumper but throws + # an exception for certain perl data strucures + # (non boolean scalar refs for example which can + # be used in DBIx conditions) + my $cache_key = eval { md5_hex(JSON->new->canonical(1)->encode(\@args)) }; + if ($cache_key) { + return $cache_key; + } else { + local $Data::Dumper::Sortkeys = 1; + return md5_hex(Dumper(\@args)); + } +} + +=head3 _objects_cache_bucket_key + +=cut + +sub _objects_cache_bucket_key { + my ($self, $bucket) = @_; + my %buckets = ( + 'ids' => 'ObjectsCachedIds', + 'args' => 'ObjectsCachedArgs' + ); + unless (exists $buckets{$bucket}) { + croak "Invalid cache bucket $bucket"; + } + return $self->_type . $buckets{$bucket}; + + +} + +=head3 _objects_cache_bucket + +=cut + +sub _objects_cache_bucket { + my ($self, $bucket) = @_; + my $memory_cache = Koha::Cache::Memory::Lite->get_instance(); + my $bucket_key = $self->_objects_cache_bucket_key($bucket); + my $cache = $memory_cache->get_from_cache($bucket_key); + unless ($cache) { + $cache = {}; + $memory_cache->set_in_cache($bucket_key, $cache); + } + return $cache; +} + +=head3 _objects_cache_get + +=cut + +sub _objects_cache_get { + my ($self, $cache_key, $bucket) = @_; + my $cache = $self->_objects_cache_bucket($bucket); + return exists $cache->{$cache_key} ? $cache->{$cache_key} : undef; +} + +=head3 _objects_cache_set + +=cut + +sub _objects_cache_set { + my ($self, $cache_key, $object, $bucket) = @_; + my $cache = $self->_objects_cache_bucket($bucket); + $cache->{$cache_key} = $object; +} + +=head3 _objects_cache_clear + +=cut + +sub _objects_cache_clear { + my ($self, $ids_cache_key) = @_; + my $memory_cache = Koha::Cache::Memory::Lite->get_instance(); + if ($ids_cache_key) { + my $cache = $self->_objects_cache_bucket('ids'); + delete $cache->{$ids_cache_key}; + } + else { + $memory_cache->clear_from_cache( + $self->_objects_cache_bucket_key('ids') + ); + } + $memory_cache->clear_from_cache( + $self->_objects_cache_bucket_key('args') + ); +} + +=head1 AUTHOR + +David Gustafsson + +=cut + +1; diff --git a/Koha/Objects/Mixin/AdditionalFields.pm b/Koha/Objects/Mixin/AdditionalFields.pm index 1fe79af4a5..113f71a9cf 100644 --- a/Koha/Objects/Mixin/AdditionalFields.pm +++ b/Koha/Objects/Mixin/AdditionalFields.pm @@ -2,8 +2,6 @@ package Koha::Objects::Mixin::AdditionalFields; use Modern::Perl; -use base qw(Koha::Objects::Mixin::ExtendedAttributes); - =head1 NAME Koha::Objects::Mixin::AdditionalFields diff --git a/Koha/Objects/Mixin/ExtendedAttributes.pm b/Koha/Objects/Mixin/ExtendedAttributes.pm deleted file mode 100644 index f18bb006d2..0000000000 --- a/Koha/Objects/Mixin/ExtendedAttributes.pm +++ /dev/null @@ -1,234 +0,0 @@ -package Koha::Objects::Mixin::ExtendedAttributes; - -# Copyright 2024 PTFS Europe Ltd -# -# This file is part of Koha. -# -# Koha is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 3 of the License, or -# (at your option) any later version. -# -# Koha is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with Koha; if not, see . - -use Modern::Perl; -use Scalar::Util qw( reftype ); - -=head1 NAME - -Koha::Objects::Mixin::ExtendedAttributes - -=head2 Class methods - - -=head3 search - - Overwrites the search method to include extended attributes rewrite and dynamic relation accessors - -=cut - -sub search { - my ( $self, $params, $attributes ) = @_; - - my $class = ref($self) ? ref($self) : $self; - - $self->handle_query_extended_attributes( - { - attributes => $attributes, - filtered_params => $params, - } - ); - - my $rs = $self->_resultset()->search( $params, $attributes ); - return $class->_new_from_dbic($rs); -} - -=head3 handle_query_extended_attributes - - Checks for the presence of extended_attributes in a query - If present, it builds the dynamic extended attributes relations and rewrites the query to include the extended_attributes relation - -=cut - -sub handle_query_extended_attributes { - my ( $self, $args ) = @_; - - my $attributes = $args->{attributes}; - my $filtered_params = $args->{filtered_params}; - - if ( reftype( $attributes->{prefetch} ) - && reftype( $attributes->{prefetch} ) eq 'ARRAY' - && grep ( /extended_attributes/, @{ $attributes->{prefetch} } ) ) - { - - my @array = $self->_get_extended_attributes_entries($filtered_params); - - # Calling our private method to build the extended attributes relations - my @joins = $self->_build_extended_attributes_relations( \@array ); - push @{ $attributes->{join} }, @joins; - - } -} - -=head3 _get_extended_attributes_entries - - $self->_get_extended_attributes_entries( $filtered_params, 0 ) - -Recursive function that returns the rewritten extended_attributes query entries. - -Given: -[ - '-and', - [ - { - 'extended_attributes.code' => 'CODE_1', - 'extended_attributes.attribute' => { 'like' => '%Bar%' } - }, - { - 'extended_attributes.attribute' => { 'like' => '%Bar%' }, - 'extended_attributes.code' => 'CODE_2' - } - ] -]; - -Returns : - -[ - 'CODE_1', - 'CODE_2' -] - -=cut - -sub _get_extended_attributes_entries { - my ( $self, $params, @array ) = @_; - - if ( reftype($params) && reftype($params) eq 'HASH' ) { - - # rewrite additional_field_values table query params - @array = _rewrite_related_metadata_query( $params, 'field_id', 'value', @array ) - if $params->{'extended_attributes.field_id'}; - - # rewrite borrower_attributes table query params - @array = _rewrite_related_metadata_query( $params, 'code', 'attribute', @array ) - if $params->{'extended_attributes.code'}; - - # rewrite illrequestattributes table query params - @array = _rewrite_related_metadata_query( $params, 'type', 'value', @array ) - if $params->{'extended_attributes.type'}; - - foreach my $key ( keys %{$params} ) { - return $self->_get_extended_attributes_entries( $params->{$key}, @array ); - } - } elsif ( reftype($params) && reftype($params) eq 'ARRAY' ) { - foreach my $ea_instance (@$params) { - @array = $self->_get_extended_attributes_entries( $ea_instance, @array ); - } - return @array; - } else { - return @array; - } -} - -=head3 _rewrite_related_metadata_query - - $extended_attributes_entries = - _rewrite_related_metadata_query( $params, 'field_id', 'value', @array ) - -Helper function that rewrites all subsequent extended_attributes queries to match the alias generated by the dbic self left join -Take the below example (patrons): - [ - { - "extended_attributes.attribute":{"like":"%123%"}, - "extended_attributes.code":"CODE_1" - } - ], - [ - { - "extended_attributes.attribute":{"like":"%abc%" }, - "extended_attributes.code":"CODE_2" - } - ] - -It'll be rewritten as: - [ - { - 'extended_attributes_CODE_1.attribute' => { 'like' => '%123%' }, - 'extended_attributes_CODE_1.code' => 'CODE_1' - } - ], - [ - { - 'extended_attributes_CODE_2.attribute' => { 'like' => '%abc%' }, - 'extended_attributes_CODE_2.code' => 'CODE_2' - } - ] - -=cut - -sub _rewrite_related_metadata_query { - my ( $params, $key, $value, @array ) = @_; - - if ( ref \$params->{ 'extended_attributes.' . $key } eq 'SCALAR' ) { - my $old_key_value = delete $params->{ 'extended_attributes.' . $key }; - my $new_key_value = "extended_attributes_$old_key_value" . "." . $key; - $params->{$new_key_value} = $old_key_value; - - my $old_value_value = delete $params->{ 'extended_attributes.' . $value }; - my $new_value_value = "extended_attributes_$old_key_value" . "." . $value; - $params->{$new_value_value} = $old_value_value; - push @array, $old_key_value; - } - - return @array; -} - -=head3 _build_extended_attributes_relations - - Method to dynamically add has_many relations for Koha classes that support extended_attributes. - - Returns a list of relation accessor names. - -=cut - -sub _build_extended_attributes_relations { - my ( $self, $types ) = @_; - - return if ( !grep ( /extended_attributes/, keys %{ $self->_resultset->result_source->_relationships } ) ); - - my $ea_config = $self->extended_attributes_config; - - my $result_source = $self->_resultset->result_source; - for my $type ( @{$types} ) { - $result_source->add_relationship( - "extended_attributes_$type", - "$ea_config->{schema_class}", - sub { - my $args = shift; - - return { - "$args->{foreign_alias}.$ea_config->{id_field}->{foreign}" => - { -ident => "$args->{self_alias}.$ea_config->{id_field}->{self}" }, - "$args->{foreign_alias}.$ea_config->{key_field}" => { '=', $type }, - }; - }, - { - accessor => 'multi', - join_type => 'LEFT', - cascade_copy => 0, - cascade_delete => 0, - is_depends_on => 0 - }, - ); - - } - return map { 'extended_attributes_' . $_ } @{$types}; -} - -1; diff --git a/Koha/Patron.pm b/Koha/Patron.pm index 20ac75196d..b8f009ef3c 100644 --- a/Koha/Patron.pm +++ b/Koha/Patron.pm @@ -67,7 +67,7 @@ use Koha::Subscription::Routinglists; use Koha::Token; use Koha::Virtualshelves; -use base qw(Koha::Object); +use base qw(Koha::Object::CachedExpiration); use constant ADMINISTRATIVE_LOCKOUT => -1; @@ -729,7 +729,9 @@ sub merge_with { next if $patron_id eq $anonymous_patron; - my $patron = Koha::Patrons->find( $patron_id ); + # Don't use cache as this could risk deleting a patron object + # which has a reference outside of this class + my $patron = Koha::Patrons->find( $patron_id, { cache => 0 } ); next unless $patron; @@ -2018,8 +2020,10 @@ sub libraries_where_can_see_things { my $subpermission = $params->{subpermission}; my $group_feature = $params->{group_feature}; - return @{ $self->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} } - if exists( $self->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} ); + $self->{'_cache'} //= {}; + + return @{ $self->{'_cache'}->{"_resetricted_branchcodes:$permission:$subpermission:$group_feature"} } + if exists( $self->{'_cache'}->{"_resetricted_branchcodes:$permission:$subpermission:$group_feature"} ); my $userenv = C4::Context->userenv; @@ -2059,8 +2063,8 @@ sub libraries_where_can_see_things { @restricted_branchcodes = uniq(@restricted_branchcodes); @restricted_branchcodes = sort(@restricted_branchcodes); - $self->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} = \@restricted_branchcodes; - return @{ $self->{"_restricted_branchcodes:$permission:$subpermission:$group_feature"} }; + $self->{'_cache'}->{"_resetricted_branchcodes:$permission:$subpermission:$group_feature"} = \@restricted_branchcodes; + return @{ $self->{'_cache'}->{"_resetricted_branchcodes:$permission:$subpermission:$group_feature"} }; } =head3 has_permission diff --git a/Koha/Patrons.pm b/Koha/Patrons.pm index 04d3bf05f6..21507eb481 100644 --- a/Koha/Patrons.pm +++ b/Koha/Patrons.pm @@ -30,7 +30,7 @@ use Koha::Exceptions::Patron; use Koha::Exceptions::SysPref; use Koha::Patron::Categories; -use base qw(Koha::Objects::Mixin::ExtendedAttributes Koha::Objects); +use base qw(Koha::Objects::Cached); =head1 NAME diff --git a/acqui/acqui-home.pl b/acqui/acqui-home.pl index af1034d309..843697c203 100755 --- a/acqui/acqui-home.pl +++ b/acqui/acqui-home.pl @@ -83,16 +83,12 @@ my $totordered_active = 0; my $totavail_active = 0; my @budget_loop; -my %patrons = ( $loggedinuser => Koha::Patrons->find($loggedinuser) ); -my $loggedinpatron = $patrons{$loggedinuser}->unblessed; +my $loggedinpatron = Koha::Patrons->find($loggedinuser); foreach my $budget ( @{$budget_arr} ) { next unless ( CanUserUseBudget( $loggedinpatron, $budget, $userflags ) ); - if ( my $borrowernumber = $budget->{budget_owner_id} ) { - unless ( exists $patrons{$borrowernumber} ) { - $patrons{$borrowernumber} = Koha::Patrons->find($borrowernumber); - } - $budget->{budget_owner} = $patrons{$borrowernumber}; + if ( $budget->{budget_owner_id} ) { + $budget->{budget_owner} = Koha::Patrons->find($budget->{budget_owner_id}); } if ( !defined $budget->{budget_amount} ) { diff --git a/t/db_dependent/Koha/Libraries.t b/t/db_dependent/Koha/Libraries.t index 5c746d679d..947eb20d3a 100755 --- a/t/db_dependent/Koha/Libraries.t +++ b/t/db_dependent/Koha/Libraries.t @@ -19,7 +19,7 @@ use Modern::Perl; -use Test::More tests => 13; +use Test::More tests => 14; use C4::Biblio; use C4::Context; @@ -32,6 +32,7 @@ use Koha::Library; use Koha::Libraries; use Koha::Database; use Koha::CirculationRules; +use Koha::Cache::Memory::Lite; use t::lib::Mocks; use t::lib::TestBuilder; @@ -413,3 +414,203 @@ subtest 'outgoing_transfers' => sub { $schema->storage->txn_rollback; }; + +subtest 'cache tests' => sub { + plan tests => 24; + + $schema->storage->txn_begin; + + my $library1 = $builder->build_object( + { + class => 'Koha::Libraries', + value => { + branchname => 'My library' + } + } + ); + my $library2 = $builder->build_object( + { + class => 'Koha::Libraries', + value => { + branchname => 'My other library' + } + } + ); + + # Since build_object calls find internally + # we first have to flush the cache since these + # objects are now already cached + Koha::Cache::Memory::Lite->get_instance()->flush(); + + my $ids_bucket = Koha::Libraries->_objects_cache_bucket('ids'); + ok(!%{$ids_bucket}, 'Find cache has been cleared after flushing memory cache'); + + my $cached_library = Koha::Libraries->find($library1->branchcode); + Koha::Libraries->find($library2->branchcode); + + my $cached_library_ids_bucket = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode), + 'ids' + ); + is (ref($cached_library_ids_bucket), 'Koha::Library', 'Library should be cached after previously have been fetched'); + is ($cached_library_ids_bucket->branchcode, $library1->branchcode, 'The cashed library should be the expected library'); + + # Set property of library by-passing the cache expiration logic + # so we can veriy library is not only present in cache by also + # properly retrieved in find + $cached_library->_result->set_column('branchname', 'My library in cache'); + $cached_library = Koha::Libraries->find($library1->branchcode); + is ( + $cached_library->branchname, + 'My library in cache', + 'The cashed library returned by find should be the cached library' + ); + + $library1->branchname('My expired library'); + $cached_library_ids_bucket = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode), + 'ids' + ); + is ( + $cached_library_ids_bucket, + undef, + 'Cache has been expired after changing library property' + ); + + $cached_library = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key('find', $library2->branchcode), + 'ids' + ); + is ( + ref($cached_library), + 'Koha::Library', 'Cache should still contain other cached libraries' + ); + + my $stored_library = Koha::Libraries->find($library1->branchcode); + is ( + $stored_library->branchname, + 'My library', + 'Library is fetched from database after cache has been expired' + ); + + $cached_library = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode), + 'ids' + ); + is ( + ref($cached_library), + 'Koha::Library', + 'Library should be cached after previously have been fetched' + ); + + $library1->store(); + $cached_library = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode), + 'ids' + ); + is ($cached_library, undef, 'Cache has been expired after saving library to database'); + + Koha::Libraries->find($library1->branchcode, { key => 'primary' }); + $cached_library = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode, { key => 'primary' }), + 'args' + ); + is ( + ref($cached_library), + 'Koha::Library', + 'The args cache bucket should be used if find is called with the attrs argument' + ); + my $cached_value; + + for my $method ('find', 'search') { + + Koha::Libraries->$method({ branchcode => $library1->branchcode }); + Koha::Libraries->$method({ branchcode => $library2->branchcode }); + + $cached_value = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key($method, { branchcode => $library1->branchcode }), + 'args' + ); + $cached_library = $method eq 'search' ? $cached_value->next : $cached_value; + is ( + ref($cached_library), + 'Koha::Library', + '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') + ); + + $cached_library->_result->set_column('branchname', 'My library in cache'); + $cached_value = Koha::Libraries->$method({ branchcode => $library1->branchcode }); + $cached_library = $method eq 'search' ? $cached_value->next : $cached_value; + is ( + $cached_library->branchname, + 'My library in cache', + "The cashed library returned by $method should be the cached library, using the args cache bucket" + ); + + $cached_library->branchname('My expired library'); + $cached_value = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key($method, { branchcode => $library1->branchcode }), + 'args' + ); + is ( + $cached_value, + undef, + 'Cache has been expired after changing branchname, using the args cache bucket' + ); + + $cached_value = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key($method, { branchcode => $library2->branchcode }), + 'args' + ); + is ( + $cached_value, + undef, + 'The whole args cache bucket has been emptied after triggering cache expiration' + ); + } + + Koha::Libraries->find($library2->branchcode); + + my $libraries = Koha::Libraries->search({ branchcode => $library1->branchcode }); + $libraries->next; + is($libraries->next, undef, 'Cached libraries search result iterator has been exhausted'); + + $libraries = Koha::Libraries->search({ branchcode => $library1->branchcode }); + is(ref($libraries->next), 'Koha::Library', 'Cached libraries search result iterator has been reset'); + + + my $cached_libraries = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key('search', { 'branchcode' => $library1->branchcode }), + 'args' + ); + is ( + ref($cached_libraries), + 'Koha::Libraries', + 'Libraries should be cached after previously have been fetched' + ); + + $library1->delete(); + $cached_libraries = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key('search', { 'branchcode' => $library1->branchcode }), + 'args' + ); + is ($cached_libraries, undef, 'Search cache has been expired after deleting library'); + + $cached_library = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key('find', $library2->branchcode), + 'ids' + ); + is ( + ref($cached_library), + 'Koha::Library', + 'Library should be cached after previously have been fetched' + ); + $library2->delete(); + $cached_library = Koha::Libraries->_objects_cache_get( + Koha::Libraries->_objects_cache_cache_key('find', $library2->branchcode), + 'ids' + ); + is ($cached_library, undef, 'Find cache has been expired after deleting library'); + + $schema->storage->txn_rollback; +} -- 2.39.5