← Index
NYTProf Performance Profile   « line view »
For Makefile.PL
  Run on Sun Mar 1 16:04:44 2015
Reported on Sun Mar 1 16:09:02 2015

FilenameC:/tmp64ng/perl/lib/Carp.pm
StatementsExecuted 1517 statements in 0s
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1110s0sCarp::::BEGIN@131 Carp::BEGIN@131
1110s0sCarp::::BEGIN@171 Carp::BEGIN@171
1110s0sCarp::::BEGIN@3 Carp::BEGIN@3
1110s0sCarp::::BEGIN@4 Carp::BEGIN@4
1110s0sCarp::::BEGIN@49 Carp::BEGIN@49
1110s0sCarp::::BEGIN@5 Carp::BEGIN@5
1110s0sCarp::::BEGIN@555 Carp::BEGIN@555
1110s0sCarp::::BEGIN@568 Carp::BEGIN@568
1110s0sCarp::::BEGIN@575 Carp::BEGIN@575
1110s0sCarp::::BEGIN@6 Carp::BEGIN@6
1110s0sCarp::::BEGIN@61 Carp::BEGIN@61
1110s0sCarp::::BEGIN@73 Carp::BEGIN@73
45210s0sCarp::::CORE:match Carp::CORE:match (opcode)
84210s0sCarp::::CORE:subst Carp::CORE:subst (opcode)
22110s0sCarp::::CORE:substcont Carp::CORE:substcont (opcode)
6110s0sCarp::::__ANON__[:261] Carp::__ANON__[:261]
0000s0sCarp::::__ANON__[:272] Carp::__ANON__[:272]
0000s0sCarp::::__ANON__[:66] Carp::__ANON__[:66]
0000s0sCarp::::__ANON__[:86] Carp::__ANON__[:86]
33310s0sCarp::::_cgc Carp::_cgc
17310s0sCarp::::_fetch_sub Carp::_fetch_sub
21210s0sCarp::::caller_info Carp::caller_info
0000s0sCarp::::carp Carp::carp
0000s0sCarp::::cluck Carp::cluck
0000s0sCarp::::confess Carp::confess
0000s0sCarp::::croak Carp::croak
0000s0sCarp::::export_fail Carp::export_fail
59110s0sCarp::::format_arg Carp::format_arg
0000s0sCarp::::get_status Carp::get_status
18110s0sCarp::::get_subname Carp::get_subname
3110s0sCarp::::long_error_loc Carp::long_error_loc
3110s0sCarp::::longmess Carp::longmess
3110s0sCarp::::longmess_heavy Carp::longmess_heavy
3110s0sCarp::::ret_backtrace Carp::ret_backtrace
0000s0sCarp::::ret_summary Carp::ret_summary
0000s0sCarp::::short_error_loc Carp::short_error_loc
0000s0sCarp::::shortmess Carp::shortmess
0000s0sCarp::::shortmess_heavy Carp::shortmess_heavy
0000s0sCarp::::str_len_trim Carp::str_len_trim
0000s0sCarp::::trusts Carp::trusts
0000s0sCarp::::trusts_directly Carp::trusts_directly
0000s0sRegexp::::CARP_TRACERegexp::CARP_TRACE
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Carp;
2
330s10s
# spent 0s within Carp::BEGIN@3 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 3
{ use 5.006; }
# spent 0s making 1 call to Carp::BEGIN@3
420s20s
# spent 0s within Carp::BEGIN@4 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 4
use strict;
# spent 0s making 1 call to Carp::BEGIN@4 # spent 0s making 1 call to strict::import
520s20s
# spent 0s within Carp::BEGIN@5 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 5
use warnings;
# spent 0s making 1 call to Carp::BEGIN@5 # spent 0s making 1 call to warnings::import
6
# spent 0s within Carp::BEGIN@6 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 26
BEGIN {
7 # Very old versions of warnings.pm load Carp. This can go wrong due
8 # to the circular dependency. If warnings is invoked before Carp,
9 # then warnings starts by loading Carp, then Carp (above) tries to
10 # invoke warnings, and gets nothing because warnings is in the process
11 # of loading and hasn't defined its import method yet. If we were
12 # only turning on warnings ("use warnings" above) this wouldn't be too
13 # bad, because Carp would just gets the state of the -w switch and so
14 # might not get some warnings that it wanted. The real problem is
15 # that we then want to turn off Unicode warnings, but "no warnings
16 # 'utf8'" won't be effective if we're in this circular-dependency
17 # situation. So, if warnings.pm is an affected version, we turn
18 # off all warnings ourselves by directly setting ${^WARNING_BITS}.
19 # On unaffected versions, we turn off just Unicode warnings, via
20 # the proper API.
2110s if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) {
# spent 0s executing statements in string eval
22 ${^WARNING_BITS} = "";
23 } else {
2410s10s "warnings"->unimport("utf8");
# spent 0s making 1 call to warnings::unimport
25 }
2610s10s}
# spent 0s making 1 call to Carp::BEGIN@6
27
28
# spent 0s within Carp::_fetch_sub which was called 17 times, avg 0s/call: # 15 times (0s+0s) by Carp::format_arg at line 280, avg 0s/call # once (0s+0s) by Carp::BEGIN@73 at line 74 # once (0s+0s) by Carp::BEGIN@61 at line 62
sub _fetch_sub { # fetch sub without autovivifying
29170s my($pack, $sub) = @_;
30170s $pack .= '::';
31 # only works with top-level packages
32170s return unless exists($::{$pack});
33170s for ($::{$pack}) {
34170s return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
35170s for ($$_{$sub}) {
36170s return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
37 }
38 }
39}
40
41# UTF8_REGEXP_PROBLEM is a compile-time constant indicating whether Carp
42# must avoid applying a regular expression to an upgraded (is_utf8)
43# string. There are multiple problems, on different Perl versions,
44# that require this to be avoided. All versions prior to 5.13.8 will
45# load utf8_heavy.pl for the swash system, even if the regexp doesn't
46# use character classes. Perl 5.6 and Perls [5.11.2, 5.13.11) exhibit
47# specific problems when Carp is being invoked in the aftermath of a
48# syntax error.
49
# spent 0s within Carp::BEGIN@49 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 55
BEGIN {
5010s if("$]" < 5.013011) {
51 *UTF8_REGEXP_PROBLEM = sub () { 1 };
52 } else {
5310s *UTF8_REGEXP_PROBLEM = sub () { 0 };
54 }
5510s10s}
# spent 0s making 1 call to Carp::BEGIN@49
56
57# is_utf8() is essentially the utf8::is_utf8() function, which indicates
58# whether a string is represented in the upgraded form (using UTF-8
59# internally). As utf8::is_utf8() is only available from Perl 5.8
60# onwards, extra effort is required here to make it work on Perl 5.6.
61
# spent 0s within Carp::BEGIN@61 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 68
BEGIN {
6210s10s if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
# spent 0s making 1 call to Carp::_fetch_sub
63 *is_utf8 = $sub;
64 } else {
65 # black magic for perl 5.6
66 *is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 };
67 }
6810s10s}
# spent 0s making 1 call to Carp::BEGIN@61
69
70# The downgrade() function defined here is to be used for attempts to
71# downgrade where it is acceptable to fail. It must be called with a
72# second argument that is a true value.
73
# spent 0s within Carp::BEGIN@73 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 88
BEGIN {
7410s10s if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
# spent 0s making 1 call to Carp::_fetch_sub
75 *downgrade = \&{"utf8::downgrade"};
76 } else {
77 *downgrade = sub {
78 my $r = "";
79 my $l = length($_[0]);
80 for(my $i = 0; $i != $l; $i++) {
81 my $o = ord(substr($_[0], $i, 1));
82 return if $o > 255;
83 $r .= chr($o);
84 }
85 $_[0] = $r;
86 };
87 }
8810s10s}
# spent 0s making 1 call to Carp::BEGIN@73
89
9010sour $VERSION = '1.3301';
91
9210sour $MaxEvalLen = 0;
9310sour $Verbose = 0;
9410sour $CarpLevel = 0;
9510sour $MaxArgLen = 64; # How much of each argument to print. 0 = all.
9610sour $MaxArgNums = 8; # How many arguments to print. 0 = all.
9710sour $RefArgFormatter = undef; # allow caller to format reference arguments
98
9910srequire Exporter;
10010sour @ISA = ('Exporter');
10110sour @EXPORT = qw(confess croak carp);
10210sour @EXPORT_OK = qw(cluck verbose longmess shortmess);
10310sour @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
104
105# The members of %Internal are packages that are internal to perl.
106# Carp will not report errors from within these packages if it
107# can. The members of %CarpInternal are internal to Perl's warning
108# system. Carp will not report errors from within these packages
109# either, and will not report calls *to* these packages for carp and
110# croak. They replace $CarpLevel, which is deprecated. The
111# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
112# text and function arguments should be formatted when printed.
113
11410sour %CarpInternal;
11510sour %Internal;
116
117# disable these by default, so they can live w/o require Carp
11810s$CarpInternal{Carp}++;
11910s$CarpInternal{warnings}++;
12010s$Internal{Exporter}++;
12110s$Internal{'Exporter::Heavy'}++;
122
123# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
124# then the following method will be called by the Exporter which knows
125# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
126# 'verbose'.
127
128sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
129
130
# spent 0s within Carp::_cgc which was called 33 times, avg 0s/call: # 21 times (0s+0s) by Carp::caller_info at line 183, avg 0s/call # 9 times (0s+0s) by Carp::long_error_loc at line 380, avg 0s/call # 3 times (0s+0s) by Carp::longmess at line 144, avg 0s/call
sub _cgc {
13120s20s
# spent 0s within Carp::BEGIN@131 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 131
no strict 'refs';
# spent 0s making 1 call to Carp::BEGIN@131 # spent 0s making 1 call to strict::unimport
132330s return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
133330s return;
134}
135
136
# spent 0s within Carp::longmess which was called 3 times, avg 0s/call: # 3 times (0s+0s) by ExtUtils::MakeMaker::new at line 564 of ExtUtils/MakeMaker.pm, avg 0s/call
sub longmess {
13730s local($!, $^E);
138 # Icky backwards compatibility wrapper. :-(
139 #
140 # The story is that the original implementation hard-coded the
141 # number of call levels to go back, so calls to longmess were off
142 # by one. Other code began calling longmess and expecting this
143 # behaviour, so the replacement has to emulate that behaviour.
14430s30s my $cgc = _cgc();
# spent 0s making 3 calls to Carp::_cgc, avg 0s/call
14530s my $call_pack = $cgc ? $cgc->() : caller();
14630s if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
147 return longmess_heavy(@_);
148 }
149 else {
15030s local $CarpLevel = $CarpLevel + 1;
15130s30s return longmess_heavy(@_);
# spent 0s making 3 calls to Carp::longmess_heavy, avg 0s/call
152 }
153}
154
15510sour @CARP_NOT;
156
157sub shortmess {
158 local($!, $^E);
159 my $cgc = _cgc();
160
161 # Icky backwards compatibility wrapper. :-(
162 local @CARP_NOT = $cgc ? $cgc->() : caller();
163 shortmess_heavy(@_);
164}
165
166sub croak { die shortmess @_ }
167sub confess { die longmess @_ }
168sub carp { warn shortmess @_ }
169sub cluck { warn longmess @_ }
170
171
# spent 0s within Carp::BEGIN@171 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 178
BEGIN {
17210s if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
173 ("$]" >= 5.012005 && "$]" < 5.013)) {
174 *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
175 } else {
176 *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
177 }
17810s10s}
# spent 0s making 1 call to Carp::BEGIN@171
179
180
# spent 0s within Carp::caller_info which was called 21 times, avg 0s/call: # 18 times (0s+0s) by Carp::ret_backtrace at line 446, avg 0s/call # 3 times (0s+0s) by Carp::ret_backtrace at line 432, avg 0s/call
sub caller_info {
181210s my $i = shift(@_) + 1;
182210s my %call_info;
183210s210s my $cgc = _cgc();
# spent 0s making 21 calls to Carp::_cgc, avg 0s/call
184 {
185 # Some things override caller() but forget to implement the
186 # @DB::args part of it, which we need. We check for this by
187 # pre-populating @DB::args with a sentinel which no-one else
188 # has the address of, so that we can detect whether @DB::args
189 # has been properly populated. However, on earlier versions
190 # of perl this check tickles a bug in CORE::caller() which
191 # leaks memory. So we only check on fixed perls.
192420s @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
193 package DB;
194
195210s
- -
199210s unless ( defined $call_info{file} ) {
200 return ();
201 }
202
203180s180s my $sub_name = Carp::get_subname( \%call_info );
# spent 0s making 18 calls to Carp::get_subname, avg 0s/call
204180s if ( $call_info{has_args} ) {
205140s my @args;
206140s if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
207 && ref $DB::args[0] eq ref \$i
208 && $DB::args[0] == \$i ) {
209 @DB::args = (); # Don't let anyone see the address of $i
210 local $@;
211 my $where = eval {
212 my $func = $cgc or return '';
213 my $gv =
214 (_fetch_sub B => 'svref_2object' or return '')
215 ->($func)->GV;
216 my $package = $gv->STASH->NAME;
217 my $subname = $gv->NAME;
218 return unless defined $package && defined $subname;
219
220 # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
221 return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
222 " in &${package}::$subname";
223 } || '';
224 @args
225 = "** Incomplete caller override detected$where; \@DB::args were not set **";
226 }
227 else {
228140s @args = @DB::args;
229140s my $overflow;
230140s if ( $MaxArgNums and @args > $MaxArgNums )
231 { # More than we want to show?
23230s $#args = $MaxArgNums;
23330s $overflow = 1;
234 }
235
236730s590s @args = map { Carp::format_arg($_) } @args;
# spent 0s making 59 calls to Carp::format_arg, avg 0s/call
237
238140s if ($overflow) {
239 push @args, '...';
240 }
241 }
242
243 # Push the args onto the subroutine
244140s $sub_name .= '(' . join( ', ', @args ) . ')';
245 }
246180s $call_info{sub_name} = $sub_name;
247180s return wantarray() ? %call_info : \%call_info;
248}
249
250# Transform an argument to a function into a string.
25110sour $in_recurse;
252
# spent 0s within Carp::format_arg which was called 59 times, avg 0s/call: # 59 times (0s+0s) by Carp::caller_info at line 236, avg 0s/call
sub format_arg {
253590s my $arg = shift;
254
255590s if ( ref($arg) ) {
256 # legitimate, let's not leak it.
257150s if (!$in_recurse &&
258 do {
259150s local $@;
260150s local $in_recurse = 1;
261210s
# spent 0s within Carp::__ANON__[C:/tmp64ng/perl/lib/Carp.pm:261] which was called 6 times, avg 0s/call: # 6 times (0s+0s) by Carp::format_arg at line 262, avg 0s/call
local $SIG{__DIE__} = sub{};
262300s150s eval {$arg->can('CARP_TRACE') }
# spent 0s making 6 calls to Carp::__ANON__[Carp.pm:261], avg 0s/call # spent 0s making 9 calls to UNIVERSAL::can, avg 0s/call
263 })
264 {
265 return $arg->CARP_TRACE();
266 }
267 elsif (!$in_recurse &&
268 defined($RefArgFormatter) &&
269 do {
270 local $@;
271 local $in_recurse = 1;
272 local $SIG{__DIE__} = sub{};
273 eval {$arg = $RefArgFormatter->($arg); 1}
274 })
275 {
276 return $arg;
277 }
278 else
279 {
280150s150s my $sub = _fetch_sub(overload => 'StrVal');
# spent 0s making 15 calls to Carp::_fetch_sub, avg 0s/call
281150s150s return $sub ? &$sub($arg) : "$arg";
# spent 0s making 15 calls to overload::AddrRef, avg 0s/call
282 }
283 }
284440s return "undef" if !defined($arg);
285420s420s downgrade($arg, 1);
# spent 0s making 42 calls to utf8::downgrade, avg 0s/call
286420s420s return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
# spent 0s making 42 calls to Carp::CORE:match, avg 0s/call
287 $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
288420s my $suffix = "";
289420s if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
290 substr ( $arg, $MaxArgLen - 3 ) = "";
291 $suffix = "...";
292 }
293420s if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
294 for(my $i = length($arg); $i--; ) {
295 my $c = substr($arg, $i, 1);
296 my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
297 if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
298 substr $arg, $i, 0, "\\";
299 next;
300 }
301 my $o = ord($c);
302 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
303 if $o < 0x20 || $o > 0x7f;
304 }
305 } else {
306420s640s $arg =~ s/([\"\\\$\@])/\\$1/g;
# spent 0s making 42 calls to Carp::CORE:subst, avg 0s/call # spent 0s making 22 calls to Carp::CORE:substcont, avg 0s/call
307420s420s $arg =~ s/([^ -~])/sprintf("\\x{%x}",ord($1))/eg;
# spent 0s making 42 calls to Carp::CORE:subst, avg 0s/call
308 }
309420s420s downgrade($arg, 1);
# spent 0s making 42 calls to utf8::downgrade, avg 0s/call
310420s return "\"".$arg."\"".$suffix;
311}
312
313sub Regexp::CARP_TRACE {
314 my $arg = "$_[0]";
315 downgrade($arg, 1);
316 if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
317 for(my $i = length($arg); $i--; ) {
318 my $o = ord(substr($arg, $i, 1));
319 my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
320 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
321 if $o < 0x20 || $o > 0x7f;
322 }
323 } else {
324 $arg =~ s/([^ -~])/sprintf("\\x{%x}",ord($1))/eg;
325 }
326 downgrade($arg, 1);
327 my $suffix = "";
328 if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
329 ($suffix, $arg) = ($1, $2);
330 }
331 if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
332 substr ( $arg, $MaxArgLen - 3 ) = "";
333 $suffix = "...".$suffix;
334 }
335 return "qr($arg)$suffix";
336}
337
338# Takes an inheritance cache and a package and returns
339# an anon hash of known inheritances and anon array of
340# inheritances which consequences have not been figured
341# for.
342sub get_status {
343 my $cache = shift;
344 my $pkg = shift;
345 $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
346 return @{ $cache->{$pkg} };
347}
348
349# Takes the info from caller() and figures out the name of
350# the sub/require/eval
351
# spent 0s within Carp::get_subname which was called 18 times, avg 0s/call: # 18 times (0s+0s) by Carp::caller_info at line 203, avg 0s/call
sub get_subname {
352180s my $info = shift;
353180s if ( defined( $info->{evaltext} ) ) {
35420s my $eval = $info->{evaltext};
35520s if ( $info->{is_require} ) {
356 return "require $eval";
357 }
358 else {
359 $eval =~ s/([\\\'])/\\$1/g;
360 return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
361 }
362 }
363
364 # this can happen on older perls when the sub (or the stash containing it)
365 # has been deleted
366160s if ( !defined( $info->{sub} ) ) {
367 return '__ANON__::__ANON__';
368 }
369
370160s return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
371}
372
373# Figures out what call (from the point of view of the caller)
374# the long error backtrace should start at.
375
# spent 0s within Carp::long_error_loc which was called 3 times, avg 0s/call: # 3 times (0s+0s) by Carp::longmess_heavy at line 414, avg 0s/call
sub long_error_loc {
37630s my $i;
37730s my $lvl = $CarpLevel;
378 {
379120s ++$i;
38090s90s my $cgc = _cgc();
# spent 0s making 9 calls to Carp::_cgc, avg 0s/call
38190s my @caller = $cgc ? $cgc->($i) : caller($i);
38290s my $pkg = $caller[0];
38390s unless ( defined($pkg) ) {
384
385 # This *shouldn't* happen.
386 if (%Internal) {
387 local %Internal;
388 $i = long_error_loc();
389 last;
390 }
391 elsif (defined $caller[2]) {
392 # this can happen when the stash has been deleted
393 # in that case, just assume that it's a reasonable place to
394 # stop (the file and line data will still be intact in any
395 # case) - the only issue is that we can't detect if the
396 # deleted package was internal (so don't do that then)
397 # -doy
398 redo unless 0 > --$lvl;
399 last;
400 }
401 else {
402 return 2;
403 }
404 }
40590s redo if $CarpInternal{$pkg};
40660s redo unless 0 > --$lvl;
40730s redo if $Internal{$pkg};
408 }
40930s return $i - 1;
410}
411
412
# spent 0s within Carp::longmess_heavy which was called 3 times, avg 0s/call: # 3 times (0s+0s) by Carp::longmess at line 151, avg 0s/call
sub longmess_heavy {
41330s return @_ if ref( $_[0] ); # don't break references as exceptions
41430s30s my $i = long_error_loc();
# spent 0s making 3 calls to Carp::long_error_loc, avg 0s/call
41530s30s return ret_backtrace( $i, @_ );
# spent 0s making 3 calls to Carp::ret_backtrace, avg 0s/call
416}
417
418# Returns a full stack backtrace starting from where it is
419# told.
420
# spent 0s within Carp::ret_backtrace which was called 3 times, avg 0s/call: # 3 times (0s+0s) by Carp::longmess_heavy at line 415, avg 0s/call
sub ret_backtrace {
42130s my ( $i, @error ) = @_;
42230s my $mess;
42330s my $err = join '', @error;
42430s $i++;
425
42630s my $tid_msg = '';
42730s if ( defined &threads::tid ) {
428 my $tid = threads->tid;
429 $tid_msg = " thread $tid" if $tid;
430 }
431
43230s30s my %i = caller_info($i);
# spent 0s making 3 calls to Carp::caller_info, avg 0s/call
43330s $mess = "$err at $i{file} line $i{line}$tid_msg";
43430s if( defined $. ) {
43530s local $@ = '';
43630s local $SIG{__DIE__};
43730s eval {
43830s CORE::die;
439 };
44030s30s if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
# spent 0s making 3 calls to Carp::CORE:match, avg 0s/call
441 $mess .= $1;
442 }
443 }
44430s $mess .= "\.\n";
445
44630s180s while ( my %i = caller_info( ++$i ) ) {
# spent 0s making 18 calls to Carp::caller_info, avg 0s/call
447 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
448 }
449
45030s return $mess;
451}
452
453sub ret_summary {
454 my ( $i, @error ) = @_;
455 my $err = join '', @error;
456 $i++;
457
458 my $tid_msg = '';
459 if ( defined &threads::tid ) {
460 my $tid = threads->tid;
461 $tid_msg = " thread $tid" if $tid;
462 }
463
464 my %i = caller_info($i);
465 return "$err at $i{file} line $i{line}$tid_msg\.\n";
466}
467
468sub short_error_loc {
469 # You have to create your (hash)ref out here, rather than defaulting it
470 # inside trusts *on a lexical*, as you want it to persist across calls.
471 # (You can default it on $_[2], but that gets messy)
472 my $cache = {};
473 my $i = 1;
474 my $lvl = $CarpLevel;
475 {
476 my $cgc = _cgc();
477 my $called = $cgc ? $cgc->($i) : caller($i);
478 $i++;
479 my $caller = $cgc ? $cgc->($i) : caller($i);
480
481 if (!defined($caller)) {
482 my @caller = $cgc ? $cgc->($i) : caller($i);
483 if (@caller) {
484 # if there's no package but there is other caller info, then
485 # the package has been deleted - treat this as a valid package
486 # in this case
487 redo if defined($called) && $CarpInternal{$called};
488 redo unless 0 > --$lvl;
489 last;
490 }
491 else {
492 return 0;
493 }
494 }
495 redo if $Internal{$caller};
496 redo if $CarpInternal{$caller};
497 redo if $CarpInternal{$called};
498 redo if trusts( $called, $caller, $cache );
499 redo if trusts( $caller, $called, $cache );
500 redo unless 0 > --$lvl;
501 }
502 return $i - 1;
503}
504
505sub shortmess_heavy {
506 return longmess_heavy(@_) if $Verbose;
507 return @_ if ref( $_[0] ); # don't break references as exceptions
508 my $i = short_error_loc();
509 if ($i) {
510 ret_summary( $i, @_ );
511 }
512 else {
513 longmess_heavy(@_);
514 }
515}
516
517# If a string is too long, trims it with ...
518sub str_len_trim {
519 my $str = shift;
520 my $max = shift || 0;
521 if ( 2 < $max and $max < length($str) ) {
522 substr( $str, $max - 3 ) = '...';
523 }
524 return $str;
525}
526
527# Takes two packages and an optional cache. Says whether the
528# first inherits from the second.
529#
530# Recursive versions of this have to work to avoid certain
531# possible endless loops, and when following long chains of
532# inheritance are less efficient.
533sub trusts {
534 my $child = shift;
535 my $parent = shift;
536 my $cache = shift;
537 my ( $known, $partial ) = get_status( $cache, $child );
538
539 # Figure out consequences until we have an answer
540 while ( @$partial and not exists $known->{$parent} ) {
541 my $anc = shift @$partial;
542 next if exists $known->{$anc};
543 $known->{$anc}++;
544 my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
545 my @found = keys %$anc_knows;
546 @$known{@found} = ();
547 push @$partial, @$anc_partial;
548 }
549 return exists $known->{$parent};
550}
551
552# Takes a package and gives a list of those trusted directly
553sub trusts_directly {
554 my $class = shift;
55520s20s
# spent 0s within Carp::BEGIN@555 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 555
no strict 'refs';
# spent 0s making 1 call to Carp::BEGIN@555 # spent 0s making 1 call to strict::unimport
556 my $stash = \%{"$class\::"};
557 for my $var (qw/ CARP_NOT ISA /) {
558 # Don't try using the variable until we know it exists,
559 # to avoid polluting the caller's namespace.
560 if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
561 return @{$stash->{$var}}
562 }
563 }
564 return;
565}
566
56710sif(!defined($warnings::VERSION) ||
56830s20s
# spent 0s within Carp::BEGIN@568 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 568
do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
# spent 0s making 1 call to Carp::BEGIN@568 # spent 0s making 1 call to warnings::unimport
569 # Very old versions of warnings.pm import from Carp. This can go
570 # wrong due to the circular dependency. If Carp is invoked before
571 # warnings, then Carp starts by loading warnings, then warnings
572 # tries to import from Carp, and gets nothing because Carp is in
573 # the process of loading and hasn't defined its import method yet.
574 # So we work around that by manually exporting to warnings here.
57520s20s
# spent 0s within Carp::BEGIN@575 which was called: # once (0s+0s) by ExtUtils::MakeMaker::BEGIN@11 at line 575
no strict "refs";
# spent 0s making 1 call to Carp::BEGIN@575 # spent 0s making 1 call to strict::unimport
576 *{"warnings::$_"} = \&$_ foreach @EXPORT;
577}
578
57910s1;
580
581__END__
 
# spent 0s within Carp::CORE:match which was called 45 times, avg 0s/call: # 42 times (0s+0s) by Carp::format_arg at line 286, avg 0s/call # 3 times (0s+0s) by Carp::ret_backtrace at line 440, avg 0s/call
sub Carp::CORE:match; # opcode
# spent 0s within Carp::CORE:subst which was called 84 times, avg 0s/call: # 42 times (0s+0s) by Carp::format_arg at line 307, avg 0s/call # 42 times (0s+0s) by Carp::format_arg at line 306, avg 0s/call
sub Carp::CORE:subst; # opcode
# spent 0s within Carp::CORE:substcont which was called 22 times, avg 0s/call: # 22 times (0s+0s) by Carp::format_arg at line 306, avg 0s/call
sub Carp::CORE:substcont; # opcode
Report produced by the NYTProf 5.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.