← 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:11:25 2013

Filename/usr/share/perl/5.10/Carp/Heavy.pm
StatementsExecuted 77 statements in 1.99ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
22130µs71µsCarp::::trustsCarp::trusts
11127µs98µsCarp::::short_error_locCarp::short_error_loc
32121µs41µsCarp::::get_statusCarp::get_status
31120µs20µsCarp::::trusts_directlyCarp::trusts_directly
11120µs72µsCarp::::BEGIN@5Carp::BEGIN@5
11114µs40µsCarp::::BEGIN@289Carp::BEGIN@289
11111µs26µsCarp::::BEGIN@290Carp::BEGIN@290
0000s0sCarp::::caller_infoCarp::caller_info
0000s0sCarp::::format_argCarp::format_arg
0000s0sCarp::::get_subnameCarp::get_subname
0000s0sCarp::::long_error_locCarp::long_error_loc
0000s0sCarp::::longmess_heavyCarp::longmess_heavy
0000s0sCarp::::longmess_realCarp::longmess_real
0000s0sCarp::::ret_backtraceCarp::ret_backtrace
0000s0sCarp::::ret_summaryCarp::ret_summary
0000s0sCarp::::shortmess_heavyCarp::shortmess_heavy
0000s0sCarp::::shortmess_realCarp::shortmess_real
0000s0sCarp::::str_len_trimCarp::str_len_trim
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# Carp::Heavy uses some variables in common with Carp.
2package Carp;
3
4# On one line so MakeMaker will see it.
541.74ms2124µs
# spent 72µs (20+52) within Carp::BEGIN@5 which was called: # once (20µs+52µs) by warnings::_error_loc at line 5
use Carp; our $VERSION = $Carp::VERSION;
# spent 72µs making 1 call to Carp::BEGIN@5 # spent 52µs making 1 call to Exporter::import
6# use strict; # not yet
7
8# 'use Carp' just installs some very lightweight stubs; the first time
9# these are called, they require Carp::Heavy which installs the real
10# routines.
11
12# The members of %Internal are packages that are internal to perl.
13# Carp will not report errors from within these packages if it
14# can. The members of %CarpInternal are internal to Perl's warning
15# system. Carp will not report errors from within these packages
16# either, and will not report calls *to* these packages for carp and
17# croak. They replace $CarpLevel, which is deprecated. The
18# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
19# text and function arguments should be formatted when printed.
20
21# disable these by default, so they can live w/o require Carp
2212µs$CarpInternal{Carp}++;
231700ns$CarpInternal{warnings}++;
2411µs$Internal{Exporter}++;
251700ns$Internal{'Exporter::Heavy'}++;
26
2711µsour ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
28
29# XXX longmess_real and shortmess_real should really be merged into
30# XXX {long|sort}mess_heavy at some point
31
32sub longmess_real {
33 # Icky backwards compatibility wrapper. :-(
34 #
35 # The story is that the original implementation hard-coded the
36 # number of call levels to go back, so calls to longmess were off
37 # by one. Other code began calling longmess and expecting this
38 # behaviour, so the replacement has to emulate that behaviour.
39 my $call_pack = caller();
40 if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
41 return longmess_heavy(@_);
42 }
43 else {
44 local $CarpLevel = $CarpLevel + 1;
45 return longmess_heavy(@_);
46 }
47};
48
49sub shortmess_real {
50 # Icky backwards compatibility wrapper. :-(
51 local @CARP_NOT = caller();
52 shortmess_heavy(@_);
53};
54
55# replace the two hooks added by Carp
56
57# aliasing the whole glob rather than just the CV slot avoids 'redefined'
58# warnings, even in the presence of perl -W (as used by lib/warnings.t !)
59# However it has the potential to create infinite loops, if somehow Carp
60# is forcibly reloaded, but $INC{"Carp/Heavy.pm"} remains true.
61# Hence the extra hack of deleting the previous typeglob first.
62
6311µsdelete $Carp::{shortmess_jmp};
641400nsdelete $Carp::{longmess_jmp};
6517µs*longmess_jmp = *longmess_real;
6614µs*shortmess_jmp = *shortmess_real;
67
68sub caller_info {
69 my $i = shift(@_) + 1;
70 package DB;
71
- -
94# Transform an argument to a function into a string.
95sub format_arg {
96 my $arg = shift;
97 if (ref($arg)) {
98 $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
99 }
100 if (defined($arg)) {
101 $arg =~ s/'/\\'/g;
102 $arg = str_len_trim($arg, $MaxArgLen);
103
104 # Quote it?
105 $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
106 } else {
107 $arg = 'undef';
108 }
109
110 # The following handling of "control chars" is direct from
111 # the original code - it is broken on Unicode though.
112 # Suggestions?
113 utf8::is_utf8($arg)
114 or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
115 return $arg;
116}
117
118# Takes an inheritance cache and a package and returns
119# an anon hash of known inheritances and anon array of
120# inheritances which consequences have not been figured
121# for.
122
# spent 41µs (21+20) within Carp::get_status which was called 3 times, avg 14µs/call: # 2 times (15µs+15µs) by Carp::trusts at line 272, avg 15µs/call # once (6µs+5µs) by Carp::trusts at line 278
sub get_status {
1231221µs my $cache = shift;
124 my $pkg = shift;
125320µs $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
# spent 20µs making 3 calls to Carp::trusts_directly, avg 7µs/call
126 return @{$cache->{$pkg}};
127}
128
129# Takes the info from caller() and figures out the name of
130# the sub/require/eval
131sub get_subname {
132 my $info = shift;
133 if (defined($info->{evaltext})) {
134 my $eval = $info->{evaltext};
135 if ($info->{is_require}) {
136 return "require $eval";
137 }
138 else {
139 $eval =~ s/([\\\'])/\\$1/g;
140 return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
141 }
142 }
143
144 return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
145}
146
147# Figures out what call (from the point of view of the caller)
148# the long error backtrace should start at.
149sub long_error_loc {
150 my $i;
151 my $lvl = $CarpLevel;
152 {
153 my $pkg = caller(++$i);
154 unless(defined($pkg)) {
155 # This *shouldn't* happen.
156 if (%Internal) {
157 local %Internal;
158 $i = long_error_loc();
159 last;
160 }
161 else {
162 # OK, now I am irritated.
163 return 2;
164 }
165 }
166 redo if $CarpInternal{$pkg};
167 redo unless 0 > --$lvl;
168 redo if $Internal{$pkg};
169 }
170 return $i - 1;
171}
172
173sub longmess_heavy {
174 return @_ if ref($_[0]); # don't break references as exceptions
175 my $i = long_error_loc();
176 return ret_backtrace($i, @_);
177}
178
179# Returns a full stack backtrace starting from where it is
180# told.
181sub ret_backtrace {
182 my ($i, @error) = @_;
183 my $mess;
184 my $err = join '', @error;
185 $i++;
186
187 my $tid_msg = '';
188 if (defined &threads::tid) {
189 my $tid = threads->tid;
190 $tid_msg = " thread $tid" if $tid;
191 }
192
193 my %i = caller_info($i);
194 $mess = "$err at $i{file} line $i{line}$tid_msg\n";
195
196 while (my %i = caller_info(++$i)) {
197 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
198 }
199
200 return $mess;
201}
202
203sub ret_summary {
204 my ($i, @error) = @_;
205 my $err = join '', @error;
206 $i++;
207
208 my $tid_msg = '';
209 if (defined &threads::tid) {
210 my $tid = threads->tid;
211 $tid_msg = " thread $tid" if $tid;
212 }
213
214 my %i = caller_info($i);
215 return "$err at $i{file} line $i{line}$tid_msg\n";
216}
217
218
# spent 98µs (27+71) within Carp::short_error_loc which was called: # once (27µs+71µs) by warnings::__chk at line 328 of warnings.pm
sub short_error_loc {
219 # You have to create your (hash)ref out here, rather than defaulting it
220 # inside trusts *on a lexical*, as you want it to persist across calls.
221 # (You can default it on $_[2], but that gets messy)
2222024µs my $cache = {};
223 my $i = 1;
224 my $lvl = $CarpLevel;
225 {
226 my $called = caller($i++);
227 my $caller = caller($i);
228
229 return 0 unless defined($caller); # What happened?
230 redo if $Internal{$caller};
231 redo if $CarpInternal{$caller};
232 redo if $CarpInternal{$called};
233124µs redo if trusts($called, $caller, $cache);
# spent 24µs making 1 call to Carp::trusts
234147µs redo if trusts($caller, $called, $cache);
# spent 47µs making 1 call to Carp::trusts
235 redo unless 0 > --$lvl;
236 }
237 return $i - 1;
238}
239
240sub shortmess_heavy {
241 return longmess_heavy(@_) if $Verbose;
242 return @_ if ref($_[0]); # don't break references as exceptions
243 my $i = short_error_loc();
244 if ($i) {
245 ret_summary($i, @_);
246 }
247 else {
248 longmess_heavy(@_);
249 }
250}
251
252# If a string is too long, trims it with ...
253sub str_len_trim {
254 my $str = shift;
255 my $max = shift || 0;
256 if (2 < $max and $max < length($str)) {
257 substr($str, $max - 3) = '...';
258 }
259 return $str;
260}
261
262# Takes two packages and an optional cache. Says whether the
263# first inherits from the second.
264#
265# Recursive versions of this have to work to avoid certain
266# possible endless loops, and when following long chains of
267# inheritance are less efficient.
268
# spent 71µs (30+41) within Carp::trusts which was called 2 times, avg 36µs/call: # once (22µs+24µs) by Carp::short_error_loc at line 234 # once (8µs+16µs) by Carp::short_error_loc at line 233
sub trusts {
2691932µs my $child = shift;
270 my $parent = shift;
271 my $cache = shift;
272230µs my ($known, $partial) = get_status($cache, $child);
# spent 30µs making 2 calls to Carp::get_status, avg 15µs/call
273 # Figure out consequences until we have an answer
274 while (@$partial and not exists $known->{$parent}) {
275 my $anc = shift @$partial;
276 next if exists $known->{$anc};
277 $known->{$anc}++;
278111µs my ($anc_knows, $anc_partial) = get_status($cache, $anc);
# spent 11µs making 1 call to Carp::get_status
279 my @found = keys %$anc_knows;
280 @$known{@found} = ();
281 push @$partial, @$anc_partial;
282 }
283 return exists $known->{$parent};
284}
285
286# Takes a package and gives a list of those trusted directly
287
# spent 20µs within Carp::trusts_directly which was called 3 times, avg 7µs/call: # 3 times (20µs+0s) by Carp::get_status at line 125, avg 7µs/call
sub trusts_directly {
288625µs my $class = shift;
289334µs265µs
# spent 40µs (14+25) within Carp::BEGIN@289 which was called: # once (14µs+25µs) by warnings::_error_loc at line 289
no strict 'refs';
# spent 40µs making 1 call to Carp::BEGIN@289 # spent 25µs making 1 call to strict::unimport
290391µs241µs
# spent 26µs (11+15) within Carp::BEGIN@290 which was called: # once (11µs+15µs) by warnings::_error_loc at line 290
no warnings 'once';
# spent 26µs making 1 call to Carp::BEGIN@290 # spent 15µs making 1 call to warnings::unimport
291 return @{"$class\::CARP_NOT"}
292 ? @{"$class\::CARP_NOT"}
293 : @{"$class\::ISA"};
294}
295
296110µs1;
297
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.