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

(-)a/C4/Biblio.pm (-4 / +4 lines)
Lines 50-58 use vars qw(@ISA @EXPORT); Link Here
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;
(-)a/C4/Circulation.pm (-3 / +5 lines)
Lines 68-75 use Date::Calc qw( Link Here
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;
(-)a/C4/Items.pm (-5 / +5 lines)
Lines 48-56 use Koha::Libraries; Link Here
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;
(-)a/C4/Members.pm (-3 / +4 lines)
Lines 56-63 if ( ! can_load( modules => { 'Koha::NorwegianPatronDB' => undef } ) ) { Link Here
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;
(-)a/C4/Reserves.pm (-13 / +23 lines)
Lines 36-41 use C4::Members qw(); Link Here
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');
(-)a/Koha/Object.pm (+3 lines)
Lines 22-27 use Modern::Perl; Link Here
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
(-)a/Koha/Objects.pm (-1 / +3 lines)
Lines 21-27 use Modern::Perl; Link Here
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);
(-)a/Koha/Template/Plugin/Branches.pm (-2 / +3 lines)
Lines 20-27 package Koha::Template::Plugin::Branches; Link Here
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;
(-)a/Koha/Util/PureFunctions.pm (+266 lines)
Line 0 Link Here
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
(-)a/catalogue/detail.pl (+3 lines)
Lines 45-50 use Koha::AuthorisedValues; Link Here
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
};
(-)a/debian/templates/plack.psgi (-1 / +39 lines)
Lines 66-71 my $apiv1 = builder { Link Here
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