Profile of /usr/local/lib/perl5/5.10.1/Carp/Heavy.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For 01.HTTP.t
Run on Tue May 4 15:25:55 2010
Reported on Tue May 4 15:26:09 2010

File | /usr/local/lib/perl5/5.10.1/Carp/Heavy.pm
Statements Executed | 20
Statement Execution Time | 9.85ms

Subroutines — ordered by exclusive time
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 13µs | 45µs | Carp::::BEGIN@11Carp::BEGIN@11
1 | 1 | 1 | 11µs | 23µs | Carp::::BEGIN@300Carp::BEGIN@300
1 | 1 | 1 | 7µs | 15µs | Carp::::BEGIN@301Carp::BEGIN@301
0 | 0 | 0 | 0s | 0s | Carp::::caller_infoCarp::caller_info
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::::longmess_heavyCarp::longmess_heavy
0 | 0 | 0 | 0s | 0s | Carp::::longmess_realCarp::longmess_real
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::::shortmess_heavyCarp::shortmess_heavy
0 | 0 | 0 | 0s | 0s | Carp::::shortmess_realCarp::shortmess_real
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 |  |  |  |  | # Carp::Heavy uses some variables in common with Carp.
2 |  |  |  |  | package Carp;
3 |  |  |  |  |
4 |  |  |  |  | =head1 NAME
5 |  |  |  |  |
6 |  |  |  |  | Carp::Heavy - heavy machinery, no user serviceable parts inside
7 |  |  |  |  |
8 |  |  |  |  | =cut
9 |  |  |  |  |
10 |  |  |  |  | # On one line so MakeMaker will see it.
11 | 4 | 990µs | 2 | 78µs | # spent 45µs (13+32) within Carp::BEGIN@11 which was called # once (13µs+32µs) by Moose::Error::Default::BEGIN@10 at line 11 use Carp; our $VERSION = $Carp::VERSION; # spent 45µs making 1 call to Carp::BEGIN@11 # spent 32µs making 1 call to Exporter::import
12 |  |  |  |  | # use strict; # not yet
13 |  |  |  |  |
14 |  |  |  |  | # 'use Carp' just installs some very lightweight stubs; the first time
15 |  |  |  |  | # these are called, they require Carp::Heavy which installs the real
16 |  |  |  |  | # routines.
17 |  |  |  |  |
18 |  |  |  |  | # The members of %Internal are packages that are internal to perl.
19 |  |  |  |  | # Carp will not report errors from within these packages if it
20 |  |  |  |  | # can. The members of %CarpInternal are internal to Perl's warning
21 |  |  |  |  | # system. Carp will not report errors from within these packages
22 |  |  |  |  | # either, and will not report calls *to* these packages for carp and
23 |  |  |  |  | # croak. They replace $CarpLevel, which is deprecated. The
24 |  |  |  |  | # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
25 |  |  |  |  | # text and function arguments should be formatted when printed.
26 |  |  |  |  |
27 |  |  |  |  | # disable these by default, so they can live w/o require Carp
28 | 1 | 2µs |  |  | $CarpInternal{Carp}++;
29 | 1 | 200ns |  |  | $CarpInternal{warnings}++;
30 | 1 | 800ns |  |  | $Internal{Exporter}++;
31 | 1 | 400ns |  |  | $Internal{'Exporter::Heavy'}++;
32 |  |  |  |  |
33 |  |  |  |  |
34 | 1 | 400ns |  |  | our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
35 |  |  |  |  |
36 |  |  |  |  | # XXX longmess_real and shortmess_real should really be merged into
37 |  |  |  |  | # XXX {long|sort}mess_heavy at some point
38 |  |  |  |  |
39 |  |  |  |  | sub longmess_real {
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 = 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 |  |  |  |  |
56 |  |  |  |  | sub shortmess_real {
57 |  |  |  |  | # Icky backwards compatibility wrapper. :-(
58 |  |  |  |  | local @CARP_NOT = caller();
59 |  |  |  |  | shortmess_heavy(@_);
60 |  |  |  |  | };
61 |  |  |  |  |
62 |  |  |  |  | # replace the two hooks added by Carp
63 |  |  |  |  |
64 |  |  |  |  | # aliasing the whole glob rather than just the CV slot avoids 'redefined'
65 |  |  |  |  | # warnings, even in the presence of perl -W (as used by lib/warnings.t !)
66 |  |  |  |  | # However it has the potential to create infinite loops, if somehow Carp
67 |  |  |  |  | # is forcibly reloaded, but $INC{"Carp/Heavy.pm"} remains true.
68 |  |  |  |  | # Hence the extra hack of deleting the previous typeglob first.
69 |  |  |  |  |
70 | 1 | 2µs |  |  | delete $Carp::{shortmess_jmp};
71 | 1 | 300ns |  |  | delete $Carp::{longmess_jmp};
72 | 1 | 11µs |  |  | *longmess_jmp = *longmess_real;
73 | 1 | 10µs |  |  | *shortmess_jmp = *shortmess_real;
74 |  |  |  |  |
75 |  |  |  |  |
76 |  |  |  |  | sub caller_info {
77 |  |  |  |  | my $i = shift(@_) + 1;
78 |  |  |  |  | package DB;
79 |  |  |  |  | my %call_info;
80 |  |  |  |  | @call_info{
81 |  |  |  |  | qw(pack file line sub has_args wantarray evaltext is_require)
82 |  |  |  |  | } = caller($i);
83 |  |  |  |  |
84 |  |  |  |  | unless (defined $call_info{pack}) {
85 |  |  |  |  | return ();
86 |  |  |  |  | }
87 |  |  |  |  |
88 |  |  |  |  | my $sub_name = Carp::get_subname(\%call_info);
89 |  |  |  |  | if ($call_info{has_args}) {
90 |  |  |  |  | my @args = map {Carp::format_arg($_)} @DB::args;
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.
103 |  |  |  |  | sub 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.
130 |  |  |  |  | sub 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
139 |  |  |  |  | sub 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.
157 |  |  |  |  | sub long_error_loc {
158 |  |  |  |  | my $i;
159 |  |  |  |  | my $lvl = $CarpLevel;
160 |  |  |  |  | {
161 |  |  |  |  | my $pkg = caller(++$i);
162 |  |  |  |  | unless(defined($pkg)) {
163 |  |  |  |  | # This *shouldn't* happen.
164 |  |  |  |  | if (%Internal) {
165 |  |  |  |  | local %Internal;
166 |  |  |  |  | $i = long_error_loc();
167 |  |  |  |  | last;
168 |  |  |  |  | }
169 |  |  |  |  | else {
170 |  |  |  |  | # OK, now I am irritated.
171 |  |  |  |  | return 2;
172 |  |  |  |  | }
173 |  |  |  |  | }
174 |  |  |  |  | redo if $CarpInternal{$pkg};
175 |  |  |  |  | redo unless 0 > --$lvl;
176 |  |  |  |  | redo if $Internal{$pkg};
177 |  |  |  |  | }
178 |  |  |  |  | return $i - 1;
179 |  |  |  |  | }
180 |  |  |  |  |
181 |  |  |  |  |
182 |  |  |  |  | sub longmess_heavy {
183 |  |  |  |  | return @_ if ref($_[0]); # don't break references as exceptions
184 |  |  |  |  | my $i = long_error_loc();
185 |  |  |  |  | return ret_backtrace($i, @_);
186 |  |  |  |  | }
187 |  |  |  |  |
188 |  |  |  |  | # Returns a full stack backtrace starting from where it is
189 |  |  |  |  | # told.
190 |  |  |  |  | sub ret_backtrace {
191 |  |  |  |  | my ($i, @error) = @_;
192 |  |  |  |  | my $mess;
193 |  |  |  |  | my $err = join '', @error;
194 |  |  |  |  | $i++;
195 |  |  |  |  |
196 |  |  |  |  | my $tid_msg = '';
197 |  |  |  |  | if (defined &threads::tid) {
198 |  |  |  |  | my $tid = threads->tid;
199 |  |  |  |  | $tid_msg = " thread $tid" if $tid;
200 |  |  |  |  | }
201 |  |  |  |  |
202 |  |  |  |  | my %i = caller_info($i);
203 |  |  |  |  | $mess = "$err at $i{file} line $i{line}$tid_msg\n";
204 |  |  |  |  |
205 |  |  |  |  | while (my %i = caller_info(++$i)) {
206 |  |  |  |  | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
207 |  |  |  |  | }
208 |  |  |  |  |
209 |  |  |  |  | return $mess;
210 |  |  |  |  | }
211 |  |  |  |  |
212 |  |  |  |  | sub ret_summary {
213 |  |  |  |  | my ($i, @error) = @_;
214 |  |  |  |  | my $err = join '', @error;
215 |  |  |  |  | $i++;
216 |  |  |  |  |
217 |  |  |  |  | my $tid_msg = '';
218 |  |  |  |  | if (defined &threads::tid) {
219 |  |  |  |  | my $tid = threads->tid;
220 |  |  |  |  | $tid_msg = " thread $tid" if $tid;
221 |  |  |  |  | }
222 |  |  |  |  |
223 |  |  |  |  | my %i = caller_info($i);
224 |  |  |  |  | return "$err at $i{file} line $i{line}$tid_msg\n";
225 |  |  |  |  | }
226 |  |  |  |  |
227 |  |  |  |  |
228 |  |  |  |  | sub short_error_loc {
229 |  |  |  |  | # You have to create your (hash)ref out here, rather than defaulting it
230 |  |  |  |  | # inside trusts *on a lexical*, as you want it to persist across calls.
231 |  |  |  |  | # (You can default it on $_[2], but that gets messy)
232 |  |  |  |  | my $cache = {};
233 |  |  |  |  | my $i = 1;
234 |  |  |  |  | my $lvl = $CarpLevel;
235 |  |  |  |  | {
236 |  |  |  |  | my $called = caller($i++);
237 |  |  |  |  | my $caller = caller($i);
238 |  |  |  |  |
239 |  |  |  |  | return 0 unless defined($caller); # What happened?
240 |  |  |  |  | redo if $Internal{$caller};
241 |  |  |  |  | redo if $CarpInternal{$caller};
242 |  |  |  |  | redo if $CarpInternal{$called};
243 |  |  |  |  | redo if trusts($called, $caller, $cache);
244 |  |  |  |  | redo if trusts($caller, $called, $cache);
245 |  |  |  |  | redo unless 0 > --$lvl;
246 |  |  |  |  | }
247 |  |  |  |  | return $i - 1;
248 |  |  |  |  | }
249 |  |  |  |  |
250 |  |  |  |  |
251 |  |  |  |  | sub shortmess_heavy {
252 |  |  |  |  | return longmess_heavy(@_) if $Verbose;
253 |  |  |  |  | return @_ if ref($_[0]); # don't break references as exceptions
254 |  |  |  |  | my $i = short_error_loc();
255 |  |  |  |  | if ($i) {
256 |  |  |  |  | ret_summary($i, @_);
257 |  |  |  |  | }
258 |  |  |  |  | else {
259 |  |  |  |  | longmess_heavy(@_);
260 |  |  |  |  | }
261 |  |  |  |  | }
262 |  |  |  |  |
263 |  |  |  |  | # If a string is too long, trims it with ...
264 |  |  |  |  | sub str_len_trim {
265 |  |  |  |  | my $str = shift;
266 |  |  |  |  | my $max = shift || 0;
267 |  |  |  |  | if (2 < $max and $max < length($str)) {
268 |  |  |  |  | substr($str, $max - 3) = '...';
269 |  |  |  |  | }
270 |  |  |  |  | return $str;
271 |  |  |  |  | }
272 |  |  |  |  |
273 |  |  |  |  | # Takes two packages and an optional cache. Says whether the
274 |  |  |  |  | # first inherits from the second.
275 |  |  |  |  | #
276 |  |  |  |  | # Recursive versions of this have to work to avoid certain
277 |  |  |  |  | # possible endless loops, and when following long chains of
278 |  |  |  |  | # inheritance are less efficient.
279 |  |  |  |  | sub trusts {
280 |  |  |  |  | my $child = shift;
281 |  |  |  |  | my $parent = shift;
282 |  |  |  |  | my $cache = shift;
283 |  |  |  |  | my ($known, $partial) = get_status($cache, $child);
284 |  |  |  |  | # Figure out consequences until we have an answer
285 |  |  |  |  | while (@$partial and not exists $known->{$parent}) {
286 |  |  |  |  | my $anc = shift @$partial;
287 |  |  |  |  | next if exists $known->{$anc};
288 |  |  |  |  | $known->{$anc}++;
289 |  |  |  |  | my ($anc_knows, $anc_partial) = get_status($cache, $anc);
290 |  |  |  |  | my @found = keys %$anc_knows;
291 |  |  |  |  | @$known{@found} = ();
292 |  |  |  |  | push @$partial, @$anc_partial;
293 |  |  |  |  | }
294 |  |  |  |  | return exists $known->{$parent};
295 |  |  |  |  | }
296 |  |  |  |  |
297 |  |  |  |  | # Takes a package and gives a list of those trusted directly
298 |  |  |  |  | sub trusts_directly {
299 |  |  |  |  | my $class = shift;
300 | 3 | 23µs | 2 | 35µs | # spent 23µs (11+12) within Carp::BEGIN@300 which was called # once (11µs+12µs) by Moose::Error::Default::BEGIN@10 at line 300 no strict 'refs'; # spent 23µs making 1 call to Carp::BEGIN@300 # spent 12µs making 1 call to strict::unimport
301 | 3 | 8.80ms | 2 | 23µs | # spent 15µs (7+8) within Carp::BEGIN@301 which was called # once (7µs+8µs) by Moose::Error::Default::BEGIN@10 at line 301 no warnings 'once'; # spent 15µs making 1 call to Carp::BEGIN@301 # spent 8µs making 1 call to warnings::unimport
302 |  |  |  |  | return @{"$class\::CARP_NOT"}
303 |  |  |  |  | ? @{"$class\::CARP_NOT"}
304 |  |  |  |  | : @{"$class\::ISA"};
305 |  |  |  |  | }
306 |  |  |  |  |
307 | 1 | 16µs |  |  | 1;
308 |  |  |  |  |