From 8b9ce851b2c94d4ad6bd4a37e85cfcc2643f1842 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 Signed-off-by: David Nind --- Koha/Acquisition/Currencies.pm | 2 +- Koha/Object.pm | 2 +- Koha/Object/CachedExpiration.pm | 6 +- Koha/Objects.pm | 2 +- Koha/Objects/Cached.pm | 44 +++++++------- Koha/Objects/Cached/Base.pm | 104 ++++++++++++++++++++++++-------- acqui/acqui-home.pl | 2 +- 7 files changed, 107 insertions(+), 55 deletions(-) diff --git a/Koha/Acquisition/Currencies.pm b/Koha/Acquisition/Currencies.pm index 62486b4dbd..bda6b22d4f 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 abca2df26d..2089255e75 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 ca57ca4b5f..cfc1936c3c 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 9920d895bc..6af9dd2403 100644 --- a/Koha/Objects.pm +++ b/Koha/Objects.pm @@ -143,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); diff --git a/Koha/Objects/Cached.pm b/Koha/Objects/Cached.pm index d21530f7c3..5d968af499 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 ab5569e15c..b6f79424e5 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 bfd0066fcc..c412397ca2 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} ) { -- 2.39.5