← Index
NYTProf Performance Profile   « block view • line view • sub view »
For bin/hailo
  Run on Thu Oct 21 22:50:37 2010
Reported on Thu Oct 21 22:52:07 2010

Filename/home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/5.13.5/Carp.pm
StatementsExecuted 66 statements in 271µs
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11165µs138µsCarp::::short_error_locCarp::short_error_loc
11148µs81µsCarp::::BEGIN@313Carp::BEGIN@313
22128µs73µsCarp::::trustsCarp::trusts
21127µs45µsCarp::::get_statusCarp::get_status
21118µs18µsCarp::::trusts_directlyCarp::trusts_directly
11113µs38µsCarp::::BEGIN@314Carp::BEGIN@314
0000s0sCarp::::caller_infoCarp::caller_info
0000s0sCarp::::carpCarp::carp
0000s0sCarp::::cluckCarp::cluck
0000s0sCarp::::confessCarp::confess
0000s0sCarp::::croakCarp::croak
0000s0sCarp::::export_failCarp::export_fail
0000s0sCarp::::format_argCarp::format_arg
0000s0sCarp::::get_subnameCarp::get_subname
0000s0sCarp::::long_error_locCarp::long_error_loc
0000s0sCarp::::longmessCarp::longmess
0000s0sCarp::::longmess_heavyCarp::longmess_heavy
0000s0sCarp::::ret_backtraceCarp::ret_backtrace
0000s0sCarp::::ret_summaryCarp::ret_summary
0000s0sCarp::::shortmessCarp::shortmess
0000s0sCarp::::shortmess_heavyCarp::shortmess_heavy
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
1package Carp;
2
312µsour $VERSION = '1.18';
4
511µsour $MaxEvalLen = 0;
611µsour $Verbose = 0;
711µsour $CarpLevel = 0;
811µsour $MaxArgLen = 64; # How much of each argument to print. 0 = all.
911µsour $MaxArgNums = 8; # How many arguments to print. 0 = all.
10
1112µsrequire Exporter;
1218µsour @ISA = ('Exporter');
1312µsour @EXPORT = qw(confess croak carp);
1412µsour @EXPORT_OK = qw(cluck verbose longmess shortmess);
1511µsour @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
16
17# The members of %Internal are packages that are internal to perl.
18# Carp will not report errors from within these packages if it
19# can. The members of %CarpInternal are internal to Perl's warning
20# system. Carp will not report errors from within these packages
21# either, and will not report calls *to* these packages for carp and
22# croak. They replace $CarpLevel, which is deprecated. The
23# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
24# text and function arguments should be formatted when printed.
25
26# disable these by default, so they can live w/o require Carp
2712µs$CarpInternal{Carp}++;
281900ns$CarpInternal{warnings}++;
2911µs$Internal{Exporter}++;
3011µs$Internal{'Exporter::Heavy'}++;
31
32# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
33# then the following method will be called by the Exporter which knows
34# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
35# 'verbose'.
36
37sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
38
39sub longmess {
40 # Icky backwards compatibility wrapper. :-(
41 #
42 # The story is that the original implementation hard-coded the
43 # number of call levels to go back, so calls to longmess were off
44 # by one. Other code began calling longmess and expecting this
45 # behaviour, so the replacement has to emulate that behaviour.
46 my $call_pack = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}() : caller();
47 if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
48 return longmess_heavy(@_);
49 }
50 else {
51 local $CarpLevel = $CarpLevel + 1;
52 return longmess_heavy(@_);
53 }
54};
55
56sub shortmess {
57 # Icky backwards compatibility wrapper. :-(
58 local @CARP_NOT = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}() : caller();
59 shortmess_heavy(@_);
60};
61
62sub croak { die shortmess @_ }
63sub confess { die longmess @_ }
64sub carp { warn shortmess @_ }
65sub cluck { warn longmess @_ }
66
67sub caller_info {
68 my $i = shift(@_) + 1;
69 my %call_info;
70 {
71 package DB;
72
- -
78 unless (defined $call_info{pack}) {
79 return ();
80 }
81
82 my $sub_name = Carp::get_subname(\%call_info);
83 if ($call_info{has_args}) {
84 my @args;
85 if (@DB::args == 1 && ref $DB::args[0] eq ref \$i && $DB::args[0] == \$i) {
86 @DB::args = (); # Don't let anyone see the address of $i
87 local $@;
88 my $where = eval {
89 my $gv = B::svref_2object(\&CORE::GLOBAL::caller)->GV;
90 my $package = $gv->STASH->NAME;
91 my $subname = $gv->NAME;
92 return unless defined $package && defined $subname;
93 # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
94 return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
95 " in &${package}::$subname";
96 } // '';
97 @args = "** Incomplete caller override detected$where; \@DB::args were not set **";
98 } else {
99 @args = map {Carp::format_arg($_)} @DB::args;
100 }
101 if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
102 $#args = $MaxArgNums;
103 push @args, '...';
104 }
105 # Push the args onto the subroutine
106 $sub_name .= '(' . join (', ', @args) . ')';
107 }
108 $call_info{sub_name} = $sub_name;
109 return wantarray() ? %call_info : \%call_info;
110}
111
112# Transform an argument to a function into a string.
113sub format_arg {
114 my $arg = shift;
115 if (ref($arg)) {
116 $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
117 }
118 if (defined($arg)) {
119 $arg =~ s/'/\\'/g;
120 $arg = str_len_trim($arg, $MaxArgLen);
121
122 # Quote it?
123 $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
124 } else {
125 $arg = 'undef';
126 }
127
128 # The following handling of "control chars" is direct from
129 # the original code - it is broken on Unicode though.
130 # Suggestions?
131 utf8::is_utf8($arg)
132 or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
133 return $arg;
134}
135
136# Takes an inheritance cache and a package and returns
137# an anon hash of known inheritances and anon array of
138# inheritances which consequences have not been figured
139# for.
140
# spent 45µs (27+18) within Carp::get_status which was called 2 times, avg 22µs/call: # 2 times (27µs+18µs) by Carp::trusts at line 296, avg 22µs/call
sub get_status {
141824µs my $cache = shift;
142 my $pkg = shift;
143218µs $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
# spent 18µs making 2 calls to Carp::trusts_directly, avg 9µs/call
144 return @{$cache->{$pkg}};
145}
146
147# Takes the info from caller() and figures out the name of
148# the sub/require/eval
149sub get_subname {
150 my $info = shift;
151 if (defined($info->{evaltext})) {
152 my $eval = $info->{evaltext};
153 if ($info->{is_require}) {
154 return "require $eval";
155 }
156 else {
157 $eval =~ s/([\\\'])/\\$1/g;
158 return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
159 }
160 }
161
162 return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
163}
164
165# Figures out what call (from the point of view of the caller)
166# the long error backtrace should start at.
167sub long_error_loc {
168 my $i;
169 my $lvl = $CarpLevel;
170 {
171 ++$i;
172 my $pkg = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
173 unless(defined($pkg)) {
174 # This *shouldn't* happen.
175 if (%Internal) {
176 local %Internal;
177 $i = long_error_loc();
178 last;
179 }
180 else {
181 # OK, now I am irritated.
182 return 2;
183 }
184 }
185 redo if $CarpInternal{$pkg};
186 redo unless 0 > --$lvl;
187 redo if $Internal{$pkg};
188 }
189 return $i - 1;
190}
191
192
193sub longmess_heavy {
194 return @_ if ref($_[0]); # don't break references as exceptions
195 my $i = long_error_loc();
196 return ret_backtrace($i, @_);
197}
198
199# Returns a full stack backtrace starting from where it is
200# told.
201sub ret_backtrace {
202 my ($i, @error) = @_;
203 my $mess;
204 my $err = join '', @error;
205 $i++;
206
207 my $tid_msg = '';
208 if (defined &threads::tid) {
209 my $tid = threads->tid;
210 $tid_msg = " thread $tid" if $tid;
211 }
212
213 my %i = caller_info($i);
214 $mess = "$err at $i{file} line $i{line}$tid_msg\n";
215
216 while (my %i = caller_info(++$i)) {
217 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
218 }
219
220 return $mess;
221}
222
223sub ret_summary {
224 my ($i, @error) = @_;
225 my $err = join '', @error;
226 $i++;
227
228 my $tid_msg = '';
229 if (defined &threads::tid) {
230 my $tid = threads->tid;
231 $tid_msg = " thread $tid" if $tid;
232 }
233
234 my %i = caller_info($i);
235 return "$err at $i{file} line $i{line}$tid_msg\n";
236}
237
238
239
# spent 138µs (65+73) within Carp::short_error_loc which was called: # once (65µs+73µs) by warnings::__chk at line 527 of warnings.pm
sub short_error_loc {
240 # You have to create your (hash)ref out here, rather than defaulting it
241 # inside trusts *on a lexical*, as you want it to persist across calls.
242 # (You can default it on $_[2], but that gets messy)
243513µs my $cache = {};
244 my $i = 1;
245 my $lvl = $CarpLevel;
246 {
247
2481733µs my $called = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
249 $i++;
250 my $caller = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
251
252 return 0 unless defined($caller); # What happened?
253 redo if $Internal{$caller};
254 redo if $CarpInternal{$caller};
255 redo if $CarpInternal{$called};
256142µs redo if trusts($called, $caller, $cache);
# spent 42µs making 1 call to Carp::trusts
257131µs redo if trusts($caller, $called, $cache);
# spent 31µs making 1 call to Carp::trusts
258 redo unless 0 > --$lvl;
259 }
260 return $i - 1;
261}
262
263
264sub shortmess_heavy {
265 return longmess_heavy(@_) if $Verbose;
266 return @_ if ref($_[0]); # don't break references as exceptions
267 my $i = short_error_loc();
268 if ($i) {
269 ret_summary($i, @_);
270 }
271 else {
272 longmess_heavy(@_);
273 }
274}
275
276# If a string is too long, trims it with ...
277sub str_len_trim {
278 my $str = shift;
279 my $max = shift || 0;
280 if (2 < $max and $max < length($str)) {
281 substr($str, $max - 3) = '...';
282 }
283 return $str;
284}
285
286# Takes two packages and an optional cache. Says whether the
287# first inherits from the second.
288#
289# Recursive versions of this have to work to avoid certain
290# possible endless loops, and when following long chains of
291# inheritance are less efficient.
292
# spent 73µs (28+45) within Carp::trusts which was called 2 times, avg 37µs/call: # once (16µs+26µs) by Carp::short_error_loc at line 256 # once (12µs+19µs) by Carp::short_error_loc at line 257
sub trusts {
2931248µs my $child = shift;
294 my $parent = shift;
295 my $cache = shift;
296245µs my ($known, $partial) = get_status($cache, $child);
# spent 45µs making 2 calls to Carp::get_status, avg 22µs/call
297 # Figure out consequences until we have an answer
298 while (@$partial and not exists $known->{$parent}) {
299 my $anc = shift @$partial;
300 next if exists $known->{$anc};
301 $known->{$anc}++;
302 my ($anc_knows, $anc_partial) = get_status($cache, $anc);
303 my @found = keys %$anc_knows;
304 @$known{@found} = ();
305 push @$partial, @$anc_partial;
306 }
307 return exists $known->{$parent};
308}
309
310# Takes a package and gives a list of those trusted directly
311
# spent 18µs within Carp::trusts_directly which was called 2 times, avg 9µs/call: # 2 times (18µs+0s) by Carp::get_status at line 143, avg 9µs/call
sub trusts_directly {
312422µs my $class = shift;
313233µs2114µs
# spent 81µs (48+33) within Carp::BEGIN@313 which was called: # once (48µs+33µs) by Mouse::Exporter::BEGIN@5 at line 313
no strict 'refs';
# spent 81µs making 1 call to Carp::BEGIN@313 # spent 33µs making 1 call to strict::unimport
314264µs263µs
# spent 38µs (13+25) within Carp::BEGIN@314 which was called: # once (13µs+25µs) by Mouse::Exporter::BEGIN@5 at line 314
no warnings 'once';
# spent 38µs making 1 call to Carp::BEGIN@314 # spent 25µs making 1 call to warnings::unimport
315 return @{"$class\::CARP_NOT"}
316 ? @{"$class\::CARP_NOT"}
317 : @{"$class\::ISA"};
318}
319
32019µs1;
321
322__END__