Profile of Carp.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For t/app_dpath.t
Run on Tue Jun 5 15:25:28 2012
Reported on Tue Jun 5 15:25:59 2012

Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/site_perl/5.14.1/Carp.pm
Statements | Executed 46 statements in 13.6ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 164µs | 164µs | Carp::::BEGIN@7Carp::BEGIN@7
1 | 1 | 1 | 140µs | 157µs | Carp::::BEGIN@4Carp::BEGIN@4
1 | 1 | 1 | 65µs | 65µs | Carp::::BEGIN@3Carp::BEGIN@3
1 | 1 | 1 | 55µs | 130µs | Carp::::BEGIN@398Carp::BEGIN@398
1 | 1 | 1 | 55µs | 55µs | Carp::::BEGIN@105Carp::BEGIN@105
1 | 1 | 1 | 41µs | 76µs | Carp::::BEGIN@406Carp::BEGIN@406
1 | 1 | 1 | 35µs | 71µs | Carp::::BEGIN@413Carp::BEGIN@413
1 | 1 | 1 | 30µs | 98µs | Carp::::BEGIN@399Carp::BEGIN@399
1 | 1 | 1 | 27µs | 53µs | Carp::::BEGIN@5Carp::BEGIN@5
1 | 1 | 1 | 26µs | 68µs | Carp::::BEGIN@67Carp::BEGIN@67
1 | 1 | 1 | 25µs | 80µs | Carp::::BEGIN@8Carp::BEGIN@8
1 | 1 | 1 | 24µs | 70µs | Carp::::BEGIN@18Carp::BEGIN@18
1 | 1 | 1 | 23µs | 23µs | Carp::::BEGIN@17Carp::BEGIN@17
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:13]Carp::__ANON__[:13]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:23]Carp::__ANON__[:23]
0 | 0 | 0 | 0s | 0s | Carp::::_cgcCarp::_cgc
0 | 0 | 0 | 0s | 0s | Carp::::caller_infoCarp::caller_info
0 | 0 | 0 | 0s | 0s | Carp::::carpCarp::carp
0 | 0 | 0 | 0s | 0s | Carp::::cluckCarp::cluck
0 | 0 | 0 | 0s | 0s | Carp::::confessCarp::confess
0 | 0 | 0 | 0s | 0s | Carp::::croakCarp::croak
0 | 0 | 0 | 0s | 0s | Carp::::export_failCarp::export_fail
0 | 0 | 0 | 0s | 0s | Carp::::format_argCarp::format_arg
0 | 0 | 0 | 0s | 0s | Carp::::get_statusCarp::get_status
0 | 0 | 0 | 0s | 0s | Carp::::get_subnameCarp::get_subname
0 | 0 | 0 | 0s | 0s | Carp::::long_error_locCarp::long_error_loc
0 | 0 | 0 | 0s | 0s | Carp::::longmessCarp::longmess
0 | 0 | 0 | 0s | 0s | Carp::::longmess_heavyCarp::longmess_heavy
0 | 0 | 0 | 0s | 0s | Carp::::ret_backtraceCarp::ret_backtrace
0 | 0 | 0 | 0s | 0s | Carp::::ret_summaryCarp::ret_summary
0 | 0 | 0 | 0s | 0s | Carp::::short_error_locCarp::short_error_loc
0 | 0 | 0 | 0s | 0s | Carp::::shortmessCarp::shortmess
0 | 0 | 0 | 0s | 0s | Carp::::shortmess_heavyCarp::shortmess_heavy
0 | 0 | 0 | 0s | 0s | Carp::::str_len_trimCarp::str_len_trim
0 | 0 | 0 | 0s | 0s | Carp::::trustsCarp::trusts
0 | 0 | 0 | 0s | 0s | Carp::::trusts_directlyCarp::trusts_directly

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Carp;
2 |  |  |  |  |
3 | 3 | 177µs | 1 | 65µs | # spent 65µs within Carp::BEGIN@3 which was called: # once (65µs+0s) by Data::Dumper::BEGIN@20 at line 3 { use 5.006; } # spent 65µs making 1 call to Carp::BEGIN@3
4 | 2 | 104µs | 2 | 174µs | # spent 157µs (140+17) within Carp::BEGIN@4 which was called: # once (140µs+17µs) by Data::Dumper::BEGIN@20 at line 4 use strict; # spent 157µs making 1 call to Carp::BEGIN@4 # spent 17µs making 1 call to strict::import
5 | 2 | 118µs | 2 | 79µs | # spent 53µs (27+26) within Carp::BEGIN@5 which was called: # once (27µs+26µs) by Data::Dumper::BEGIN@20 at line 5 use warnings; # spent 53µs making 1 call to Carp::BEGIN@5 # spent 26µs making 1 call to warnings::import
6 |  |  |  |  |
7 |  |  |  |  | # spent 164µs within Carp::BEGIN@7 which was called: # once (164µs+0s) by Data::Dumper::BEGIN@20 at line 15 BEGIN {
8 | 2 | 482µs | 2 | 136µs | # spent 80µs (25+56) within Carp::BEGIN@8 which was called: # once (25µs+56µs) by Data::Dumper::BEGIN@20 at line 8 no strict "refs"; # spent 80µs making 1 call to Carp::BEGIN@8 # spent 56µs making 1 call to strict::unimport
9 | 1 | 67µs |  |  | if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"is_utf8"}) &&
10 |  |  |  |  | defined(*{*{$::{"utf8::"}}{HASH}->{"is_utf8"}}{CODE})) {
11 |  |  |  |  | *is_utf8 = \&{"utf8::is_utf8"};
12 |  |  |  |  | } else {
13 |  |  |  |  | *is_utf8 = sub { 0 };
14 |  |  |  |  | }
15 | 1 | 121µs | 1 | 164µs | } # spent 164µs making 1 call to Carp::BEGIN@7
16 |  |  |  |  |
17 |  |  |  |  | # spent 23µs within Carp::BEGIN@17 which was called: # once (23µs+0s) by Data::Dumper::BEGIN@20 at line 25 BEGIN {
18 | 2 | 304µs | 2 | 116µs | # spent 70µs (24+46) within Carp::BEGIN@18 which was called: # once (24µs+46µs) by Data::Dumper::BEGIN@20 at line 18 no strict "refs"; # spent 70µs making 1 call to Carp::BEGIN@18 # spent 46µs making 1 call to strict::unimport
19 | 1 | 30µs |  |  | if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"downgrade"}) &&
20 |  |  |  |  | defined(*{*{$::{"utf8::"}}{HASH}->{"downgrade"}}{CODE})) {
21 |  |  |  |  | *downgrade = \&{"utf8::downgrade"};
22 |  |  |  |  | } else {
23 |  |  |  |  | *downgrade = sub {};
24 |  |  |  |  | }
25 | 1 | 799µs | 1 | 23µs | } # spent 23µs making 1 call to Carp::BEGIN@17
26 |  |  |  |  |
27 | 1 | 2µs |  |  | our $VERSION = '1.25';
28 |  |  |  |  |
29 | 1 | 1µs |  |  | our $MaxEvalLen = 0;
30 | 1 | 700ns |  |  | our $Verbose = 0;
31 | 1 | 600ns |  |  | our $CarpLevel = 0;
32 | 1 | 800ns |  |  | our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
33 | 1 | 800ns |  |  | our $MaxArgNums = 8; # How many arguments to print. 0 = all.
34 |  |  |  |  |
35 | 1 | 2.81ms |  |  | require Exporter;
36 | 1 | 32µs |  |  | our @ISA = ('Exporter');
37 | 1 | 5µs |  |  | our @EXPORT = qw(confess croak carp);
38 | 1 | 5µs |  |  | our @EXPORT_OK = qw(cluck verbose longmess shortmess);
39 | 1 | 2µs |  |  | our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
40 |  |  |  |  |
41 |  |  |  |  | # The members of %Internal are packages that are internal to perl.
42 |  |  |  |  | # Carp will not report errors from within these packages if it
43 |  |  |  |  | # can. The members of %CarpInternal are internal to Perl's warning
44 |  |  |  |  | # system. Carp will not report errors from within these packages
45 |  |  |  |  | # either, and will not report calls *to* these packages for carp and
46 |  |  |  |  | # croak. They replace $CarpLevel, which is deprecated. The
47 |  |  |  |  | # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
48 |  |  |  |  | # text and function arguments should be formatted when printed.
49 |  |  |  |  |
50 | 1 | 1µs |  |  | our %CarpInternal;
51 | 1 | 1µs |  |  | our %Internal;
52 |  |  |  |  |
53 |  |  |  |  | # disable these by default, so they can live w/o require Carp
54 | 1 | 5µs |  |  | $CarpInternal{Carp}++;
55 | 1 | 2µs |  |  | $CarpInternal{warnings}++;
56 | 1 | 2µs |  |  | $Internal{Exporter}++;
57 | 1 | 2µs |  |  | $Internal{'Exporter::Heavy'}++;
58 |  |  |  |  |
59 |  |  |  |  | # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
60 |  |  |  |  | # then the following method will be called by the Exporter which knows
61 |  |  |  |  | # to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
62 |  |  |  |  | # 'verbose'.
63 |  |  |  |  |
64 |  |  |  |  | sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
65 |  |  |  |  |
66 |  |  |  |  | sub _cgc {
67 | 2 | 1.31ms | 2 | 109µs | # spent 68µs (26+42) within Carp::BEGIN@67 which was called: # once (26µs+42µs) by Data::Dumper::BEGIN@20 at line 67 no strict 'refs'; # spent 68µs making 1 call to Carp::BEGIN@67 # spent 42µs making 1 call to strict::unimport
68 |  |  |  |  | return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
69 |  |  |  |  | return;
70 |  |  |  |  | }
71 |  |  |  |  |
72 |  |  |  |  | sub longmess {
73 |  |  |  |  | # Icky backwards compatibility wrapper. :-(
74 |  |  |  |  | #
75 |  |  |  |  | # The story is that the original implementation hard-coded the
76 |  |  |  |  | # number of call levels to go back, so calls to longmess were off
77 |  |  |  |  | # by one. Other code began calling longmess and expecting this
78 |  |  |  |  | # behaviour, so the replacement has to emulate that behaviour.
79 |  |  |  |  | my $cgc = _cgc();
80 |  |  |  |  | my $call_pack = $cgc ? $cgc->() : caller();
81 |  |  |  |  | if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
82 |  |  |  |  | return longmess_heavy(@_);
83 |  |  |  |  | }
84 |  |  |  |  | else {
85 |  |  |  |  | local $CarpLevel = $CarpLevel + 1;
86 |  |  |  |  | return longmess_heavy(@_);
87 |  |  |  |  | }
88 |  |  |  |  | }
89 |  |  |  |  |
90 | 1 | 2µs |  |  | our @CARP_NOT;
91 |  |  |  |  |
92 |  |  |  |  | sub shortmess {
93 |  |  |  |  | my $cgc = _cgc();
94 |  |  |  |  |
95 |  |  |  |  | # Icky backwards compatibility wrapper. :-(
96 |  |  |  |  | local @CARP_NOT = $cgc ? $cgc->() : caller();
97 |  |  |  |  | shortmess_heavy(@_);
98 |  |  |  |  | }
99 |  |  |  |  |
100 |  |  |  |  | sub croak { die shortmess @_ }
101 |  |  |  |  | sub confess { die longmess @_ }
102 |  |  |  |  | sub carp { warn shortmess @_ }
103 |  |  |  |  | sub cluck { warn longmess @_ }
104 |  |  |  |  |
105 |  |  |  |  | # spent 55µs within Carp::BEGIN@105 which was called: # once (55µs+0s) by Data::Dumper::BEGIN@20 at line 112 BEGIN {
106 | 2 | 56µs |  |  | if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
107 |  |  |  |  | ("$]" >= 5.012005 && "$]" < 5.013)) {
108 |  |  |  |  | *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
109 |  |  |  |  | } else {
110 |  |  |  |  | *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
111 |  |  |  |  | }
112 | 1 | 6.27ms | 1 | 55µs | } # spent 55µs making 1 call to Carp::BEGIN@105
113 |  |  |  |  |
114 |  |  |  |  | sub caller_info {
115 |  |  |  |  | my $i = shift(@_) + 1;
116 |  |  |  |  | my %call_info;
117 |  |  |  |  | my $cgc = _cgc();
118 |  |  |  |  | {
119 |  |  |  |  | # Some things override caller() but forget to implement the
120 |  |  |  |  | # @DB::args part of it, which we need. We check for this by
121 |  |  |  |  | # pre-populating @DB::args with a sentinel which no-one else
122 |  |  |  |  | # has the address of, so that we can detect whether @DB::args
123 |  |  |  |  | # has been properly populated. However, on earlier versions
124 |  |  |  |  | # of perl this check tickles a bug in CORE::caller() which
125 |  |  |  |  | # leaks memory. So we only check on fixed perls.
126 |  |  |  |  | @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
127 |  |  |  |  | package DB;
128 |  |  |  |  |
- - |  |  |  |  |
133 |  |  |  |  | unless ( defined $call_info{pack} ) {
134 |  |  |  |  | return ();
135 |  |  |  |  | }
136 |  |  |  |  |
137 |  |  |  |  | my $sub_name = Carp::get_subname( \%call_info );
138 |  |  |  |  | if ( $call_info{has_args} ) {
139 |  |  |  |  | my @args;
140 |  |  |  |  | if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
141 |  |  |  |  | && ref $DB::args[0] eq ref \$i
142 |  |  |  |  | && $DB::args[0] == \$i ) {
143 |  |  |  |  | @DB::args = (); # Don't let anyone see the address of $i
144 |  |  |  |  | local $@;
145 |  |  |  |  | my $where = eval {
146 |  |  |  |  | my $func = $cgc or return '';
147 |  |  |  |  | my $gv =
148 |  |  |  |  | *{
149 |  |  |  |  | ( $::{"B::"} || return '') # B stash
150 |  |  |  |  | ->{svref_2object} || return '' # entry in stash
151 |  |  |  |  | }{CODE} # coderef in entry
152 |  |  |  |  | ->($func)->GV;
153 |  |  |  |  | my $package = $gv->STASH->NAME;
154 |  |  |  |  | my $subname = $gv->NAME;
155 |  |  |  |  | return unless defined $package && defined $subname;
156 |  |  |  |  |
157 |  |  |  |  | # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
158 |  |  |  |  | return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
159 |  |  |  |  | " in &${package}::$subname";
160 |  |  |  |  | } || '';
161 |  |  |  |  | @args
162 |  |  |  |  | = "** Incomplete caller override detected$where; \@DB::args were not set **";
163 |  |  |  |  | }
164 |  |  |  |  | else {
165 |  |  |  |  | @args = map { Carp::format_arg($_) } @DB::args;
166 |  |  |  |  | }
167 |  |  |  |  | if ( $MaxArgNums and @args > $MaxArgNums )
168 |  |  |  |  | { # More than we want to show?
169 |  |  |  |  | $#args = $MaxArgNums;
170 |  |  |  |  | push @args, '...';
171 |  |  |  |  | }
172 |  |  |  |  |
173 |  |  |  |  | # Push the args onto the subroutine
174 |  |  |  |  | $sub_name .= '(' . join( ', ', @args ) . ')';
175 |  |  |  |  | }
176 |  |  |  |  | $call_info{sub_name} = $sub_name;
177 |  |  |  |  | return wantarray() ? %call_info : \%call_info;
178 |  |  |  |  | }
179 |  |  |  |  |
180 |  |  |  |  | # Transform an argument to a function into a string.
181 |  |  |  |  | sub format_arg {
182 |  |  |  |  | my $arg = shift;
183 |  |  |  |  | if ( ref($arg) ) {
184 |  |  |  |  | $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
185 |  |  |  |  | }
186 |  |  |  |  | if ( defined($arg) ) {
187 |  |  |  |  | $arg =~ s/'/\\'/g;
188 |  |  |  |  | $arg = str_len_trim( $arg, $MaxArgLen );
189 |  |  |  |  |
190 |  |  |  |  | # Quote it?
191 |  |  |  |  | # Downgrade, and use [0-9] rather than \d, to avoid loading
192 |  |  |  |  | # Unicode tables, which would be liable to fail if we're
193 |  |  |  |  | # processing a syntax error.
194 |  |  |  |  | downgrade($arg, 1);
195 |  |  |  |  | $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/;
196 |  |  |  |  | }
197 |  |  |  |  | else {
198 |  |  |  |  | $arg = 'undef';
199 |  |  |  |  | }
200 |  |  |  |  |
201 |  |  |  |  | # The following handling of "control chars" is direct from
202 |  |  |  |  | # the original code - it is broken on Unicode though.
203 |  |  |  |  | # Suggestions?
204 |  |  |  |  | is_utf8($arg)
205 |  |  |  |  | or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
206 |  |  |  |  | return $arg;
207 |  |  |  |  | }
208 |  |  |  |  |
209 |  |  |  |  | # Takes an inheritance cache and a package and returns
210 |  |  |  |  | # an anon hash of known inheritances and anon array of
211 |  |  |  |  | # inheritances which consequences have not been figured
212 |  |  |  |  | # for.
213 |  |  |  |  | sub get_status {
214 |  |  |  |  | my $cache = shift;
215 |  |  |  |  | my $pkg = shift;
216 |  |  |  |  | $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
217 |  |  |  |  | return @{ $cache->{$pkg} };
218 |  |  |  |  | }
219 |  |  |  |  |
220 |  |  |  |  | # Takes the info from caller() and figures out the name of
221 |  |  |  |  | # the sub/require/eval
222 |  |  |  |  | sub get_subname {
223 |  |  |  |  | my $info = shift;
224 |  |  |  |  | if ( defined( $info->{evaltext} ) ) {
225 |  |  |  |  | my $eval = $info->{evaltext};
226 |  |  |  |  | if ( $info->{is_require} ) {
227 |  |  |  |  | return "require $eval";
228 |  |  |  |  | }
229 |  |  |  |  | else {
230 |  |  |  |  | $eval =~ s/([\\\'])/\\$1/g;
231 |  |  |  |  | return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
232 |  |  |  |  | }
233 |  |  |  |  | }
234 |  |  |  |  |
235 |  |  |  |  | return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
236 |  |  |  |  | }
237 |  |  |  |  |
238 |  |  |  |  | # Figures out what call (from the point of view of the caller)
239 |  |  |  |  | # the long error backtrace should start at.
240 |  |  |  |  | sub long_error_loc {
241 |  |  |  |  | my $i;
242 |  |  |  |  | my $lvl = $CarpLevel;
243 |  |  |  |  | {
244 |  |  |  |  | ++$i;
245 |  |  |  |  | my $cgc = _cgc();
246 |  |  |  |  | my $pkg = $cgc ? $cgc->($i) : caller($i);
247 |  |  |  |  | unless ( defined($pkg) ) {
248 |  |  |  |  |
249 |  |  |  |  | # This *shouldn't* happen.
250 |  |  |  |  | if (%Internal) {
251 |  |  |  |  | local %Internal;
252 |  |  |  |  | $i = long_error_loc();
253 |  |  |  |  | last;
254 |  |  |  |  | }
255 |  |  |  |  | else {
256 |  |  |  |  |
257 |  |  |  |  | # OK, now I am irritated.
258 |  |  |  |  | return 2;
259 |  |  |  |  | }
260 |  |  |  |  | }
261 |  |  |  |  | redo if $CarpInternal{$pkg};
262 |  |  |  |  | redo unless 0 > --$lvl;
263 |  |  |  |  | redo if $Internal{$pkg};
264 |  |  |  |  | }
265 |  |  |  |  | return $i - 1;
266 |  |  |  |  | }
267 |  |  |  |  |
268 |  |  |  |  | sub longmess_heavy {
269 |  |  |  |  | return @_ if ref( $_[0] ); # don't break references as exceptions
270 |  |  |  |  | my $i = long_error_loc();
271 |  |  |  |  | return ret_backtrace( $i, @_ );
272 |  |  |  |  | }
273 |  |  |  |  |
274 |  |  |  |  | # Returns a full stack backtrace starting from where it is
275 |  |  |  |  | # told.
276 |  |  |  |  | sub ret_backtrace {
277 |  |  |  |  | my ( $i, @error ) = @_;
278 |  |  |  |  | my $mess;
279 |  |  |  |  | my $err = join '', @error;
280 |  |  |  |  | $i++;
281 |  |  |  |  |
282 |  |  |  |  | my $tid_msg = '';
283 |  |  |  |  | if ( defined &threads::tid ) {
284 |  |  |  |  | my $tid = threads->tid;
285 |  |  |  |  | $tid_msg = " thread $tid" if $tid;
286 |  |  |  |  | }
287 |  |  |  |  |
288 |  |  |  |  | my %i = caller_info($i);
289 |  |  |  |  | $mess = "$err at $i{file} line $i{line}$tid_msg";
290 |  |  |  |  | if( defined $. ) {
291 |  |  |  |  | local $@ = '';
292 |  |  |  |  | local $SIG{__DIE__};
293 |  |  |  |  | eval {
294 |  |  |  |  | die;
295 |  |  |  |  | };
296 |  |  |  |  | if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
297 |  |  |  |  | $mess .= $1;
298 |  |  |  |  | }
299 |  |  |  |  | }
300 |  |  |  |  | $mess .= "\.\n";
301 |  |  |  |  |
302 |  |  |  |  | while ( my %i = caller_info( ++$i ) ) {
303 |  |  |  |  | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
304 |  |  |  |  | }
305 |  |  |  |  |
306 |  |  |  |  | return $mess;
307 |  |  |  |  | }
308 |  |  |  |  |
309 |  |  |  |  | sub ret_summary {
310 |  |  |  |  | my ( $i, @error ) = @_;
311 |  |  |  |  | my $err = join '', @error;
312 |  |  |  |  | $i++;
313 |  |  |  |  |
314 |  |  |  |  | my $tid_msg = '';
315 |  |  |  |  | if ( defined &threads::tid ) {
316 |  |  |  |  | my $tid = threads->tid;
317 |  |  |  |  | $tid_msg = " thread $tid" if $tid;
318 |  |  |  |  | }
319 |  |  |  |  |
320 |  |  |  |  | my %i = caller_info($i);
321 |  |  |  |  | return "$err at $i{file} line $i{line}$tid_msg\.\n";
322 |  |  |  |  | }
323 |  |  |  |  |
324 |  |  |  |  | sub short_error_loc {
325 |  |  |  |  | # You have to create your (hash)ref out here, rather than defaulting it
326 |  |  |  |  | # inside trusts *on a lexical*, as you want it to persist across calls.
327 |  |  |  |  | # (You can default it on $_[2], but that gets messy)
328 |  |  |  |  | my $cache = {};
329 |  |  |  |  | my $i = 1;
330 |  |  |  |  | my $lvl = $CarpLevel;
331 |  |  |  |  | {
332 |  |  |  |  | my $cgc = _cgc();
333 |  |  |  |  | my $called = $cgc ? $cgc->($i) : caller($i);
334 |  |  |  |  | $i++;
335 |  |  |  |  | my $caller = $cgc ? $cgc->($i) : caller($i);
336 |  |  |  |  |
337 |  |  |  |  | return 0 unless defined($caller); # What happened?
338 |  |  |  |  | redo if $Internal{$caller};
339 |  |  |  |  | redo if $CarpInternal{$caller};
340 |  |  |  |  | redo if $CarpInternal{$called};
341 |  |  |  |  | redo if trusts( $called, $caller, $cache );
342 |  |  |  |  | redo if trusts( $caller, $called, $cache );
343 |  |  |  |  | redo unless 0 > --$lvl;
344 |  |  |  |  | }
345 |  |  |  |  | return $i - 1;
346 |  |  |  |  | }
347 |  |  |  |  |
348 |  |  |  |  | sub shortmess_heavy {
349 |  |  |  |  | return longmess_heavy(@_) if $Verbose;
350 |  |  |  |  | return @_ if ref( $_[0] ); # don't break references as exceptions
351 |  |  |  |  | my $i = short_error_loc();
352 |  |  |  |  | if ($i) {
353 |  |  |  |  | ret_summary( $i, @_ );
354 |  |  |  |  | }
355 |  |  |  |  | else {
356 |  |  |  |  | longmess_heavy(@_);
357 |  |  |  |  | }
358 |  |  |  |  | }
359 |  |  |  |  |
360 |  |  |  |  | # If a string is too long, trims it with ...
361 |  |  |  |  | sub str_len_trim {
362 |  |  |  |  | my $str = shift;
363 |  |  |  |  | my $max = shift || 0;
364 |  |  |  |  | if ( 2 < $max and $max < length($str) ) {
365 |  |  |  |  | substr( $str, $max - 3 ) = '...';
366 |  |  |  |  | }
367 |  |  |  |  | return $str;
368 |  |  |  |  | }
369 |  |  |  |  |
370 |  |  |  |  | # Takes two packages and an optional cache. Says whether the
371 |  |  |  |  | # first inherits from the second.
372 |  |  |  |  | #
373 |  |  |  |  | # Recursive versions of this have to work to avoid certain
374 |  |  |  |  | # possible endless loops, and when following long chains of
375 |  |  |  |  | # inheritance are less efficient.
376 |  |  |  |  | sub trusts {
377 |  |  |  |  | my $child = shift;
378 |  |  |  |  | my $parent = shift;
379 |  |  |  |  | my $cache = shift;
380 |  |  |  |  | my ( $known, $partial ) = get_status( $cache, $child );
381 |  |  |  |  |
382 |  |  |  |  | # Figure out consequences until we have an answer
383 |  |  |  |  | while ( @$partial and not exists $known->{$parent} ) {
384 |  |  |  |  | my $anc = shift @$partial;
385 |  |  |  |  | next if exists $known->{$anc};
386 |  |  |  |  | $known->{$anc}++;
387 |  |  |  |  | my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
388 |  |  |  |  | my @found = keys %$anc_knows;
389 |  |  |  |  | @$known{@found} = ();
390 |  |  |  |  | push @$partial, @$anc_partial;
391 |  |  |  |  | }
392 |  |  |  |  | return exists $known->{$parent};
393 |  |  |  |  | }
394 |  |  |  |  |
395 |  |  |  |  | # Takes a package and gives a list of those trusted directly
396 |  |  |  |  | sub trusts_directly {
397 |  |  |  |  | my $class = shift;
398 | 2 | 110µs | 2 | 204µs | # spent 130µs (55+75) within Carp::BEGIN@398 which was called: # once (55µs+75µs) by Data::Dumper::BEGIN@20 at line 398 no strict 'refs'; # spent 130µs making 1 call to Carp::BEGIN@398 # spent 75µs making 1 call to strict::unimport
399 | 2 | 288µs | 2 | 166µs | # spent 98µs (30+68) within Carp::BEGIN@399 which was called: # once (30µs+68µs) by Data::Dumper::BEGIN@20 at line 399 no warnings 'once'; # spent 98µs making 1 call to Carp::BEGIN@399 # spent 68µs making 1 call to warnings::unimport
400 |  |  |  |  | return @{"$class\::CARP_NOT"}
401 |  |  |  |  | ? @{"$class\::CARP_NOT"}
402 |  |  |  |  | : @{"$class\::ISA"};
403 |  |  |  |  | }
404 |  |  |  |  |
405 | 1 | 6µs |  |  | if(!defined($warnings::VERSION) ||
406 | 3 | 159µs | 2 | 111µs | # spent 76µs (41+35) within Carp::BEGIN@406 which was called: # once (41µs+35µs) by Data::Dumper::BEGIN@20 at line 406 do { no warnings "numeric"; $warnings::VERSION < 1.03 }) { # spent 76µs making 1 call to Carp::BEGIN@406 # spent 35µs making 1 call to warnings::unimport
407 |  |  |  |  | # Very old versions of warnings.pm import from Carp. This can go
408 |  |  |  |  | # wrong due to the circular dependency. If Carp is invoked before
409 |  |  |  |  | # warnings, then Carp starts by loading warnings, then warnings
410 |  |  |  |  | # tries to import from Carp, and gets nothing because Carp is in
411 |  |  |  |  | # the process of loading and hasn't defined its import method yet.
412 |  |  |  |  | # So we work around that by manually exporting to warnings here.
413 | 2 | 271µs | 2 | 107µs | # spent 71µs (35+36) within Carp::BEGIN@413 which was called: # once (35µs+36µs) by Data::Dumper::BEGIN@20 at line 413 no strict "refs"; # spent 71µs making 1 call to Carp::BEGIN@413 # spent 36µs making 1 call to strict::unimport
414 |  |  |  |  | *{"warnings::$_"} = \&$_ foreach @EXPORT;
415 |  |  |  |  | }
416 |  |  |  |  |
417 | 1 | 56µs |  |  | 1;
418 |  |  |  |  |
419 |  |  |  |  | __END__