← Index
NYTProf Performance Profile   « block view • line view • sub view »
For lexer.pl
  Run on Thu Mar 22 18:01:49 2012
Reported on Thu Mar 22 18:02:03 2012

Filename/System/Library/Perl/5.12/Carp.pm
StatementsExecuted 22 statements in 1.21ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11122µs50µsCarp::::BEGIN@303Carp::BEGIN@303
11112µs26µsCarp::::BEGIN@304Carp::BEGIN@304
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_statusCarp::get_status
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::::short_error_locCarp::short_error_loc
0000s0sCarp::::shortmessCarp::shortmess
0000s0sCarp::::shortmess_heavyCarp::shortmess_heavy
0000s0sCarp::::str_len_trimCarp::str_len_trim
0000s0sCarp::::trustsCarp::trusts
0000s0sCarp::::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
1package Carp;
2
31900nsour $VERSION = '1.17';
4
51200nsour $MaxEvalLen = 0;
61200nsour $Verbose = 0;
71200nsour $CarpLevel = 0;
81100nsour $MaxArgLen = 64; # How much of each argument to print. 0 = all.
91200nsour $MaxArgNums = 8; # How many arguments to print. 0 = all.
10
1111.02msrequire Exporter;
12112µsour @ISA = ('Exporter');
1311µsour @EXPORT = qw(confess croak carp);
1411µsour @EXPORT_OK = qw(cluck verbose longmess shortmess);
151600nsour @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}++;
281300ns$CarpInternal{warnings}++;
291500ns$Internal{Exporter}++;
301300ns$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 @args = "** Incomplete caller override detected; \@DB::args were not set **";
88 } else {
89 @args = map {Carp::format_arg($_)} @DB::args;
90 }
91 if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
92 $#args = $MaxArgNums;
93 push @args, '...';
94 }
95 # Push the args onto the subroutine
96 $sub_name .= '(' . join (', ', @args) . ')';
97 }
98 $call_info{sub_name} = $sub_name;
99 return wantarray() ? %call_info : \%call_info;
100}
101
102# Transform an argument to a function into a string.
103sub format_arg {
104 my $arg = shift;
105 if (ref($arg)) {
106 $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
107 }
108 if (defined($arg)) {
109 $arg =~ s/'/\\'/g;
110 $arg = str_len_trim($arg, $MaxArgLen);
111
112 # Quote it?
113 $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
114 } else {
115 $arg = 'undef';
116 }
117
118 # The following handling of "control chars" is direct from
119 # the original code - it is broken on Unicode though.
120 # Suggestions?
121 utf8::is_utf8($arg)
122 or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
123 return $arg;
124}
125
126# Takes an inheritance cache and a package and returns
127# an anon hash of known inheritances and anon array of
128# inheritances which consequences have not been figured
129# for.
130sub get_status {
131 my $cache = shift;
132 my $pkg = shift;
133 $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
134 return @{$cache->{$pkg}};
135}
136
137# Takes the info from caller() and figures out the name of
138# the sub/require/eval
139sub get_subname {
140 my $info = shift;
141 if (defined($info->{evaltext})) {
142 my $eval = $info->{evaltext};
143 if ($info->{is_require}) {
144 return "require $eval";
145 }
146 else {
147 $eval =~ s/([\\\'])/\\$1/g;
148 return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
149 }
150 }
151
152 return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
153}
154
155# Figures out what call (from the point of view of the caller)
156# the long error backtrace should start at.
157sub long_error_loc {
158 my $i;
159 my $lvl = $CarpLevel;
160 {
161 ++$i;
162 my $pkg = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
163 unless(defined($pkg)) {
164 # This *shouldn't* happen.
165 if (%Internal) {
166 local %Internal;
167 $i = long_error_loc();
168 last;
169 }
170 else {
171 # OK, now I am irritated.
172 return 2;
173 }
174 }
175 redo if $CarpInternal{$pkg};
176 redo unless 0 > --$lvl;
177 redo if $Internal{$pkg};
178 }
179 return $i - 1;
180}
181
182
183sub longmess_heavy {
184 return @_ if ref($_[0]); # don't break references as exceptions
185 my $i = long_error_loc();
186 return ret_backtrace($i, @_);
187}
188
189# Returns a full stack backtrace starting from where it is
190# told.
191sub ret_backtrace {
192 my ($i, @error) = @_;
193 my $mess;
194 my $err = join '', @error;
195 $i++;
196
197 my $tid_msg = '';
198 if (defined &threads::tid) {
199 my $tid = threads->tid;
200 $tid_msg = " thread $tid" if $tid;
201 }
202
203 my %i = caller_info($i);
204 $mess = "$err at $i{file} line $i{line}$tid_msg\n";
205
206 while (my %i = caller_info(++$i)) {
207 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
208 }
209
210 return $mess;
211}
212
213sub ret_summary {
214 my ($i, @error) = @_;
215 my $err = join '', @error;
216 $i++;
217
218 my $tid_msg = '';
219 if (defined &threads::tid) {
220 my $tid = threads->tid;
221 $tid_msg = " thread $tid" if $tid;
222 }
223
224 my %i = caller_info($i);
225 return "$err at $i{file} line $i{line}$tid_msg\n";
226}
227
228
229sub short_error_loc {
230 # You have to create your (hash)ref out here, rather than defaulting it
231 # inside trusts *on a lexical*, as you want it to persist across calls.
232 # (You can default it on $_[2], but that gets messy)
233 my $cache = {};
234 my $i = 1;
235 my $lvl = $CarpLevel;
236 {
237
238 my $called = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
239 $i++;
240 my $caller = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
241
242 return 0 unless defined($caller); # What happened?
243 redo if $Internal{$caller};
244 redo if $CarpInternal{$caller};
245 redo if $CarpInternal{$called};
246 redo if trusts($called, $caller, $cache);
247 redo if trusts($caller, $called, $cache);
248 redo unless 0 > --$lvl;
249 }
250 return $i - 1;
251}
252
253
254sub shortmess_heavy {
255 return longmess_heavy(@_) if $Verbose;
256 return @_ if ref($_[0]); # don't break references as exceptions
257 my $i = short_error_loc();
258 if ($i) {
259 ret_summary($i, @_);
260 }
261 else {
262 longmess_heavy(@_);
263 }
264}
265
266# If a string is too long, trims it with ...
267sub str_len_trim {
268 my $str = shift;
269 my $max = shift || 0;
270 if (2 < $max and $max < length($str)) {
271 substr($str, $max - 3) = '...';
272 }
273 return $str;
274}
275
276# Takes two packages and an optional cache. Says whether the
277# first inherits from the second.
278#
279# Recursive versions of this have to work to avoid certain
280# possible endless loops, and when following long chains of
281# inheritance are less efficient.
282sub trusts {
283 my $child = shift;
284 my $parent = shift;
285 my $cache = shift;
286 my ($known, $partial) = get_status($cache, $child);
287 # Figure out consequences until we have an answer
288 while (@$partial and not exists $known->{$parent}) {
289 my $anc = shift @$partial;
290 next if exists $known->{$anc};
291 $known->{$anc}++;
292 my ($anc_knows, $anc_partial) = get_status($cache, $anc);
293 my @found = keys %$anc_knows;
294 @$known{@found} = ();
295 push @$partial, @$anc_partial;
296 }
297 return exists $known->{$parent};
298}
299
300# Takes a package and gives a list of those trusted directly
301sub trusts_directly {
302 my $class = shift;
303344µs278µs
# spent 50µs (22+28) within Carp::BEGIN@303 which was called: # once (22µs+28µs) by Data::Dumper::BEGIN@20 at line 303
no strict 'refs';
# spent 50µs making 1 call to Carp::BEGIN@303 # spent 28µs making 1 call to strict::unimport
3043105µs240µs
# spent 26µs (12+14) within Carp::BEGIN@304 which was called: # once (12µs+14µs) by Data::Dumper::BEGIN@20 at line 304
no warnings 'once';
# spent 26µs making 1 call to Carp::BEGIN@304 # spent 14µs making 1 call to warnings::unimport
305 return @{"$class\::CARP_NOT"}
306 ? @{"$class\::CARP_NOT"}
307 : @{"$class\::ISA"};
308}
309
310124µs1;
311
312__END__
Report produced by the NYTProf 4.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.