Attachment #60188 for bug #17941

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




use vars qw($debug $cgi_debug);

BEGIN {
    require Koha::Util::PureFunctions;
    require Exporter;
    @ISA = qw( Koha::Util::PureFunctions Exporter );

    # to add biblios
    # EXPORTED FUNCTIONS.


=cut

sub GetBiblioData : PureFunction {
    my ($bibnum) = @_;
    my $dbh = C4::Context->dbh;


=cut

#'
sub GetBiblioFromItemNumber : PureFunction {
    my ( $itemnumber, $barcode ) = @_;
    my $dbh = C4::Context->dbh;
    my $sth;




use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

BEGIN {
    require Koha::Util::PureFunctions;
	require Exporter;

@ISA    = qw(Koha::Util::PureFunctions Exporter );

	# FIXME subs that should probably be elsewhere
	push @EXPORT, qw(


=cut

sub GetBranchItemRule : PureFunction {
    my ( $branchcode, $itemtype ) = @_;
    my $dbh = C4::Context->dbh();
    my $result = {};


=cut

sub CanBookBeRenewed : PureFunction {
    my ( $borrowernumber, $itemnumber, $override_limit ) = @_;

    my $dbh    = C4::Context->dbh;




use vars qw(@ISA @EXPORT);

BEGIN {
    require Koha::Util::PureFunctions;
    require Exporter;
    @ISA = qw( Koha::Util::PureFunctions Exporter );

    # function exports
    @EXPORT = qw(


=cut

sub GetItem : PureFunction {
    my ($itemnumber,$barcode, $serial) = @_;
    my $dbh = C4::Context->dbh;



=cut

sub GetItemsInfo : PureFunction {
    my ( $biblionumber ) = @_;
    my $dbh   = C4::Context->dbh;
    require C4::Languages;





BEGIN {
    $debug = $ENV{DEBUG} || 0;
    require Koha::Util::PureFunctions;
    require Exporter;
    @ISA = qw(Koha::Util::PureFunctions Exporter);
    #Get data
    push @EXPORT, qw(
        &GetMember

=cut

#'
sub GetMember : PureFunction {
    my ( %information ) = @_;
    if (exists $information{borrowernumber} && !defined $information{borrowernumber}) {
        #passing mysql's kohaadmin?? Makes no sense as a query


=cut

sub GetMemberAccountRecords : PureFunction {
    my ($borrowernumber) = @_;
    my $dbh = C4::Context->dbh;
    my @acctlines;

Lines 36-41 use C4::Members qw(); Link Here

(-)a/C4/Reserves.pm (-13 / +23 lines)
36	use C4::Letters;	36	use C4::Letters;
37	use C4::Log;	37	use C4::Log;
38		38
		39	use Koha::Util::PureFunctions;
39	use Koha::DateUtils;	40	use Koha::DateUtils;
40	use Koha::Calendar;	41	use Koha::Calendar;
41	use Koha::Database;	42	use Koha::Database;
Lines 99-105 This modules provides somes functions to deal with reservations. Link Here
99		100
100	BEGIN {	101	BEGIN {
101	require Exporter;	102	require Exporter;
102	@ISA = qw(Exporter);	103	@ISA = qw(Koha::Util::PureFunctions Exporter);
103	@EXPORT = qw(	104	@EXPORT = qw(
104	&AddReserve	105	&AddReserve
105		106
Lines 457-463 sub CanBookBeReserved{ Link Here
457		458
458	=cut	459	=cut
459		460
460	sub CanItemBeReserved {	461	sub _IsItemOnHold : PureFunction {
		462	my ($borrowernumber, $itemnumber) = @_;
		463	return Koha::Holds->search( { borrowernumber => $borrowernumber, itemnumber => $itemnumber } )->next() ? 1 : 0 # next() is faster than autoloaded ->count()
		464	}
		465
		466	sub CanItemBeReserved : PureFunction {
461	my ( $borrowernumber, $itemnumber ) = @_;	467	my ( $borrowernumber, $itemnumber ) = @_;
462		468
463	my $dbh = C4::Context->dbh;	469	my $dbh = C4::Context->dbh;
Lines 482-489 sub CanItemBeReserved { Link Here
482	return 'ageRestricted' if $daysToAgeRestriction && $daysToAgeRestriction > 0;	488	return 'ageRestricted' if $daysToAgeRestriction && $daysToAgeRestriction > 0;
483		489
484	# Check that the patron doesn't have an item level hold on this item already	490	# Check that the patron doesn't have an item level hold on this item already
485	return 'itemAlreadyOnHold'	491	return 'itemAlreadyOnHold' if _IsItemOnHold($borrowernumber, $itemnumber);
486	if Koha::Holds->search( { borrowernumber => $borrowernumber, itemnumber => $itemnumber } )->count();
487		492
488	my $controlbranch = C4::Context->preference('ReservesControlBranch');	493	my $controlbranch = C4::Context->preference('ReservesControlBranch');
489		494
Lines 1480-1486 and canreservefromotherbranches. Link Here
1480		1485
1481	=cut	1486	=cut
1482		1487
1483	sub IsAvailableForItemLevelRequest {	1488	sub IsAvailableForItemLevelRequest : PureFunction {
1484	my $item = shift;	1489	my $item = shift;
1485	my $borrower = shift;	1490	my $borrower = shift;
1486		1491
Lines 1572-1578 sub _get_itype { Link Here
1572	return $itype;	1577	return $itype;
1573	}	1578	}
1574		1579
1575	sub _OnShelfHoldsAllowed {	1580	sub _OnShelfHoldsAllowed : PureFunction {
1576	my ($itype,$borrowercategory,$branchcode) = @_;	1581	my ($itype,$borrowercategory,$branchcode) = @_;
1577		1582
1578	my $issuing_rule = Koha::IssuingRules->get_effective_issuing_rule({ categorycode => $borrowercategory, itemtype => $itype, branchcode => $branchcode });	1583	my $issuing_rule = Koha::IssuingRules->get_effective_issuing_rule({ categorycode => $borrowercategory, itemtype => $itype, branchcode => $branchcode });
Lines 1846-1851 C<biblioitemnumber>. Link Here
1846		1851
1847	sub _Findgroupreserve {	1852	sub _Findgroupreserve {
1848	my ( $bibitem, $biblio, $itemnumber, $lookahead, $ignore_borrowers) = @_;	1853	my ( $bibitem, $biblio, $itemnumber, $lookahead, $ignore_borrowers) = @_;
		1854	my %ignored = map { $_ => 1 } @$ignore_borrowers;
		1855	return grep {
		1856	!$ignored{$_->{borrowernumber}}
		1857	} _Findgroupreserve_unfiltered($bibitem, $biblio, $itemnumber, $lookahead);
		1858	}
		1859
		1860	sub _Findgroupreserve_unfiltered : PureFunction {
		1861	my ( $bibitem, $biblio, $itemnumber, $lookahead) = @_;
1849	my $dbh = C4::Context->dbh;	1862	my $dbh = C4::Context->dbh;
1850		1863
1851	# TODO: consolidate at least the SELECT portion of the first 2 queries to a common $select var.	1864	# TODO: consolidate at least the SELECT portion of the first 2 queries to a common $select var.
Lines 1879-1886 sub _Findgroupreserve { Link Here
1879	$sth->execute($itemnumber, $lookahead\|\|0);	1892	$sth->execute($itemnumber, $lookahead\|\|0);
1880	my @results;	1893	my @results;
1881	if ( my $data = $sth->fetchrow_hashref ) {	1894	if ( my $data = $sth->fetchrow_hashref ) {
1882	push( @results, $data )	1895	push( @results, $data );
1883	unless any{ $data->{borrowernumber} eq $_ } @$ignore_borrowers ;
1884	}	1896	}
1885	return @results if @results;	1897	return @results if @results;
1886		1898
Lines 1914-1921 sub _Findgroupreserve { Link Here
1914	$sth->execute($itemnumber, $lookahead\|\|0);	1926	$sth->execute($itemnumber, $lookahead\|\|0);
1915	@results = ();	1927	@results = ();
1916	if ( my $data = $sth->fetchrow_hashref ) {	1928	if ( my $data = $sth->fetchrow_hashref ) {
1917	push( @results, $data )	1929	push( @results, $data );
1918	unless any{ $data->{borrowernumber} eq $_ } @$ignore_borrowers ;
1919	}	1930	}
1920	return @results if @results;	1931	return @results if @results;
1921		1932
Lines 1944-1951 sub _Findgroupreserve { Link Here
1944	$sth->execute( $biblio, $itemnumber, $lookahead\|\|0);	1955	$sth->execute( $biblio, $itemnumber, $lookahead\|\|0);
1945	@results = ();	1956	@results = ();
1946	while ( my $data = $sth->fetchrow_hashref ) {	1957	while ( my $data = $sth->fetchrow_hashref ) {
1947	push( @results, $data )	1958	push( @results, $data );
1948	unless any{ $data->{borrowernumber} eq $_ } @$ignore_borrowers ;
1949	}	1959	}
1950	return @results;	1960	return @results;
1951	}	1961	}
Lines 2447-2453 sub CalculatePriority { Link Here
2447		2457
2448	=cut	2458	=cut
2449		2459
2450	sub IsItemOnHoldAndFound {	2460	sub IsItemOnHoldAndFound : PureFunction {
2451	my ($itemnumber) = @_;	2461	my ($itemnumber) = @_;
2452		2462
2453	my $rs = Koha::Database->new()->schema()->resultset('Reserve');	2463	my $rs = Koha::Database->new()->schema()->resultset('Reserve');

Lines 22-27 use Modern::Perl; Link Here

(-)a/Koha/Object.pm (+3 lines)
22		22
23	use Carp;	23	use Carp;
24		24
		25	use Koha::Util::PureFunctions;
		26	use base 'Koha::Util::PureFunctions';
		27
25	use Koha::Database;	28	use Koha::Database;
26	use Koha::Exceptions::Object;	29	use Koha::Exceptions::Object;
27		30





use Carp;

use Koha::Util::PureFunctions;
use Koha::Database;
use base 'Koha::Util::PureFunctions';

=head1 NAME



=cut

sub find : PureFunction {
    my ( $self, $id ) = @_;

    return unless defined($id);





use Modern::Perl;

use Koha::Util::PureFunctions;
use Template::Plugin;
use base qw( Koha::Util::PureFunctions Template::Plugin );

use C4::Koha;
use C4::Context;

    return $b->{branchurl};
}

sub all : PureFunction {
    my ( $self, $params ) = @_;
    my $selected = $params->{selected};
    my $unfiltered = $params->{unfiltered} || 0;





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 E<lt>oha@oha.itE<gt>

=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;


Lines 45-50 use Koha::AuthorisedValues; Link Here

(-)a/catalogue/detail.pl (+3 lines)
45	use Koha::Patrons;	45	use Koha::Patrons;
46	use Koha::Virtualshelves;	46	use Koha::Virtualshelves;
47		47
		48	Koha::Util::PureFunctions::pure {
		49
48	my $query = CGI->new();	50	my $query = CGI->new();
49		51
50	my $analyze = $query->param('analyze');	52	my $analyze = $query->param('analyze');
Lines 515-517 $template->param (basketsorders => \@baskets_orders); Link Here
515	$template->param (basketsdeletedorders => \@baskets_deletedorders);	517	$template->param (basketsdeletedorders => \@baskets_deletedorders);
516		518
517	output_html_with_http_headers $query, $cookie, $template->output;	519	output_html_with_http_headers $query, $cookie, $template->output;
		520	};

Lines 66-71 my $apiv1 = builder { Link Here

(-)a/debian/templates/plack.psgi (-1 / +39 lines)
66	};	66	};
67		67
68	builder {	68	builder {
		69	enable sub {
		70	my $app = shift;
		71	sub {
		72	my $env = shift;
		73	if ($Koha::Util::PureFunctions::STORE) {
		74	warn "PureFunctions still holding a cache?!?";
		75	}
		76	$Koha::Util::PureFunctions::STORE = undef; # be safe!
		77	# my $stats = {};
		78	# my $hook = $Koha::Util::PureFunctions::HOOKS->{plack} = sub {
		79	# my %e = @_;
		80	# my $s = $stats->{$e{package}."::".$e{name}} //= {%defaults};
		81	# my $g = $global->{$e{package}."::".$e{name}} //= {%defaults};
		82	# $s->{$_} += $e{$_}//0 for keys %$s;
		83	# $g->{$_} += $e{$_}//0 for keys %$g;
		84	# };
		85
		86	my $t0 = time();
		87	my $res = $app->($env);
		88	my $dt = time() - $t0;
		89
		90	printf STDERR "%s %s elapsed %.3fs\n", scalar(gmtime()), $env->{REQUEST_URI}, $dt;
		91
		92	# printf STDERR "%-60s %12s %14s\n", "TOTALS", "hit ratio", "count (tot)", "saved time";
		93	# for my $k (sort keys %$global) {
		94	# my $s = $stats->{$k} // {%defaults};
		95	# my $g = $global->{$k};
		96	# my $st = $s->{hit}+$s->{miss}; $st\|\|=1;
		97	# my $s_saved = $s->{miss} ? $s->{miss_time}/$s->{miss}*$s->{hit} : 0;
		98	# my $g_saved = $g->{miss} ? $g->{miss_time}/$g->{miss}*$g->{hit} : 0;
		99	# printf STDERR "%-60s %5.2f%% (%5.2f%%) %5d (%7d) -%5.2fs (-%.2fs) %d\n",
		100	# $k, 100$s->{hit}/$st, 100$g->{hit}/($g->{hit}+$g->{miss}),
		101	# $s->{hit}+$s->{miss}, $g->{hit}+$g->{miss}, $s_saved, $g_saved, $s->{new};
		102	# }
		103
		104	return $res;
		105	};
		106	};
		107
69	enable "ReverseProxy";	108	enable "ReverseProxy";
70	enable "Plack::Middleware::Static";	109	enable "Plack::Middleware::Static";
71	# + is required so Plack doesn't try to prefix Plack::Middleware::	110	# + is required so Plack doesn't try to prefix Plack::Middleware::
72	-

Return to bug 17941

Lines 50-58 use vars qw(@ISA @EXPORT); Link Here

(-)a/C4/Biblio.pm (-4 / +4 lines)
50	use vars qw($debug $cgi_debug);	50	use vars qw($debug $cgi_debug);
51		51
52	BEGIN {	52	BEGIN {
53		53	require Koha::Util::PureFunctions;
54	require Exporter;	54	require Exporter;
55	@ISA = qw( Exporter );	55	@ISA = qw( Koha::Util::PureFunctions Exporter );
56		56
57	# to add biblios	57	# to add biblios
58	# EXPORTED FUNCTIONS.	58	# EXPORTED FUNCTIONS.
Lines 761-767 the first one is considered. Link Here
761		761
762	=cut	762	=cut
763		763
764	sub GetBiblioData {	764	sub GetBiblioData : PureFunction {
765	my ($bibnum) = @_;	765	my ($bibnum) = @_;
766	my $dbh = C4::Context->dbh;	766	my $dbh = C4::Context->dbh;
767		767
Lines 860-866 database. Link Here
860	=cut	860	=cut
861		861
862	#'	862	#'
863	sub GetBiblioFromItemNumber {	863	sub GetBiblioFromItemNumber : PureFunction {
864	my ( $itemnumber, $barcode ) = @_;	864	my ( $itemnumber, $barcode ) = @_;
865	my $dbh = C4::Context->dbh;	865	my $dbh = C4::Context->dbh;
866	my $sth;	866	my $sth;

Lines 68-75 use Date::Calc qw( Link Here

(-)a/C4/Circulation.pm (-3 / +5 lines)
68	use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);	68	use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
69		69
70	BEGIN {	70	BEGIN {
		71	require Koha::Util::PureFunctions;
71	require Exporter;	72	require Exporter;
72	@ISA = qw(Exporter);	73
		74	@ISA = qw(Koha::Util::PureFunctions Exporter );
73		75
74	# FIXME subs that should probably be elsewhere	76	# FIXME subs that should probably be elsewhere
75	push @EXPORT, qw(	77	push @EXPORT, qw(
Lines 1685-1691 Neither C<$branchcode> nor C<$itemtype> should be '*'. Link Here
1685		1687
1686	=cut	1688	=cut
1687		1689
1688	sub GetBranchItemRule {	1690	sub GetBranchItemRule : PureFunction {
1689	my ( $branchcode, $itemtype ) = @_;	1691	my ( $branchcode, $itemtype ) = @_;
1690	my $dbh = C4::Context->dbh();	1692	my $dbh = C4::Context->dbh();
1691	my $result = {};	1693	my $result = {};
Lines 2617-2623 already renewed the loan. $error will contain the reason the renewal can not pro Link Here
2617		2619
2618	=cut	2620	=cut
2619		2621
2620	sub CanBookBeRenewed {	2622	sub CanBookBeRenewed : PureFunction {
2621	my ( $borrowernumber, $itemnumber, $override_limit ) = @_;	2623	my ( $borrowernumber, $itemnumber, $override_limit ) = @_;
2622		2624
2623	my $dbh = C4::Context->dbh;	2625	my $dbh = C4::Context->dbh;

Lines 48-56 use Koha::Libraries; Link Here

(-)a/C4/Items.pm (-5 / +5 lines)
48	use vars qw(@ISA @EXPORT);	48	use vars qw(@ISA @EXPORT);
49		49
50	BEGIN {	50	BEGIN {
51		51	require Koha::Util::PureFunctions;
52	require Exporter;	52	require Exporter;
53	@ISA = qw( Exporter );	53	@ISA = qw( Koha::Util::PureFunctions Exporter );
54		54
55	# function exports	55	# function exports
56	@EXPORT = qw(	56	@EXPORT = qw(
Lines 154-160 names to values. If C<$serial> is true, include serial publication data. Link Here
154		154
155	=cut	155	=cut
156		156
157	sub GetItem {	157	sub GetItem : PureFunction {
158	my ($itemnumber,$barcode, $serial) = @_;	158	my ($itemnumber,$barcode, $serial) = @_;
159	my $dbh = C4::Context->dbh;	159	my $dbh = C4::Context->dbh;
160		160
Lines 1302-1308 If this is set, it is set to C<One Order>. Link Here
1302		1302
1303	=cut	1303	=cut
1304		1304
1305	sub GetItemsInfo {	1305	sub GetItemsInfo : PureFunction {
1306	my ( $biblionumber ) = @_;	1306	my ( $biblionumber ) = @_;
1307	my $dbh = C4::Context->dbh;	1307	my $dbh = C4::Context->dbh;
1308	require C4::Languages;	1308	require C4::Languages;

Lines 56-63 if ( ! can_load( modules => { 'Koha::NorwegianPatronDB' => undef } ) ) { Link Here

(-)a/C4/Members.pm (-3 / +4 lines)
56		56
57	BEGIN {	57	BEGIN {
58	$debug = $ENV{DEBUG} \|\| 0;	58	$debug = $ENV{DEBUG} \|\| 0;
		59	require Koha::Util::PureFunctions;
59	require Exporter;	60	require Exporter;
60	@ISA = qw(Exporter);	61	@ISA = qw(Koha::Util::PureFunctions Exporter);
61	#Get data	62	#Get data
62	push @EXPORT, qw(	63	push @EXPORT, qw(
63	&GetMember	64	&GetMember
Lines 299-305 enforced in the routine itself. Link Here
299	=cut	300	=cut
300		301
301	#'	302	#'
302	sub GetMember {	303	sub GetMember : PureFunction {
303	my ( %information ) = @_;	304	my ( %information ) = @_;
304	if (exists $information{borrowernumber} && !defined $information{borrowernumber}) {	305	if (exists $information{borrowernumber} && !defined $information{borrowernumber}) {
305	#passing mysql's kohaadmin?? Makes no sense as a query	306	#passing mysql's kohaadmin?? Makes no sense as a query
Lines 794-800 total amount outstanding for all of the account lines. Link Here
794		795
795	=cut	796	=cut
796		797
797	sub GetMemberAccountRecords {	798	sub GetMemberAccountRecords : PureFunction {
798	my ($borrowernumber) = @_;	799	my ($borrowernumber) = @_;
799	my $dbh = C4::Context->dbh;	800	my $dbh = C4::Context->dbh;
800	my @acctlines;	801	my @acctlines;

Lines 21-27 use Modern::Perl; Link Here

(-)a/Koha/Objects.pm (-1 / +3 lines)
21		21
22	use Carp;	22	use Carp;
23		23
		24	use Koha::Util::PureFunctions;
24	use Koha::Database;	25	use Koha::Database;
		26	use base 'Koha::Util::PureFunctions';
25		27
26	=head1 NAME	28	=head1 NAME
27		29
Lines 75-81 my $object = Koha::Objects->find( { keypart1 => $keypart1, keypart2 => $keypart2 Link Here
75		77
76	=cut	78	=cut
77		79
78	sub find {	80	sub find : PureFunction {
79	my ( $self, $id ) = @_;	81	my ( $self, $id ) = @_;
80		82
81	return unless defined($id);	83	return unless defined($id);

Lines 20-27 package Koha::Template::Plugin::Branches; Link Here

(-)a/Koha/Template/Plugin/Branches.pm (-2 / +3 lines)
20		20
21	use Modern::Perl;	21	use Modern::Perl;
22		22
		23	use Koha::Util::PureFunctions;
23	use Template::Plugin;	24	use Template::Plugin;
24	use base qw( Template::Plugin );	25	use base qw( Koha::Util::PureFunctions Template::Plugin );
25		26
26	use C4::Koha;	27	use C4::Koha;
27	use C4::Context;	28	use C4::Context;
Lines 55-61 sub GetURL { Link Here
55	return $b->{branchurl};	56	return $b->{branchurl};
56	}	57	}
57		58
58	sub all {	59	sub all : PureFunction {
59	my ( $self, $params ) = @_;	60	my ( $self, $params ) = @_;
60	my $selected = $params->{selected};	61	my $selected = $params->{selected};
61	my $unfiltered = $params->{unfiltered} \|\| 0;	62	my $unfiltered = $params->{unfiltered} \|\| 0;

Line 0 Link Here

(-)a/Koha/Util/PureFunctions.pm (+266 lines)
		1
		2	use warnings;
		3
		4	=head1 NAME
		5
		6	Koha::Util::PureFunctions
		7
		8	=head1 SYNOPSIS
		9
		10	package X;
		11	use base 'Koha::Util::PureFunctions';
		12
		13	sub GetFoo : PureFunction {
		14	...
		15	IsValid(...);
		16	}
		17
		18	sub IsValid : PureFunction {
		19	...
		20	}
		21
		22	sub UpdateFoo {
		23	my $foo = GetFoo(); # it's ok, pure functions can be called inside impure functions
		24	}
		25
		26
		27	sub MakeBar : ImpureFunction {
		28	}
		29
		30	sub ListBars : PureFunction {
		31	my @bars = ...;
		32	@bars or push @bars, MakeBar(); # ERROR, you can't call an impure function inside a pure one
		33	}
		34
		35	=head1 DESCRIPTION
		36
		37	Pure functions are functions that returns the same results given the same arguments.
		38
		39	In some cases, and for a strict scope, functions that read data from the database can be seen as pure functions.
		40	E.g. when showing items or members in a long list in a function that DOES NOT change the data on the database.
		41
		42	There are several cases in Koha where there is a loop over objects that need to be decorated, which will end up calling
		43	the same getter for the same entity over and over again. (e.g.: C4::Members::GetMember, C4::Circulation::GetBranchItemRule or Koha::Objects::find)
		44
		45	By marking the function (or method) with the PureFunction attribute, you declare that the result of that function SHOULD be reused, provided the caller
		46	is pure.
		47
		48	=head2 Storage
		49
		50	every time a pure function is called, it checks if it is inside a "pure" environment already.
		51
		52	If not, a new environment is created and used to share a "cache" of all the calls.
		53
		54	If it is, then the "cache" is used to verify if the same requests has been returned in the same "pure" environment.
		55
		56	Note: it is similar to "scope", but it extends to the callees
		57
		58	When the first function exits, the whole "pure" environment is destroyed.
		59
		60	=head2 Pure/Impure
		61
		62	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
		63
		64	=head2 Memoize
65
66	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.
67
68	=head2 How it works
69
70	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.
71
72	there is a lot of magic happening there, which relies on Attribute::Handler, local variables, and function redef.
73
74	=head1 FUNCTIONS
75
76	=head2 pure
77
78	Koha::Util::PureFunctions::pure {
79	...
80	};
81
82	Utility function that create a "pure" environment if not present. Useful when you want only a part of a function/script to be pure.
83
84	=head1 BUGS AND ISSUE
85
86	This module requires to be extended (use base/parent) by subclasses.
87
88	This can be problematic with Exporter, where subroutines MUST be exported AFTER the module wrap them
89
90	=head1 AUTHOR
91
92	Francesco Rivetti E<lt>oha@oha.itE<gt>
93
94	=cut
95
96	package Koha::Util::PureFunctions;
97	our $DBG;
98	our $STORE; # the temporary storage (cache)
99	our @STACK; # the stack of pure only functions
100	our $HOOKS;
101
102	# this will keep this function private, since lots of objects will inherit
103	my $fire_hooks = sub {
104	while (my ($k,$v) = each %$HOOKS) {
105	eval {
106	$v->(@_);
107	1;
108	} or warn "error while executing hook '$k': $@";
109	}
110	};
111
112	use Attribute::Handlers;
113	use JSON; our $JSON = JSON->new()->utf8(1)->canonical(1)->allow_blessed(1);
114	use Data::Dumper;
115	use Time::HiRes qw/time/;
116
117	sub pure(&) {
118	my ($code) = @_;
119	local $STORE = $STORE//{};
120	my @caller = caller(1);
121	local @STACK = (@STACK, "$caller[1]:$caller[2]");
122	$code->();
123	}
124
125
126	sub ImpureFunction :ATTR(BEGIN) {
127	my ($package, $subp, $code, $attr) = @_;
128
129	# get the full name of the function
130	my $subn = $package."::".*{$subp}{NAME};
131
132	# prepare the replacement function
133	my $memo = sub {
134	# are we in a Pure environment?
135	$STORE and die "function '$subn' is marked as Impure, but called inside '".$STACK[-1]."'";
136
137	# call and return the original function
138	$code->();
139	};
140	$DBG and print STDERR "redefining '$subn'...\n";
141
142	# replace the function
143	no warnings 'redefine';
144	*{$subp} = $memo;
145	}
146
147	sub PureFunction :ATTR(BEGIN) {
148	my ($package, $subp, $code, $attr) = @_;
149
150	# get the full name of the function
151	my $name = *{$subp}{NAME};
152	my $subn = $package."::".$name;
153
154	# prepare the replacement
155	my $memo = sub {
156	# push this function in the pure function stack
157	local @STACK = (@STACK, $subn);
158
159	# initiate a pure environment if not present already
160	my $old_store = $STORE;
161	local $STORE = $STORE//{};
162
163	# compute a key with the argument list
164	my $key = $JSON->encode(\@_);
165	$key = "@".$key if wantarray; # different caches based on wantarray
166
167	$DBG and printf STDERR "$subn : PureFunction(%s)... store: $::STORE\n", $key;
168
169	# find or create the cache for this specific function
170	my $cache = $STORE->{$subn}//={};
171
172	my $stats = {
173	package => $package,
174	name => $name,
175	};
176	$stats->{new} = 1 unless $old_store;
177
178	if (exists $cache->{$key}) {
179	# cache HIT
180	$stats->{hit}++;
181	} else {
182	# cache MISS
183	$stats->{miss}++;
184
185	# measure time
186	my $t0 = time();
187
188	if (wantarray) {
189	$cache->{$key} = [$code->(@_)]; # exceptions will fall thru, no caching for them
190	} else {
191	$cache->{$key} = $code->(@_);
192	}
193	my $dt = time() - $t0;
194	$stats->{miss_time} += $dt;
195	if ($dt>3) {
196	warn "$subn() took $dt seconds\nargs: $key..."
197	}
198	}
199	$fire_hooks->(%$stats); # unroll the hash, so it can't be modified
200
201	# return the results
202	if (wantarray) {
203	return @{$cache->{$key}};
204	} else {
205	return $cache->{$key};
206	}
207	};
208
209	# replace the function
210	$DBG and print STDERR "redefining '$subn'...\n";
211	no warnings 'redefine';
212	*{$subp} = $memo;
213	}
214
215	# TEST METHOD, works like PureFunction but don't enable an environment and don't do any caching
216	# usefull to check the effects of a pure function without applying it
217	sub TrackedFunction :ATTR(BEGIN) {
218	my ($package, $subp, $code, $attr) = @_;
219	my $name = *{$subp}{NAME}."?";
220	my $subn = $package."::".*{$subp}{NAME}."?";
221	my $memo = sub {
222	#local @STACK = (@STACK, $subn);
223	my $key = $JSON->encode(\@_);
224	$key = "A$key" if wantarray;
225	$DBG and printf STDERR "$subn : TrackedFunction(%s)... store: $::STORE\n", $key;
226	my $cache = $STORE ? $STORE->{$subn}//{} : {};
227	my $stats = {
228	package => $package,
229	name => $name,
230	};
231	if (exists $cache->{$key}) {
232	$stats && $stats->{hit}++;
233	# fetch anyways
234	my $t0 = time();
235	if (wantarray) {
236	$cache->{$key} = [$code->(@_)]; # exceptions will fall thru, no caching for them
237	} else {
238	$cache->{$key} = $code->(@_);
239	}
240	my $dt = time() - $t0;
241	$stats->{saved_time} += $dt;
242	} else {
243	$stats && $stats->{miss}++;
244	my $t0 = time();
245	if (wantarray) {
246	$cache->{$key} = [$code->(@_)]; # exceptions will fall thru, no caching for them
247	} else {
248	$cache->{$key} = $code->(@_);
249	}
250	my $dt = time() - $t0;
251	$stats->{miss_time} += $dt;
252	}
253	$fire_hooks->(%$stats);
254	if (wantarray) {
255	return @{$cache->{$key}};
256	} else {
257	return $cache->{$key};
258	}
259	};
260	$DBG and print STDERR "redefining '$subn'...\n";
261	no warnings 'redefine';
262	*{$subp} = $memo;
263	}
264
265	1;
266