From 8f15e151090235c5a035918b6bbc2b185e0103ec Mon Sep 17 00:00:00 2001 From: Francesco Rivetti Date: Tue, 14 Feb 2017 10:22:28 +0100 Subject: [PATCH] Bug 17941 Adding PureFunctions functionality --- C4/Biblio.pm | 8 +- C4/Circulation.pm | 8 +- C4/Items.pm | 10 +- C4/Members.pm | 7 +- C4/Reserves.pm | 36 ++++-- Koha/Object.pm | 3 + Koha/Objects.pm | 4 +- Koha/Template/Plugin/Branches.pm | 5 +- Koha/Util/PureFunctions.pm | 266 +++++++++++++++++++++++++++++++++++++++ catalogue/detail.pl | 3 + debian/templates/plack.psgi | 39 ++++++ 11 files changed, 358 insertions(+), 31 deletions(-) create mode 100644 Koha/Util/PureFunctions.pm diff --git a/C4/Biblio.pm b/C4/Biblio.pm index 6d0c9bb..6569414 100644 --- a/C4/Biblio.pm +++ b/C4/Biblio.pm @@ -50,9 +50,9 @@ use vars qw(@ISA @EXPORT); use vars qw($debug $cgi_debug); BEGIN { - + require Koha::Util::PureFunctions; require Exporter; - @ISA = qw( Exporter ); + @ISA = qw( Koha::Util::PureFunctions Exporter ); # to add biblios # EXPORTED FUNCTIONS. @@ -761,7 +761,7 @@ the first one is considered. =cut -sub GetBiblioData { +sub GetBiblioData : PureFunction { my ($bibnum) = @_; my $dbh = C4::Context->dbh; @@ -860,7 +860,7 @@ database. =cut #' -sub GetBiblioFromItemNumber { +sub GetBiblioFromItemNumber : PureFunction { my ( $itemnumber, $barcode ) = @_; my $dbh = C4::Context->dbh; my $sth; diff --git a/C4/Circulation.pm b/C4/Circulation.pm index e2cd626..330923e 100644 --- a/C4/Circulation.pm +++ b/C4/Circulation.pm @@ -68,8 +68,10 @@ use Date::Calc qw( use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); BEGIN { + require Koha::Util::PureFunctions; require Exporter; - @ISA = qw(Exporter); + +@ISA = qw(Koha::Util::PureFunctions Exporter ); # FIXME subs that should probably be elsewhere push @EXPORT, qw( @@ -1685,7 +1687,7 @@ Neither C<$branchcode> nor C<$itemtype> should be '*'. =cut -sub GetBranchItemRule { +sub GetBranchItemRule : PureFunction { my ( $branchcode, $itemtype ) = @_; my $dbh = C4::Context->dbh(); my $result = {}; @@ -2617,7 +2619,7 @@ already renewed the loan. $error will contain the reason the renewal can not pro =cut -sub CanBookBeRenewed { +sub CanBookBeRenewed : PureFunction { my ( $borrowernumber, $itemnumber, $override_limit ) = @_; my $dbh = C4::Context->dbh; diff --git a/C4/Items.pm b/C4/Items.pm index 2188ca4..1be9998 100644 --- a/C4/Items.pm +++ b/C4/Items.pm @@ -48,9 +48,9 @@ use Koha::Libraries; use vars qw(@ISA @EXPORT); BEGIN { - - require Exporter; - @ISA = qw( Exporter ); + require Koha::Util::PureFunctions; + require Exporter; + @ISA = qw( Koha::Util::PureFunctions Exporter ); # function exports @EXPORT = qw( @@ -154,7 +154,7 @@ names to values. If C<$serial> is true, include serial publication data. =cut -sub GetItem { +sub GetItem : PureFunction { my ($itemnumber,$barcode, $serial) = @_; my $dbh = C4::Context->dbh; @@ -1302,7 +1302,7 @@ If this is set, it is set to C. =cut -sub GetItemsInfo { +sub GetItemsInfo : PureFunction { my ( $biblionumber ) = @_; my $dbh = C4::Context->dbh; require C4::Languages; diff --git a/C4/Members.pm b/C4/Members.pm index a501041..50079a3 100644 --- a/C4/Members.pm +++ b/C4/Members.pm @@ -56,8 +56,9 @@ if ( ! can_load( modules => { 'Koha::NorwegianPatronDB' => undef } ) ) { BEGIN { $debug = $ENV{DEBUG} || 0; + require Koha::Util::PureFunctions; require Exporter; - @ISA = qw(Exporter); + @ISA = qw(Koha::Util::PureFunctions Exporter); #Get data push @EXPORT, qw( &GetMember @@ -299,7 +300,7 @@ enforced in the routine itself. =cut #' -sub GetMember { +sub GetMember : PureFunction { my ( %information ) = @_; if (exists $information{borrowernumber} && !defined $information{borrowernumber}) { #passing mysql's kohaadmin?? Makes no sense as a query @@ -794,7 +795,7 @@ total amount outstanding for all of the account lines. =cut -sub GetMemberAccountRecords { +sub GetMemberAccountRecords : PureFunction { my ($borrowernumber) = @_; my $dbh = C4::Context->dbh; my @acctlines; diff --git a/C4/Reserves.pm b/C4/Reserves.pm index c078af1..02c0b03 100644 --- a/C4/Reserves.pm +++ b/C4/Reserves.pm @@ -36,6 +36,7 @@ use C4::Members qw(); use C4::Letters; use C4::Log; +use Koha::Util::PureFunctions; use Koha::DateUtils; use Koha::Calendar; use Koha::Database; @@ -99,7 +100,7 @@ This modules provides somes functions to deal with reservations. BEGIN { require Exporter; - @ISA = qw(Exporter); + @ISA = qw(Koha::Util::PureFunctions Exporter); @EXPORT = qw( &AddReserve @@ -457,7 +458,12 @@ sub CanBookBeReserved{ =cut -sub CanItemBeReserved { +sub _IsItemOnHold : PureFunction { + my ($borrowernumber, $itemnumber) = @_; + return Koha::Holds->search( { borrowernumber => $borrowernumber, itemnumber => $itemnumber } )->next() ? 1 : 0 # next() is faster than autoloaded ->count() +} + +sub CanItemBeReserved : PureFunction { my ( $borrowernumber, $itemnumber ) = @_; my $dbh = C4::Context->dbh; @@ -482,8 +488,7 @@ sub CanItemBeReserved { return 'ageRestricted' if $daysToAgeRestriction && $daysToAgeRestriction > 0; # Check that the patron doesn't have an item level hold on this item already - return 'itemAlreadyOnHold' - if Koha::Holds->search( { borrowernumber => $borrowernumber, itemnumber => $itemnumber } )->count(); + return 'itemAlreadyOnHold' if _IsItemOnHold($borrowernumber, $itemnumber); my $controlbranch = C4::Context->preference('ReservesControlBranch'); @@ -1480,7 +1485,7 @@ and canreservefromotherbranches. =cut -sub IsAvailableForItemLevelRequest { +sub IsAvailableForItemLevelRequest : PureFunction { my $item = shift; my $borrower = shift; @@ -1572,7 +1577,7 @@ sub _get_itype { return $itype; } -sub _OnShelfHoldsAllowed { +sub _OnShelfHoldsAllowed : PureFunction { my ($itype,$borrowercategory,$branchcode) = @_; my $issuing_rule = Koha::IssuingRules->get_effective_issuing_rule({ categorycode => $borrowercategory, itemtype => $itype, branchcode => $branchcode }); @@ -1846,6 +1851,14 @@ C. sub _Findgroupreserve { my ( $bibitem, $biblio, $itemnumber, $lookahead, $ignore_borrowers) = @_; + my %ignored = map { $_ => 1 } @$ignore_borrowers; + return grep { + !$ignored{$_->{borrowernumber}} + } _Findgroupreserve_unfiltered($bibitem, $biblio, $itemnumber, $lookahead); +} + +sub _Findgroupreserve_unfiltered : PureFunction { + my ( $bibitem, $biblio, $itemnumber, $lookahead) = @_; my $dbh = C4::Context->dbh; # TODO: consolidate at least the SELECT portion of the first 2 queries to a common $select var. @@ -1879,8 +1892,7 @@ sub _Findgroupreserve { $sth->execute($itemnumber, $lookahead||0); my @results; if ( my $data = $sth->fetchrow_hashref ) { - push( @results, $data ) - unless any{ $data->{borrowernumber} eq $_ } @$ignore_borrowers ; + push( @results, $data ); } return @results if @results; @@ -1914,8 +1926,7 @@ sub _Findgroupreserve { $sth->execute($itemnumber, $lookahead||0); @results = (); if ( my $data = $sth->fetchrow_hashref ) { - push( @results, $data ) - unless any{ $data->{borrowernumber} eq $_ } @$ignore_borrowers ; + push( @results, $data ); } return @results if @results; @@ -1944,8 +1955,7 @@ sub _Findgroupreserve { $sth->execute( $biblio, $itemnumber, $lookahead||0); @results = (); while ( my $data = $sth->fetchrow_hashref ) { - push( @results, $data ) - unless any{ $data->{borrowernumber} eq $_ } @$ignore_borrowers ; + push( @results, $data ); } return @results; } @@ -2447,7 +2457,7 @@ sub CalculatePriority { =cut -sub IsItemOnHoldAndFound { +sub IsItemOnHoldAndFound : PureFunction { my ($itemnumber) = @_; my $rs = Koha::Database->new()->schema()->resultset('Reserve'); diff --git a/Koha/Object.pm b/Koha/Object.pm index 709d7f2..036a9eb 100644 --- a/Koha/Object.pm +++ b/Koha/Object.pm @@ -22,6 +22,9 @@ use Modern::Perl; use Carp; +use Koha::Util::PureFunctions; +use base 'Koha::Util::PureFunctions'; + use Koha::Database; use Koha::Exceptions::Object; diff --git a/Koha/Objects.pm b/Koha/Objects.pm index 9231206..ee372ea 100644 --- a/Koha/Objects.pm +++ b/Koha/Objects.pm @@ -21,7 +21,9 @@ use Modern::Perl; use Carp; +use Koha::Util::PureFunctions; use Koha::Database; +use base 'Koha::Util::PureFunctions'; =head1 NAME @@ -75,7 +77,7 @@ my $object = Koha::Objects->find( { keypart1 => $keypart1, keypart2 => $keypart2 =cut -sub find { +sub find : PureFunction { my ( $self, $id ) = @_; return unless defined($id); diff --git a/Koha/Template/Plugin/Branches.pm b/Koha/Template/Plugin/Branches.pm index 3d17edc..14b04ac 100644 --- a/Koha/Template/Plugin/Branches.pm +++ b/Koha/Template/Plugin/Branches.pm @@ -20,8 +20,9 @@ package Koha::Template::Plugin::Branches; use Modern::Perl; +use Koha::Util::PureFunctions; use Template::Plugin; -use base qw( Template::Plugin ); +use base qw( Koha::Util::PureFunctions Template::Plugin ); use C4::Koha; use C4::Context; @@ -55,7 +56,7 @@ sub GetURL { return $b->{branchurl}; } -sub all { +sub all : PureFunction { my ( $self, $params ) = @_; my $selected = $params->{selected}; my $unfiltered = $params->{unfiltered} || 0; diff --git a/Koha/Util/PureFunctions.pm b/Koha/Util/PureFunctions.pm new file mode 100644 index 0000000..419f631 --- /dev/null +++ b/Koha/Util/PureFunctions.pm @@ -0,0 +1,266 @@ + +use warnings; + +=head1 NAME + +Koha::Util::PureFunctions + +=head1 SYNOPSIS + + package X; + use base 'Koha::Util::PureFunctions'; + + sub GetFoo : PureFunction { + ... + IsValid(...); + } + + sub IsValid : PureFunction { + ... + } + + sub UpdateFoo { + my $foo = GetFoo(); # it's ok, pure functions can be called inside impure functions + } + + + sub MakeBar : ImpureFunction { + } + + sub ListBars : PureFunction { + my @bars = ...; + @bars or push @bars, MakeBar(); # ERROR, you can't call an impure function inside a pure one + } + +=head1 DESCRIPTION + +Pure functions are functions that returns the same results given the same arguments. + +In some cases, and for a strict scope, functions that read data from the database can be seen as pure functions. +E.g. when showing items or members in a long list in a function that DOES NOT change the data on the database. + +There are several cases in Koha where there is a loop over objects that need to be decorated, which will end up calling +the same getter for the same entity over and over again. (e.g.: C4::Members::GetMember, C4::Circulation::GetBranchItemRule or Koha::Objects::find) + +By marking the function (or method) with the PureFunction attribute, you declare that the result of that function SHOULD be reused, provided the caller +is pure. + +=head2 Storage + +every time a pure function is called, it checks if it is inside a "pure" environment already. + +If not, a new environment is created and used to share a "cache" of all the calls. + +If it is, then the "cache" is used to verify if the same requests has been returned in the same "pure" environment. + +Note: it is similar to "scope", but it extends to the callees + +When the first function exits, the whole "pure" environment is destroyed. + +=head2 Pure/Impure + +It is possible to call pure functions from an impure (or untagged) function. but and error will be thrown (at runtime) when a Impure function is called inside a PureFunction + +=head2 Memoize + +It works similarly to the cpan module Memoize, but instead of holding the cached results forever (or an expiry time) it only lives for the "scope" of the pure environment, granting safe results. + +=head2 How it works + +at BEGIN time, all the methods that have one of the pure attributes are replaced by a wrapped function, which performs the caching and statistics, and optionally call the original function. + +there is a lot of magic happening there, which relies on Attribute::Handler, local variables, and function redef. + +=head1 FUNCTIONS + +=head2 pure + + Koha::Util::PureFunctions::pure { + ... + }; + +Utility function that create a "pure" environment if not present. Useful when you want only a part of a function/script to be pure. + +=head1 BUGS AND ISSUE + +This module requires to be extended (use base/parent) by subclasses. + +This can be problematic with Exporter, where subroutines MUST be exported AFTER the module wrap them + +=head1 AUTHOR + +Francesco Rivetti Eoha@oha.itE + +=cut + +package Koha::Util::PureFunctions; +our $DBG; +our $STORE; # the temporary storage (cache) +our @STACK; # the stack of pure only functions +our $HOOKS; + +# this will keep this function private, since lots of objects will inherit +my $fire_hooks = sub { + while (my ($k,$v) = each %$HOOKS) { + eval { + $v->(@_); + 1; + } or warn "error while executing hook '$k': $@"; + } +}; + +use Attribute::Handlers; +use JSON; our $JSON = JSON->new()->utf8(1)->canonical(1)->allow_blessed(1); +use Data::Dumper; +use Time::HiRes qw/time/; + +sub pure(&) { + my ($code) = @_; + local $STORE = $STORE//{}; + my @caller = caller(1); + local @STACK = (@STACK, "$caller[1]:$caller[2]"); + $code->(); +} + + +sub ImpureFunction :ATTR(BEGIN) { + my ($package, $subp, $code, $attr) = @_; + + # get the full name of the function + my $subn = $package."::".*{$subp}{NAME}; + + # prepare the replacement function + my $memo = sub { + # are we in a Pure environment? + $STORE and die "function '$subn' is marked as Impure, but called inside '".$STACK[-1]."'"; + + # call and return the original function + $code->(); + }; + $DBG and print STDERR "redefining '$subn'...\n"; + + # replace the function + no warnings 'redefine'; + *{$subp} = $memo; +} + +sub PureFunction :ATTR(BEGIN) { + my ($package, $subp, $code, $attr) = @_; + + # get the full name of the function + my $name = *{$subp}{NAME}; + my $subn = $package."::".$name; + + # prepare the replacement + my $memo = sub { + # push this function in the pure function stack + local @STACK = (@STACK, $subn); + + # initiate a pure environment if not present already + my $old_store = $STORE; + local $STORE = $STORE//{}; + + # compute a key with the argument list + my $key = $JSON->encode(\@_); + $key = "@".$key if wantarray; # different caches based on wantarray + + $DBG and printf STDERR "$subn : PureFunction(%s)... store: $::STORE\n", $key; + + # find or create the cache for this specific function + my $cache = $STORE->{$subn}//={}; + + my $stats = { + package => $package, + name => $name, + }; + $stats->{new} = 1 unless $old_store; + + if (exists $cache->{$key}) { + # cache HIT + $stats->{hit}++; + } else { + # cache MISS + $stats->{miss}++; + + # measure time + my $t0 = time(); + + if (wantarray) { + $cache->{$key} = [$code->(@_)]; # exceptions will fall thru, no caching for them + } else { + $cache->{$key} = $code->(@_); + } + my $dt = time() - $t0; + $stats->{miss_time} += $dt; + if ($dt>3) { + warn "$subn() took $dt seconds\nargs: $key..." + } + } + $fire_hooks->(%$stats); # unroll the hash, so it can't be modified + + # return the results + if (wantarray) { + return @{$cache->{$key}}; + } else { + return $cache->{$key}; + } + }; + + # replace the function + $DBG and print STDERR "redefining '$subn'...\n"; + no warnings 'redefine'; + *{$subp} = $memo; +} + +# TEST METHOD, works like PureFunction but don't enable an environment and don't do any caching +# usefull to check the effects of a pure function without applying it +sub TrackedFunction :ATTR(BEGIN) { + my ($package, $subp, $code, $attr) = @_; + my $name = *{$subp}{NAME}."?"; + my $subn = $package."::".*{$subp}{NAME}."?"; + my $memo = sub { +#local @STACK = (@STACK, $subn); + my $key = $JSON->encode(\@_); + $key = "A$key" if wantarray; + $DBG and printf STDERR "$subn : TrackedFunction(%s)... store: $::STORE\n", $key; + my $cache = $STORE ? $STORE->{$subn}//{} : {}; + my $stats = { + package => $package, + name => $name, + }; + if (exists $cache->{$key}) { + $stats && $stats->{hit}++; + # fetch anyways + my $t0 = time(); + if (wantarray) { + $cache->{$key} = [$code->(@_)]; # exceptions will fall thru, no caching for them + } else { + $cache->{$key} = $code->(@_); + } + my $dt = time() - $t0; + $stats->{saved_time} += $dt; + } else { + $stats && $stats->{miss}++; + my $t0 = time(); + if (wantarray) { + $cache->{$key} = [$code->(@_)]; # exceptions will fall thru, no caching for them + } else { + $cache->{$key} = $code->(@_); + } + my $dt = time() - $t0; + $stats->{miss_time} += $dt; + } + $fire_hooks->(%$stats); + if (wantarray) { + return @{$cache->{$key}}; + } else { + return $cache->{$key}; + } + }; + $DBG and print STDERR "redefining '$subn'...\n"; + no warnings 'redefine'; + *{$subp} = $memo; +} + +1; + diff --git a/catalogue/detail.pl b/catalogue/detail.pl index a31a0c5..ce4ca24 100755 --- a/catalogue/detail.pl +++ b/catalogue/detail.pl @@ -45,6 +45,8 @@ use Koha::AuthorisedValues; use Koha::Patrons; use Koha::Virtualshelves; +Koha::Util::PureFunctions::pure { + my $query = CGI->new(); my $analyze = $query->param('analyze'); @@ -515,3 +517,4 @@ $template->param (basketsorders => \@baskets_orders); $template->param (basketsdeletedorders => \@baskets_deletedorders); output_html_with_http_headers $query, $cookie, $template->output; +}; diff --git a/debian/templates/plack.psgi b/debian/templates/plack.psgi index 3538b9a..f337013 100644 --- a/debian/templates/plack.psgi +++ b/debian/templates/plack.psgi @@ -66,6 +66,45 @@ my $apiv1 = builder { }; builder { + enable sub { + my $app = shift; + sub { + my $env = shift; + if ($Koha::Util::PureFunctions::STORE) { + warn "PureFunctions still holding a cache?!?"; + } + $Koha::Util::PureFunctions::STORE = undef; # be safe! +# my $stats = {}; +# my $hook = $Koha::Util::PureFunctions::HOOKS->{plack} = sub { +# my %e = @_; +# my $s = $stats->{$e{package}."::".$e{name}} //= {%defaults}; +# my $g = $global->{$e{package}."::".$e{name}} //= {%defaults}; +# $s->{$_} += $e{$_}//0 for keys %$s; +# $g->{$_} += $e{$_}//0 for keys %$g; +# }; + + my $t0 = time(); + my $res = $app->($env); + my $dt = time() - $t0; + + printf STDERR "%s %s elapsed %.3fs\n", scalar(gmtime()), $env->{REQUEST_URI}, $dt; + +# printf STDERR "%-60s %12s %14s\n", "TOTALS", "hit ratio", "count (tot)", "saved time"; +# for my $k (sort keys %$global) { +# my $s = $stats->{$k} // {%defaults}; +# my $g = $global->{$k}; +# my $st = $s->{hit}+$s->{miss}; $st||=1; +# my $s_saved = $s->{miss} ? $s->{miss_time}/$s->{miss}*$s->{hit} : 0; +# my $g_saved = $g->{miss} ? $g->{miss_time}/$g->{miss}*$g->{hit} : 0; +# printf STDERR "%-60s %5.2f%% (%5.2f%%) %5d (%7d) -%5.2fs (-%.2fs) %d\n", +# $k, 100*$s->{hit}/$st, 100*$g->{hit}/($g->{hit}+$g->{miss}), +# $s->{hit}+$s->{miss}, $g->{hit}+$g->{miss}, $s_saved, $g_saved, $s->{new}; +# } + + return $res; + }; + }; + enable "ReverseProxy"; enable "Plack::Middleware::Static"; # + is required so Plack doesn't try to prefix Plack::Middleware:: -- 2.7.4