← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:01:06 2013

Filename/usr/share/perl/5.10/Memoize.pm
StatementsExecuted 129 statements in 2.30ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111191µs336µsMemoize::::memoizeMemoize::memoize
21168µs5.45msMemoize::::_memoizerMemoize::_memoizer
11123µs25µsMemoize::::_make_crefMemoize::_make_cref
11118µs64µsMemoize::::BEGIN@27Memoize::BEGIN@27
11116µs34µsMemoize::::BEGIN@30Memoize::BEGIN@30
11114µs18µsMemoize::::BEGIN@228Memoize::BEGIN@228
11113µs17µsMemoize::::BEGIN@293Memoize::BEGIN@293
11112µs18µsMemoize::::BEGIN@97Memoize::BEGIN@97
21112µs12µsMemoize::::_my_tieMemoize::_my_tie
11112µs15µsMemoize::::BEGIN@330Memoize::BEGIN@330
11111µs29µsMemoize::::BEGIN@28Memoize::BEGIN@28
11110µs43µsMemoize::::BEGIN@29Memoize::BEGIN@29
1119µs12µsMemoize::::BEGIN@34Memoize::BEGIN@34
2214µs4µsMemoize::::CORE:matchMemoize::CORE:match (opcode)
0000s0sMemoize::::_crap_outMemoize::_crap_out
0000s0sMemoize::::flush_cacheMemoize::flush_cache
0000s0sMemoize::::unmemoizeMemoize::unmemoize
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# -*- mode: perl; perl-indent-level: 2; -*-
2# Memoize.pm
3#
4# Transparent memoization of idempotent functions
5#
6# Copyright 1998, 1999, 2000, 2001 M-J. Dominus.
7# You may copy and distribute this program under the
8# same terms as Perl itself. If in doubt,
9# write to mjd-perl-memoize+@plover.com for a license.
10#
11# Version 1.01 $Revision: 1.18 $ $Date: 2001/06/24 17:16:47 $
12
13package Memoize;
141800ns$VERSION = '1.01_03';
15
16# Compile-time constants
17sub SCALAR () { 0 }
18sub LIST () { 1 }
19
20
21#
22# Usage memoize(functionname/ref,
23# { NORMALIZER => coderef, INSTALL => name,
24# LIST_CACHE => descriptor, SCALAR_CACHE => descriptor }
25#
26
27330µs2109µs
# spent 64µs (18+45) within Memoize::BEGIN@27 which was called: # once (18µs+45µs) by C4::Koha::BEGIN@28 at line 27
use Carp;
# spent 64µs making 1 call to Memoize::BEGIN@27 # spent 45µs making 1 call to Exporter::import
28328µs247µs
# spent 29µs (11+18) within Memoize::BEGIN@28 which was called: # once (11µs+18µs) by C4::Koha::BEGIN@28 at line 28
use Exporter;
# spent 29µs making 1 call to Memoize::BEGIN@28 # spent 18µs making 1 call to Exporter::import
29335µs275µs
# spent 43µs (10+33) within Memoize::BEGIN@29 which was called: # once (10µs+33µs) by C4::Koha::BEGIN@28 at line 29
use vars qw($DEBUG);
# spent 43µs making 1 call to Memoize::BEGIN@29 # spent 33µs making 1 call to vars::import
30358µs252µs
# spent 34µs (16+18) within Memoize::BEGIN@30 which was called: # once (16µs+18µs) by C4::Koha::BEGIN@28 at line 30
use Config; # Dammit.
# spent 34µs making 1 call to Memoize::BEGIN@30 # spent 18µs making 1 call to Config::import
31130µs@ISA = qw(Exporter);
3211µs@EXPORT = qw(memoize);
331600ns@EXPORT_OK = qw(unmemoize flush_cache);
343320µs216µs
# spent 12µs (9+3) within Memoize::BEGIN@34 which was called: # once (9µs+3µs) by C4::Koha::BEGIN@28 at line 34
use strict;
# spent 12µs making 1 call to Memoize::BEGIN@34 # spent 3µs making 1 call to strict::import
35
361400nsmy %memotable;
371100nsmy %revmemotable;
3811µsmy @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT HASH);
3915µsmy %IS_CACHE_TAG = map {($_ => 1)} @CONTEXT_TAGS;
40
41# Raise an error if the user tries to specify one of thesepackage as a
42# tie for LIST_CACHE
43
4415µsmy %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File);
45
46
# spent 336µs (191+145) within Memoize::memoize which was called: # once (191µs+145µs) by C4::Biblio::BEGIN@33 at line 81 of /usr/share/koha/lib/C4/Koha.pm
sub memoize {
474193µs my $fn = shift;
48 my %options = @_;
49 my $options = \%options;
50
51 unless (defined($fn) &&
52 (ref $fn eq 'CODE' || ref $fn eq '')) {
53 croak "Usage: memoize 'functionname'|coderef {OPTIONS}";
54 }
55
56 my $uppack = caller; # TCL me Elmo!
57 my $cref; # Code reference to original function
58 my $name = (ref $fn ? undef : $fn);
59
60 # Convert function names to code references
61125µs $cref = &_make_cref($fn, $uppack);
# spent 25µs making 1 call to Memoize::_make_cref
62
63 # Locate function prototype, if any
64 my $proto = prototype $cref;
65 if (defined $proto) { $proto = "($proto)" }
66 else { $proto = "" }
67
68 # I would like to get rid of the eval, but there seems not to be any
69 # other way to set the prototype properly. The switch here for
70 # 'usethreads' works around a bug in threadperl having to do with
71 # magic goto. It would be better to fix the bug and use the magic
72 # goto version everywhere.
73178µs1106µs my $wrapper =
# spent 106µs making 1 call to Config::FETCH
# spent 25µs executing statements in string eval
# includes 19µs spent executing 2 calls to 1 sub defined therein.
74 $Config{usethreads}
75 ? eval "sub $proto { &_memoizer(\$cref, \@_); }"
76 : eval "sub $proto { unshift \@_, \$cref; goto &_memoizer; }";
77
78 my $normalizer = $options{NORMALIZER};
79 if (defined $normalizer && ! ref $normalizer) {
80 $normalizer = _make_cref($normalizer, $uppack);
81 }
82
83 my $install_name;
84 if (defined $options->{INSTALL}) {
85 # INSTALL => name
86 $install_name = $options->{INSTALL};
87 } elsif (! exists $options->{INSTALL}) {
88 # No INSTALL option provided; use original name if possible
89 $install_name = $name;
90 } else {
91 # INSTALL => undef means don't install
92 }
93
94 if (defined $install_name) {
9512µs $install_name = $uppack . '::' . $install_name
# spent 2µs making 1 call to Memoize::CORE:match
96 unless $install_name =~ /::/;
973714µs224µs
# spent 18µs (12+6) within Memoize::BEGIN@97 which was called: # once (12µs+6µs) by C4::Koha::BEGIN@28 at line 97
no strict;
# spent 18µs making 1 call to Memoize::BEGIN@97 # spent 6µs making 1 call to strict::unimport
98 local($^W) = 0; # ``Subroutine $install_name redefined at ...''
99 *{$install_name} = $wrapper; # Install memoized version
100 }
101
102 $revmemotable{$wrapper} = "" . $cref; # Turn code ref into hash key
103
104 # These will be the caches
105 my %caches;
106 for my $context (qw(SCALAR LIST)) {
107 # suppress subsequent 'uninitialized value' warnings
108 $options{"${context}_CACHE"} ||= '';
109
110 my $cache_opt = $options{"${context}_CACHE"};
111 my @cache_opt_args;
112 if (ref $cache_opt) {
113 @cache_opt_args = @$cache_opt;
114 $cache_opt = shift @cache_opt_args;
115 }
116 if ($cache_opt eq 'FAULT') { # no cache
117 $caches{$context} = undef;
118 } elsif ($cache_opt eq 'HASH') { # user-supplied hash
119 my $cache = $cache_opt_args[0];
120 my $package = ref(tied %$cache);
121 if ($context eq 'LIST' && $scalar_only{$package}) {
122 croak("You can't use $package for LIST_CACHE because it can only store scalars");
123 }
124 $caches{$context} = $cache;
125 } elsif ($cache_opt eq '' || $IS_CACHE_TAG{$cache_opt}) {
126 # default is that we make up an in-memory hash
127 $caches{$context} = {};
128 # (this might get tied later, or MERGEd away)
129 } else {
130 croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (@CONTEXT_TAGS); aborting";
131 }
132 }
133
134 # Perhaps I should check here that you didn't supply *both* merge
135 # options. But if you did, it does do something reasonable: They
136 # both get merged to the same in-memory hash.
137 if ($options{SCALAR_CACHE} eq 'MERGE') {
138 $caches{SCALAR} = $caches{LIST};
139 } elsif ($options{LIST_CACHE} eq 'MERGE') {
140 $caches{LIST} = $caches{SCALAR};
141 }
142
143 # Now deal with the TIE options
144 {
145 my $context;
146 foreach $context (qw(SCALAR LIST)) {
147 # If the relevant option wasn't `TIE', this call does nothing.
148212µs _my_tie($context, $caches{$context}, $options); # Croaks on failure
# spent 12µs making 2 calls to Memoize::_my_tie, avg 6µs/call
149 }
150 }
151
152 # We should put some more stuff in here eventually.
153 # We've been saying that for serveral versions now.
154 # And you know what? More stuff keeps going in!
155 $memotable{$cref} =
156 {
157 O => $options, # Short keys here for things we need to access frequently
158 N => $normalizer,
159 U => $cref,
160 MEMOIZED => $wrapper,
161 PACKAGE => $uppack,
162 NAME => $install_name,
163 S => $caches{SCALAR},
164 L => $caches{LIST},
165 };
166
167 $wrapper # Return just memoized version
168}
169
170# This function tries to load a tied hash class and tie the hash to it.
171
# spent 12µs within Memoize::_my_tie which was called 2 times, avg 6µs/call: # 2 times (12µs+0s) by Memoize::memoize at line 148, avg 6µs/call
sub _my_tie {
172815µs my ($context, $hash, $options) = @_;
173 my $fullopt = $options->{"${context}_CACHE"};
174
175 # We already checked to make sure that this works.
176 my $shortopt = (ref $fullopt) ? $fullopt->[0] : $fullopt;
177
178 return unless defined $shortopt && $shortopt eq 'TIE';
179 carp("TIE option to memoize() is deprecated; use HASH instead")
180 if $^W;
181
182 my @args = ref $fullopt ? @$fullopt : ();
183 shift @args;
184 my $module = shift @args;
185 if ($context eq 'LIST' && $scalar_only{$module}) {
186 croak("You can't use $module for LIST_CACHE because it can only store scalars");
187 }
188 my $modulefile = $module . '.pm';
189 $modulefile =~ s{::}{/}g;
190 eval { require $modulefile };
191 if ($@) {
192 croak "Memoize: Couldn't load hash tie module `$module': $@; aborting";
193 }
194 my $rc = (tie %$hash => $module, @args);
195 unless ($rc) {
196 croak "Memoize: Couldn't tie hash to `$module': $!; aborting";
197 }
198 1;
199}
200
201sub flush_cache {
202 my $func = _make_cref($_[0], scalar caller);
203 my $info = $memotable{$revmemotable{$func}};
204 die "$func not memoized" unless defined $info;
205 for my $context (qw(S L)) {
206 my $cache = $info->{$context};
207 if (tied %$cache && ! (tied %$cache)->can('CLEAR')) {
208 my $funcname = defined($info->{NAME}) ?
209 "function $info->{NAME}" : "anonymous function $func";
210 my $context = {S => 'scalar', L => 'list'}->{$context};
211 croak "Tied cache hash for $context-context $funcname does not support flushing";
212 } else {
213 %$cache = ();
214 }
215 }
216}
217
218# This is the function that manages the memo tables.
219
# spent 5.45ms (68µs+5.39) within Memoize::_memoizer which was called 2 times, avg 2.73ms/call: # 2 times (68µs+5.39ms) by Memoize::__ANON__[(eval 998)[/usr/share/perl/5.10/Memoize.pm:73]:1] at line 1 of (eval 998)[Memoize.pm:73], avg 2.73ms/call
sub _memoizer {
2203268µs my $orig = shift; # stringized version of ref to original func.
221 my $info = $memotable{$orig};
222 my $normalizer = $info->{N};
223
224 my $argstr;
225 my $context = (wantarray() ? LIST : SCALAR);
226
227 if (defined $normalizer) {
2283358µs222µs
# spent 18µs (14+4) within Memoize::BEGIN@228 which was called: # once (14µs+4µs) by C4::Koha::BEGIN@28 at line 228
no strict;
# spent 18µs making 1 call to Memoize::BEGIN@228 # spent 4µs making 1 call to strict::unimport
229 if ($context == SCALAR) {
230 $argstr = &{$normalizer}(@_);
231 } elsif ($context == LIST) {
232 ($argstr) = &{$normalizer}(@_);
233 } else {
234 croak "Internal error \#41; context was neither LIST nor SCALAR\n";
235 }
236 } else { # Default normalizer
237 local $^W = 0;
238 $argstr = join chr(28),@_;
239 }
240
241 if ($context == SCALAR) {
242 my $cache = $info->{S};
243 _crap_out($info->{NAME}, 'scalar') unless $cache;
244 if (exists $cache->{$argstr}) {
245 return $cache->{$argstr};
246 } else {
24785.41ms my $val = &{$info->{U}}(@_);
# spent 5.39ms making 2 calls to C4::Koha::GetAuthorisedValues, avg 2.69ms/call # spent 14µs making 4 calls to DBI::common::DESTROY, avg 4µs/call # spent 5µs making 2 calls to DBD::_mem::common::DESTROY, avg 3µs/call
248 # Scalars are considered to be lists; store appropriately
249 if ($info->{O}{SCALAR_CACHE} eq 'MERGE') {
250 $cache->{$argstr} = [$val];
251 } else {
252 $cache->{$argstr} = $val;
253 }
254 $val;
255 }
256 } elsif ($context == LIST) {
257 my $cache = $info->{L};
258 _crap_out($info->{NAME}, 'list') unless $cache;
259 if (exists $cache->{$argstr}) {
260 my $val = $cache->{$argstr};
261 # If LISTCONTEXT=>MERGE, then the function never returns lists,
262 # so we have a scalar value cached, so just return it straightaway:
263 return ($val) if $info->{O}{LIST_CACHE} eq 'MERGE';
264 # Maybe in a later version we can use a faster test.
265
266 # Otherwise, we cached an array containing the returned list:
267 return @$val;
268 } else {
269 my @q = &{$info->{U}}(@_);
270 $cache->{$argstr} = $info->{O}{LIST_CACHE} eq 'MERGE' ? $q [0] : \@q;
271 @q;
272 }
273 } else {
274 croak "Internal error \#42; context was neither LIST nor SCALAR\n";
275 }
276}
277
278sub unmemoize {
279 my $f = shift;
280 my $uppack = caller;
281 my $cref = _make_cref($f, $uppack);
282
283 unless (exists $revmemotable{$cref}) {
284 croak "Could not unmemoize function `$f', because it was not memoized to begin with";
285 }
286
287 my $tabent = $memotable{$revmemotable{$cref}};
288 unless (defined $tabent) {
289 croak "Could not figure out how to unmemoize function `$f'";
290 }
291 my $name = $tabent->{NAME};
292 if (defined $name) {
2933152µs221µs
# spent 17µs (13+4) within Memoize::BEGIN@293 which was called: # once (13µs+4µs) by C4::Koha::BEGIN@28 at line 293
no strict;
# spent 17µs making 1 call to Memoize::BEGIN@293 # spent 4µs making 1 call to strict::unimport
294 local($^W) = 0; # ``Subroutine $install_name redefined at ...''
295 *{$name} = $tabent->{U}; # Replace with original function
296 }
297 undef $memotable{$revmemotable{$cref}};
298 undef $revmemotable{$cref};
299
300 # This removes the last reference to the (possibly tied) memo tables
301 # my ($old_function, $memotabs) = @{$tabent}{'U','S','L'};
302 # undef $tabent;
303
304# # Untie the memo tables if they were tied.
305# my $i;
306# for $i (0,1) {
307# if (tied %{$memotabs->[$i]}) {
308# warn "Untying hash #$i\n";
309# untie %{$memotabs->[$i]};
310# }
311# }
312
313 $tabent->{U};
314}
315
316
# spent 25µs (23+2) within Memoize::_make_cref which was called: # once (23µs+2µs) by Memoize::memoize at line 61
sub _make_cref {
3171126µs my $fn = shift;
318 my $uppack = shift;
319 my $cref;
320 my $name;
321
322 if (ref $fn eq 'CODE') {
323 $cref = $fn;
324 } elsif (! ref $fn) {
32512µs if ($fn =~ /::/) {
# spent 2µs making 1 call to Memoize::CORE:match
326 $name = $fn;
327 } else {
328 $name = $uppack . '::' . $fn;
329 }
3303268µs219µs
# spent 15µs (12+4) within Memoize::BEGIN@330 which was called: # once (12µs+4µs) by C4::Koha::BEGIN@28 at line 330
no strict;
# spent 15µs making 1 call to Memoize::BEGIN@330 # spent 4µs making 1 call to strict::unimport
331 if (defined $name and !defined(&$name)) {
332 croak "Cannot operate on nonexistent function `$fn'";
333 }
334# $cref = \&$name;
335 $cref = *{$name}{CODE};
336 } else {
337 my $parent = (caller(1))[3]; # Function that called _make_cref
338 croak "Usage: argument 1 to `$parent' must be a function name or reference.\n";
339 }
340 $DEBUG and warn "${name}($fn) => $cref in _make_cref\n";
341 $cref;
342}
343
344sub _crap_out {
345 my ($funcname, $context) = @_;
346 if (defined $funcname) {
347 croak "Function `$funcname' called in forbidden $context context; faulting";
348 } else {
349 croak "Anonymous function called in forbidden $context context; faulting";
350 }
351}
352
35319µs1;
354
- -
359=head1 NAME
360
- -
 
# spent 4µs within Memoize::CORE:match which was called 2 times, avg 2µs/call: # once (2µs+0s) by Memoize::memoize at line 95 # once (2µs+0s) by Memoize::_make_cref at line 325
sub Memoize::CORE:match; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.