From 2a0d9d62878aa5cb8228c1f33ced64ee9d7249a4 Mon Sep 17 00:00:00 2001 From: David Gustafsson Date: Fri, 28 Feb 2025 14:07:15 +0100 Subject: [PATCH] Bug 36350: Fix qa-script issues --- Koha/Acquisition/Currencies.pm | 2 +- Koha/Object.pm | 2 +- Koha/Object/CachedExpiration.pm | 6 +- Koha/Objects.pm | 4 +- Koha/Objects/Cached.pm | 44 ++++++------ Koha/Objects/Cached/Base.pm | 104 +++++++++++++++++++++-------- acqui/acqui-home.pl | 2 +- t/db_dependent/Koha/Libraries.t | 114 ++++++++++++++++---------------- 8 files changed, 165 insertions(+), 113 deletions(-) diff --git a/Koha/Acquisition/Currencies.pm b/Koha/Acquisition/Currencies.pm index cbef0ffd596..e6ab3d7c3c9 100644 --- a/Koha/Acquisition/Currencies.pm +++ b/Koha/Acquisition/Currencies.pm @@ -38,7 +38,7 @@ Koha::Acquisition::Currencies - Koha Acquisition Currency Object set class =cut sub get_active { - my ( $self ) = @_; + my ($self) = @_; return $self->search( { active => 1 } )->next; } diff --git a/Koha/Object.pm b/Koha/Object.pm index c8cecb191d0..64d917dc8fd 100644 --- a/Koha/Object.pm +++ b/Koha/Object.pm @@ -1017,7 +1017,7 @@ sub AUTOLOAD { my $accessor = sub { my $self = shift; if (@_) { - if ($self->isa("Koha::Object::CachedExpiration")) { + if ( $self->isa("Koha::Object::CachedExpiration") ) { $self->_objects_cache_expire(); } $self->_result()->set_column( $method, @_ ); diff --git a/Koha/Object/CachedExpiration.pm b/Koha/Object/CachedExpiration.pm index ca57ca4b5f6..cfc1936c3cd 100644 --- a/Koha/Object/CachedExpiration.pm +++ b/Koha/Object/CachedExpiration.pm @@ -52,9 +52,9 @@ sub store { 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); + 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); } } diff --git a/Koha/Objects.pm b/Koha/Objects.pm index 8f43f0d8924..c98c63f2526 100644 --- a/Koha/Objects.pm +++ b/Koha/Objects.pm @@ -27,7 +27,6 @@ use Scalar::Util qw( reftype ); use Koha::Database; use Koha::Exceptions::Object; - =head1 NAME Koha::Objects - Koha Object set base class @@ -144,7 +143,7 @@ sub search { } ) if defined $attributes; - my $rs = $self->_resultset()->search( $params, $attributes ); + my $rs = $self->_resultset()->search( $params, $attributes ); my $class = ref($self) ? ref($self) : $self; return $class->_new_from_dbic($rs); @@ -332,7 +331,6 @@ sub _build_extended_attributes_relations { 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 index d21530f7c31..5d968af499f 100644 --- a/Koha/Objects/Cached.pm +++ b/Koha/Objects/Cached.pm @@ -26,23 +26,24 @@ 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); + 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 $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); + $object = $class->_objects_cache_get( $cache_key, $cache_bucket ); } - if (!defined $object) { + 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'}) { + $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'}; } @@ -56,27 +57,26 @@ Overloaded I method that provides in memory caching by arguments. =cut sub search { - my ($class, $cond, $attrs) = @_; + 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 { + if ( $has_resultset || !$attrs->{cache} ) { + return $class->SUPER::search( $cond, $attrs ); + } else { my @args; - push(@args , $cond) if defined $cond; + 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'); + 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'); + } else { + $objects = $class->SUPER::search( $cond, $attrs ); + $class->_objects_cache_set( $cache_key, $objects, 'args' ); } return $objects; } diff --git a/Koha/Objects/Cached/Base.pm b/Koha/Objects/Cached/Base.pm index ab5569e15c5..b6f79424e50 100644 --- a/Koha/Objects/Cached/Base.pm +++ b/Koha/Objects/Cached/Base.pm @@ -2,7 +2,7 @@ package Koha::Objects::Cached::Base; use Modern::Perl; use Digest::MD5 qw( md5_hex ); -use Carp qw( croak ); +use Carp qw( croak ); use JSON; use Data::Dumper; @@ -16,99 +16,151 @@ Koha::Objects::Cached::Base =head3 _objects_cache_cache_key +my $cache_key = $self->_objects_cache_cache_key($method, @args); + +Get the object/objects cache key for a particular method based on the method arguments. + +=over 8 + +=item B<$method> + +The current method, for example "find" or "search". + +=item B<@args> + +The method arguments. + +=back + =cut sub _objects_cache_cache_key { - my ($self, @args) = @_; - if (@args == 2 && !ref $args[1]) { - return join(':', @args); + 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 + # an exception for certain perl data structures # (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)) }; + 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)); + return md5_hex( Dumper( \@args ) ); } } =head3 _objects_cache_bucket_key +my $bucket_key = $self->_objects_cache_bucket_key($bucket); + +Get the full cache bucket key of the short hand C<$bucket> name for this object type. + +=over 8 + +=item B<$bucket> + +The bucket name, "ids" for the bucket key where objects retrieved by ids are stored, +or "args" for the bucket key where objects retrieved by more complex conditions are +stored. + +=back + =cut sub _objects_cache_bucket_key { - my ($self, $bucket) = @_; + my ( $self, $bucket ) = @_; my %buckets = ( - 'ids' => 'ObjectsCachedIds', + 'ids' => 'ObjectsCachedIds', 'args' => 'ObjectsCachedArgs' ); - unless (exists $buckets{$bucket}) { + unless ( exists $buckets{$bucket} ) { croak "Invalid cache bucket $bucket"; } return $self->_type . $buckets{$bucket}; - } =head3 _objects_cache_bucket +my $cache = _objects_cache_bucket($bucket); + +Get the memory cache of the short hand C<$bucket> name for this object type. + +=over 8 + +=item B<$bucket> + +The bucket name, "ids" for the bucket key where objects retrieved by ids are stored, +or "args" for the bucket key where objects retrieved by more complex conditions are +stored. + +=back + =cut sub _objects_cache_bucket { - my ($self, $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); + 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); + $memory_cache->set_in_cache( $bucket_key, $cache ); } return $cache; } =head3 _objects_cache_get +my $objects = $self->_objects_cache_get($cache_key, $bucket); + +Get the cached object or objects for the C<$cache_key> and C<$bucket> + =cut sub _objects_cache_get { - my ($self, $cache_key, $bucket) = @_; + 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 +$self->_objects_cache_set($cache_key, $bucket, $object); + +Set the cached object or objects for the C<$cache_key> and C<$bucket> + =cut sub _objects_cache_set { - my ($self, $cache_key, $object, $bucket) = @_; + my ( $self, $cache_key, $object, $bucket ) = @_; my $cache = $self->_objects_cache_bucket($bucket); $cache->{$cache_key} = $object; } =head3 _objects_cache_clear +$self->_objects_cache_clear($ids_cache_key); + +Clear objects cache, if $ids_cache_key is provided only that +key will be purged from the 'ids' cache bucket. + =cut sub _objects_cache_clear { - my ($self, $ids_cache_key) = @_; + 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') ); } - else { - $memory_cache->clear_from_cache( - $self->_objects_cache_bucket_key('ids') - ); - } - $memory_cache->clear_from_cache( - $self->_objects_cache_bucket_key('args') - ); + $memory_cache->clear_from_cache( $self->_objects_cache_bucket_key('args') ); } =head1 AUTHOR diff --git a/acqui/acqui-home.pl b/acqui/acqui-home.pl index 1a650532ee8..0594f2140f3 100755 --- a/acqui/acqui-home.pl +++ b/acqui/acqui-home.pl @@ -88,7 +88,7 @@ foreach my $budget ( @{$budget_arr} ) { next unless ( CanUserUseBudget( $loggedinpatron, $budget, $userflags ) ); if ( $budget->{budget_owner_id} ) { - $budget->{budget_owner} = Koha::Patrons->find($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 6e64524f421..09ea9071421 100755 --- a/t/db_dependent/Koha/Libraries.t +++ b/t/db_dependent/Koha/Libraries.t @@ -517,17 +517,13 @@ subtest 'cache tests' => sub { my $library1 = $builder->build_object( { class => 'Koha::Libraries', - value => { - branchname => 'My library' - } + value => { branchname => 'My library' } } ); my $library2 = $builder->build_object( { class => 'Koha::Libraries', - value => { - branchname => 'My other library' - } + value => { branchname => 'My other library' } } ); @@ -537,24 +533,30 @@ subtest 'cache tests' => sub { 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'); + 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 = 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), + 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'); + 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->_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' @@ -562,36 +564,36 @@ subtest 'cache tests' => sub { $library1->branchname('My expired library'); $cached_library_ids_bucket = Koha::Libraries->_objects_cache_get( - Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode), + Koha::Libraries->_objects_cache_cache_key( 'find', $library1->branchcode ), 'ids' ); - is ( + 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), + Koha::Libraries->_objects_cache_cache_key( 'find', $library2->branchcode ), 'ids' ); - is ( + is( ref($cached_library), 'Koha::Library', 'Cache should still contain other cached libraries' ); - my $stored_library = Koha::Libraries->find($library1->branchcode); - is ( + 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), + Koha::Libraries->_objects_cache_cache_key( 'find', $library1->branchcode ), 'ids' ); - is ( + is( ref($cached_library), 'Koha::Library', 'Library should be cached after previously have been fetched' @@ -599,43 +601,44 @@ subtest 'cache tests' => sub { $library1->store(); $cached_library = Koha::Libraries->_objects_cache_get( - Koha::Libraries->_objects_cache_cache_key('find', $library1->branchcode), + Koha::Libraries->_objects_cache_cache_key( 'find', $library1->branchcode ), 'ids' ); - is ($cached_library, undef, 'Cache has been expired after saving library to database'); + is( $cached_library, undef, 'Cache has been expired after saving library to database' ); - Koha::Libraries->find($library1->branchcode, { key => 'primary' }); + 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' }), + Koha::Libraries->_objects_cache_cache_key( 'find', $library1->branchcode, { key => 'primary' } ), 'args' ); - is ( + 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') { + for my $method ( 'find', 'search' ) { - Koha::Libraries->$method({ branchcode => $library1->branchcode }); - Koha::Libraries->$method({ branchcode => $library2->branchcode }); + 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 }), + Koha::Libraries->_objects_cache_cache_key( $method, { branchcode => $library1->branchcode } ), 'args' ); $cached_library = $method eq 'search' ? $cached_value->next : $cached_value; - is ( + 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') + '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->_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 ( + is( $cached_library->branchname, 'My library in cache', "The cashed library returned by $method should be the cached library, using the args cache bucket" @@ -643,41 +646,40 @@ subtest 'cache tests' => sub { $cached_library->branchname('My expired library'); $cached_value = Koha::Libraries->_objects_cache_get( - Koha::Libraries->_objects_cache_cache_key($method, { branchcode => $library1->branchcode }), + Koha::Libraries->_objects_cache_cache_key( $method, { branchcode => $library1->branchcode } ), 'args' ); - is ( + 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 }), + Koha::Libraries->_objects_cache_cache_key( $method, { branchcode => $library2->branchcode } ), 'args' ); - is ( + is( $cached_value, undef, 'The whole args cache bucket has been emptied after triggering cache expiration' ); } - Koha::Libraries->find($library2->branchcode); + Koha::Libraries->find( $library2->branchcode ); - my $libraries = Koha::Libraries->search({ branchcode => $library1->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'); + 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 }), + Koha::Libraries->_objects_cache_cache_key( 'search', { 'branchcode' => $library1->branchcode } ), 'args' ); - is ( + is( ref($cached_libraries), 'Koha::Libraries', 'Libraries should be cached after previously have been fetched' @@ -685,26 +687,26 @@ subtest 'cache tests' => sub { $library1->delete(); $cached_libraries = Koha::Libraries->_objects_cache_get( - Koha::Libraries->_objects_cache_cache_key('search', { 'branchcode' => $library1->branchcode }), + Koha::Libraries->_objects_cache_cache_key( 'search', { 'branchcode' => $library1->branchcode } ), 'args' ); - is ($cached_libraries, undef, 'Search cache has been expired after deleting library'); + 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), + Koha::Libraries->_objects_cache_cache_key( 'find', $library2->branchcode ), 'ids' ); - is ( + 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), + Koha::Libraries->_objects_cache_cache_key( 'find', $library2->branchcode ), 'ids' ); - is ($cached_library, undef, 'Find cache has been expired after deleting library'); + is( $cached_library, undef, 'Find cache has been expired after deleting library' ); $schema->storage->txn_rollback; -} + } -- 2.34.1