← 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 17:10:45 2013
Reported on Tue Oct 15 17:12:27 2013

Filename/usr/share/perl/5.10/Memoize.pm
StatementsExecuted 741 statements in 5.02ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
29111.99ms1.61sMemoize::::_memoizerMemoize::_memoizer
522907µs1.20msMemoize::::memoizeMemoize::memoize
511123µs135µsMemoize::::_make_crefMemoize::_make_cref
101152µs52µsMemoize::::_my_tieMemoize::_my_tie
102122µs22µsMemoize::::CORE:matchMemoize::CORE:match (opcode)
11116µs62µsMemoize::::BEGIN@27Memoize::BEGIN@27
11113µs18µsMemoize::::BEGIN@293Memoize::BEGIN@293
11112µs17µsMemoize::::BEGIN@228Memoize::BEGIN@228
11112µs28µsMemoize::::BEGIN@30Memoize::BEGIN@30
11112µs16µsMemoize::::BEGIN@330Memoize::BEGIN@330
11111µs29µsMemoize::::BEGIN@28Memoize::BEGIN@28
11110µs14µsMemoize::::BEGIN@97Memoize::BEGIN@97
11110µs13µsMemoize::::BEGIN@34Memoize::BEGIN@34
1119µs31µsMemoize::::BEGIN@29Memoize::BEGIN@29
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;
1411µs$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
27333µs2109µs
# spent 62µs (16+47) within Memoize::BEGIN@27 which was called: # once (16µs+47µs) by Memoize::Memcached::BEGIN@8 at line 27
use Carp;
# spent 62µs making 1 call to Memoize::BEGIN@27 # spent 47µs making 1 call to Exporter::import
28329µs247µs
# spent 29µs (11+18) within Memoize::BEGIN@28 which was called: # once (11µs+18µs) by Memoize::Memcached::BEGIN@8 at line 28
use Exporter;
# spent 29µs making 1 call to Memoize::BEGIN@28 # spent 18µs making 1 call to Exporter::import
29327µs254µs
# spent 31µs (9+22) within Memoize::BEGIN@29 which was called: # once (9µs+22µs) by Memoize::Memcached::BEGIN@8 at line 29
use vars qw($DEBUG);
# spent 31µs making 1 call to Memoize::BEGIN@29 # spent 22µs making 1 call to vars::import
30360µs245µs
# spent 28µs (12+17) within Memoize::BEGIN@30 which was called: # once (12µs+17µs) by Memoize::Memcached::BEGIN@8 at line 30
use Config; # Dammit.
# spent 28µs making 1 call to Memoize::BEGIN@30 # spent 17µs making 1 call to Config::import
31110µs@ISA = qw(Exporter);
321700ns@EXPORT = qw(memoize);
331700ns@EXPORT_OK = qw(unmemoize flush_cache);
343248µs217µs
# spent 13µs (10+3) within Memoize::BEGIN@34 which was called: # once (10µs+3µs) by Memoize::Memcached::BEGIN@8 at line 34
use strict;
# spent 13µs making 1 call to Memoize::BEGIN@34 # spent 4µs making 1 call to strict::import
35
361200nsmy %memotable;
371200nsmy %revmemotable;
3811µsmy @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT HASH);
3916µ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
4414µsmy %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File);
45
46
# spent 1.20ms (907µs+292µs) within Memoize::memoize which was called 5 times, avg 240µs/call: # 4 times (696µs+228µs) by C4::Reserves::BEGIN@27 or C4::Templates::BEGIN@35 at line 70 of Memoize/Memcached.pm, avg 231µs/call # once (211µs+64µs) by C4::Biblio::BEGIN@33 at line 81 of /usr/share/koha/lib/C4/Koha.pm
sub memoize {
4759µs my $fn = shift;
48512µs my %options = @_;
4954µs my $options = \%options;
50
5159µs unless (defined($fn) &&
52 (ref $fn eq 'CODE' || ref $fn eq '')) {
53 croak "Usage: memoize 'functionname'|coderef {OPTIONS}";
54 }
55
5656µs my $uppack = caller; # TCL me Elmo!
5752µs my $cref; # Code reference to original function
5854µs my $name = (ref $fn ? undef : $fn);
59
60 # Convert function names to code references
61519µs5135µs $cref = &_make_cref($fn, $uppack);
# spent 135µs making 5 calls to Memoize::_make_cref, avg 27µs/call
62
63 # Locate function prototype, if any
6454µs my $proto = prototype $cref;
6554µs if (defined $proto) { $proto = "($proto)" }
6653µs 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.
735389µs595µs my $wrapper =
# spent 95µs making 5 calls to Config::FETCH, avg 19µs/call
# spent 367µs executing statements in 5 string evals (merged)
# includes 405µs spent executing 29 calls to 1 sub defined therein.
74 $Config{usethreads}
75 ? eval "sub $proto { &_memoizer(\$cref, \@_); }"
76 : eval "sub $proto { unshift \@_, \$cref; goto &_memoizer; }";
77
7855µs my $normalizer = $options{NORMALIZER};
7954µs if (defined $normalizer && ! ref $normalizer) {
80 $normalizer = _make_cref($normalizer, $uppack);
81 }
82
8352µs my $install_name;
84512µs 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
9455µs if (defined $install_name) {
95545µs510µs $install_name = $uppack . '::' . $install_name
# spent 10µs making 5 calls to Memoize::CORE:match, avg 2µs/call
96 unless $install_name =~ /::/;
973769µs218µs
# spent 14µs (10+4) within Memoize::BEGIN@97 which was called: # once (10µs+4µs) by Memoize::Memcached::BEGIN@8 at line 97
no strict;
# spent 14µs making 1 call to Memoize::BEGIN@97 # spent 4µs making 1 call to strict::unimport
98523µs local($^W) = 0; # ``Subroutine $install_name redefined at ...''
99525µs *{$install_name} = $wrapper; # Install memoized version
100 }
101
102522µs $revmemotable{$wrapper} = "" . $cref; # Turn code ref into hash key
103
104 # These will be the caches
10552µs my %caches;
10659µs for my $context (qw(SCALAR LIST)) {
107 # suppress subsequent 'uninitialized value' warnings
1081011µs $options{"${context}_CACHE"} ||= '';
109
110109µs my $cache_opt = $options{"${context}_CACHE"};
111103µs my @cache_opt_args;
112108µs if (ref $cache_opt) {
113814µs @cache_opt_args = @$cache_opt;
114810µs $cache_opt = shift @cache_opt_args;
115 }
1161023µs if ($cache_opt eq 'FAULT') { # no cache
117 $caches{$context} = undef;
118 } elsif ($cache_opt eq 'HASH') { # user-supplied hash
11984µs my $cache = $cache_opt_args[0];
120810µs my $package = ref(tied %$cache);
12186µs if ($context eq 'LIST' && $scalar_only{$package}) {
122 croak("You can't use $package for LIST_CACHE because it can only store scalars");
123 }
12489µs $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.
13758µs 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 {
145106µs my $context;
14655µs foreach $context (qw(SCALAR LIST)) {
147 # If the relevant option wasn't `TIE', this call does nothing.
1481033µs1052µs _my_tie($context, $caches{$context}, $options); # Croaks on failure
# spent 52µs making 10 calls to Memoize::_my_tie, avg 5µ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!
155538µs $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
167534µs $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 52µs within Memoize::_my_tie which was called 10 times, avg 5µs/call: # 10 times (52µs+0s) by Memoize::memoize at line 148, avg 5µs/call
sub _my_tie {
172109µs my ($context, $hash, $options) = @_;
1731010µs my $fullopt = $options->{"${context}_CACHE"};
174
175 # We already checked to make sure that this works.
176107µs my $shortopt = (ref $fullopt) ? $fullopt->[0] : $fullopt;
177
1781038µs 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 1.61s (1.99ms+1.61) within Memoize::_memoizer which was called 29 times, avg 55.6ms/call: # 29 times (1.99ms+1.61s) by Memoize::__ANON__[(eval 1015)[/usr/share/perl/5.10/Memoize.pm:73]:1] or Memoize::__ANON__[(eval 1026)[/usr/share/perl/5.10/Memoize.pm:73]:1] or Memoize::__ANON__[(eval 28)[/usr/share/perl/5.10/Memoize.pm:73]:1] or Memoize::__ANON__[(eval 30)[/usr/share/perl/5.10/Memoize.pm:73]:1] at line 1 of (eval 28)[Memoize.pm:73], avg 55.6ms/call
sub _memoizer {
2202938µs my $orig = shift; # stringized version of ref to original func.
22129113µs my $info = $memotable{$orig};
2222970µs my $normalizer = $info->{N};
223
2242914µs my $argstr;
2252934µs my $context = (wantarray() ? LIST : SCALAR);
226
2272938µs if (defined $normalizer) {
2283400µs221µs
# spent 17µs (12+4) within Memoize::BEGIN@228 which was called: # once (12µs+4µs) by Memoize::Memcached::BEGIN@8 at line 228
no strict;
# spent 17µ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
23729166µs local $^W = 0;
23829115µs $argstr = join chr(28),@_;
239 }
240
2412945µs if ($context == SCALAR) {
2422948µs my $cache = $info->{S};
2432921µs _crap_out($info->{NAME}, 'scalar') unless $cache;
244291.17ms541.61s if (exists $cache->{$argstr}) {
# spent 815ms making 27 calls to Memoize::Memcached::EXISTS, avg 30.2ms/call # spent 790ms making 27 calls to Memoize::Memcached::FETCH, avg 29.3ms/call
245 return $cache->{$argstr};
246 } else {
247217µs85.64ms my $val = &{$info->{U}}(@_);
# spent 5.58ms making 2 calls to C4::Koha::GetAuthorisedValues, avg 2.79ms/call # spent 52µs making 4 calls to DBI::common::DESTROY, avg 13µs/call # spent 6µs making 2 calls to DBD::_mem::common::DESTROY, avg 3µs/call
248 # Scalars are considered to be lists; store appropriately
24929µs if ($info->{O}{SCALAR_CACHE} eq 'MERGE') {
250 $cache->{$argstr} = [$val];
251 } else {
25224µs $cache->{$argstr} = $val;
253 }
25421µs $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) {
2933159µs223µs
# spent 18µs (13+5) within Memoize::BEGIN@293 which was called: # once (13µs+5µs) by Memoize::Memcached::BEGIN@8 at line 293
no strict;
# spent 18µs making 1 call to Memoize::BEGIN@293 # spent 5µ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 135µs (123+12) within Memoize::_make_cref which was called 5 times, avg 27µs/call: # 5 times (123µs+12µs) by Memoize::memoize at line 61, avg 27µs/call
sub _make_cref {
31754µs my $fn = shift;
31853µs my $uppack = shift;
31951µs my $cref;
32051µs my $name;
321
32259µs if (ref $fn eq 'CODE') {
323 $cref = $fn;
324 } elsif (! ref $fn) {
325551µs512µs if ($fn =~ /::/) {
# spent 12µs making 5 calls to Memoize::CORE:match, avg 2µs/call
326 $name = $fn;
327 } else {
328512µs $name = $uppack . '::' . $fn;
329 }
3303308µs220µs
# spent 16µs (12+4) within Memoize::BEGIN@330 which was called: # once (12µs+4µs) by Memoize::Memcached::BEGIN@8 at line 330
no strict;
# spent 16µs making 1 call to Memoize::BEGIN@330 # spent 4µs making 1 call to strict::unimport
331519µs if (defined $name and !defined(&$name)) {
332 croak "Cannot operate on nonexistent function `$fn'";
333 }
334# $cref = \&$name;
335513µs $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 }
34053µs $DEBUG and warn "${name}($fn) => $cref in _make_cref\n";
341522µs $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
35318µs1;
354
- -
359=head1 NAME
360
- -
 
# spent 22µs within Memoize::CORE:match which was called 10 times, avg 2µs/call: # 5 times (12µs+0s) by Memoize::_make_cref at line 325, avg 2µs/call # 5 times (10µs+0s) by Memoize::memoize at line 95, avg 2µs/call
sub Memoize::CORE:match; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.