Profile of /usr/local/lib/perl5/site_perl/5.10.1/Carp/Clan.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For 05.Domain_and_Item.t
Run on Tue May 4 17:21:41 2010
Reported on Tue May 4 17:23:07 2010

File | /usr/local/lib/perl5/site_perl/5.10.1/Carp/Clan.pm
Statements Executed | 91
Statement Execution Time | 1.55ms

Subroutines — ordered by exclusive time
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
4 | 4 | 4 | 282µs | 349µs | Carp::Clan::::importCarp::Clan::import
4 | 4 | 5 | 43µs | 43µs | Carp::Clan::::CORE:regcompCarp::Clan::CORE:regcomp (opcode)
1 | 1 | 1 | 19µs | 22µs | Carp::Clan::::BEGIN@16Carp::Clan::BEGIN@16
4 | 4 | 5 | 15µs | 15µs | Carp::Clan::::CORE:qrCarp::Clan::CORE:qr (opcode)
1 | 1 | 1 | 12µs | 31µs | Carp::Clan::::BEGIN@224Carp::Clan::BEGIN@224
8 | 1 | 2 | 10µs | 10µs | Carp::Clan::::CORE:matchCarp::Clan::CORE:match (opcode)
1 | 1 | 1 | 7µs | 72µs | Carp::Clan::::BEGIN@17Carp::Clan::BEGIN@17
1 | 1 | 1 | 4µs | 4µs | Carp::Clan::::BEGIN@18Carp::Clan::BEGIN@18
0 | 0 | 0 | 0s | 0s | Carp::Clan::::__ANON__[:225]Carp::Clan::__ANON__[:225]
0 | 0 | 0 | 0s | 0s | Carp::Clan::::__ANON__[:226]Carp::Clan::__ANON__[:226]
0 | 0 | 0 | 0s | 0s | Carp::Clan::::__ANON__[:227]Carp::Clan::__ANON__[:227]
0 | 0 | 0 | 0s | 0s | Carp::Clan::::__ANON__[:228]Carp::Clan::__ANON__[:228]
0 | 0 | 0 | 0s | 0s | Carp::Clan::::_longmsgCarp::Clan::_longmsg
0 | 0 | 0 | 0s | 0s | Carp::Clan::::_shortmsgCarp::Clan::_shortmsg
0 | 0 | 0 | 0s | 0s | Carp::Clan::::carpCarp::Clan::carp
0 | 0 | 0 | 0s | 0s | Carp::Clan::::cluckCarp::Clan::cluck
0 | 0 | 0 | 0s | 0s | Carp::Clan::::confessCarp::Clan::confess
0 | 0 | 0 | 0s | 0s | Carp::Clan::::croakCarp::Clan::croak

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

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  |
2 |  |  |  |  | ##
3 |  |  |  |  | ## Based on Carp.pm from Perl 5.005_03.
4 |  |  |  |  | ## Last modified 24-Oct-2009 by Steffen Beyer.
5 |  |  |  |  | ## Should be reasonably backwards compatible.
6 |  |  |  |  | ##
7 |  |  |  |  | ## This module is free software and can
8 |  |  |  |  | ## be used, modified and redistributed
9 |  |  |  |  | ## under the same terms as Perl itself.
10 |  |  |  |  | ##
11 |  |  |  |  |
12 | 1 | 600ns |  |  | @DB::args = (); # Avoid warning "used only once" in Perl 5.003
13 |  |  |  |  |
14 |  |  |  |  | package Carp::Clan;
15 |  |  |  |  |
16 | 3 | 32µs | 2 | 25µs | # spent 22µs (19+3) within Carp::Clan::BEGIN@16 which was called # once (19µs+3µs) by MooseX::Types::TypeDecorator::BEGIN@7 at line 16 use strict; # spent 22µs making 1 call to Carp::Clan::BEGIN@16 # spent 3µs making 1 call to strict::import
17 | 3 | 23µs | 2 | 137µs | # spent 72µs (7+65) within Carp::Clan::BEGIN@17 which was called # once (7µs+65µs) by MooseX::Types::TypeDecorator::BEGIN@7 at line 17 use vars qw( $MaxEvalLen $MaxArgLen $MaxArgNums $Verbose $VERSION ); # spent 72µs making 1 call to Carp::Clan::BEGIN@17 # spent 65µs making 1 call to vars::import
18 | 3 | 940µs | 1 | 4µs | # spent 4µs within Carp::Clan::BEGIN@18 which was called # once (4µs+0s) by MooseX::Types::TypeDecorator::BEGIN@7 at line 18 use overload (); # spent 4µs making 1 call to Carp::Clan::BEGIN@18
19 |  |  |  |  |
20 |  |  |  |  | # Original comments by Andy Wardley <abw@kfs.org> 09-Apr-1998.
21 |  |  |  |  |
22 |  |  |  |  | # The $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how
23 |  |  |  |  | # the eval text and function arguments should be formatted when printed.
24 |  |  |  |  |
25 | 1 | 300ns |  |  | $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
26 | 1 | 100ns |  |  | $MaxArgLen = 64; # How much of each argument to print. 0 = all.
27 | 1 | 100ns |  |  | $MaxArgNums = 8; # How many arguments to print. 0 = all.
28 |  |  |  |  |
29 | 1 | 0s |  |  | $Verbose = 0; # If true then make _shortmsg call _longmsg instead.
30 |  |  |  |  |
31 | 1 | 400ns |  |  | $VERSION = '6.04';
32 |  |  |  |  |
33 |  |  |  |  | # _longmsg() crawls all the way up the stack reporting on all the function
34 |  |  |  |  | # calls made. The error string, $error, is originally constructed from the
35 |  |  |  |  | # arguments passed into _longmsg() via confess(), cluck() or _shortmsg().
36 |  |  |  |  | # This gets appended with the stack trace messages which are generated for
37 |  |  |  |  | # each function call on the stack.
38 |  |  |  |  |
39 |  |  |  |  | sub _longmsg {
40 |  |  |  |  | return (@_) if ( ref $_[0] );
41 |  |  |  |  | local $_; # Protect surrounding program - just in case...
42 |  |  |  |  | my ( $pack, $file, $line, $sub, $hargs, $eval, $require, @parms, $push );
43 |  |  |  |  | my $error = join( '', @_ );
44 |  |  |  |  | my $msg = '';
45 |  |  |  |  | my $i = 0;
46 |  |  |  |  | while (
47 |  |  |  |  | do {
48 |  |  |  |  | {
49 |  |  |  |  |
50 |  |  |  |  | package DB;
51 |  |  |  |  | ( $pack, $file, $line, $sub, $hargs, undef, $eval, $require )
52 |  |  |  |  | = caller( $i++ )
53 |  |  |  |  | }
54 |  |  |  |  | }
55 |  |  |  |  | )
56 |  |  |  |  | {
57 |  |  |  |  | next if ( $pack eq 'Carp::Clan' );
58 |  |  |  |  | if ( $error eq '' ) {
59 |  |  |  |  | if ( defined $eval ) {
60 |  |  |  |  | $eval =~ s/([\\\'])/\\$1/g unless ($require); # Escape \ and '
61 |  |  |  |  | $eval
62 |  |  |  |  | =~ s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
63 |  |  |  |  | substr( $eval, $MaxEvalLen ) = '...'
64 |  |  |  |  | if ( $MaxEvalLen && length($eval) > $MaxEvalLen );
65 |  |  |  |  | if ($require) { $sub = "require $eval"; }
66 |  |  |  |  | else { $sub = "eval '$eval'"; }
67 |  |  |  |  | }
68 |  |  |  |  | elsif ( $sub eq '(eval)' ) { $sub = 'eval {...}'; }
69 |  |  |  |  | else {
70 |  |  |  |  | @parms = ();
71 |  |  |  |  | if ($hargs) {
72 |  |  |  |  | $push = 0;
73 |  |  |  |  | @parms = @DB::args
74 |  |  |  |  | ; # We may trash some of the args so we take a copy
75 |  |  |  |  | if ( $MaxArgNums and @parms > $MaxArgNums ) {
76 |  |  |  |  | $#parms = $MaxArgNums;
77 |  |  |  |  | pop(@parms);
78 |  |  |  |  | $push = 1;
79 |  |  |  |  | }
80 |  |  |  |  | for (@parms) {
81 |  |  |  |  | if ( defined $_ ) {
82 |  |  |  |  | if ( ref $_ ) {
83 |  |  |  |  | $_ = overload::StrVal($_);
84 |  |  |  |  | }
85 |  |  |  |  | else {
86 |  |  |  |  | unless ( /^-?\d+(?:\.\d+(?:[eE][+-]\d+)?)?$/
87 |  |  |  |  | ) # Looks numeric
88 |  |  |  |  | {
89 |  |  |  |  | s/([\\\'])/\\$1/g; # Escape \ and '
90 |  |  |  |  | s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
91 |  |  |  |  | substr( $_, $MaxArgLen ) = '...'
92 |  |  |  |  | if ( $MaxArgLen
93 |  |  |  |  | and length($_) > $MaxArgLen );
94 |  |  |  |  | $_ = "'$_'";
95 |  |  |  |  | }
96 |  |  |  |  | }
97 |  |  |  |  | }
98 |  |  |  |  | else { $_ = 'undef'; }
99 |  |  |  |  | }
100 |  |  |  |  | push( @parms, '...' ) if ($push);
101 |  |  |  |  | }
102 |  |  |  |  | $sub .= '(' . join( ', ', @parms ) . ')';
103 |  |  |  |  | }
104 |  |  |  |  | if ( $msg eq '' ) { $msg = "$sub called"; }
105 |  |  |  |  | else { $msg .= "\t$sub called"; }
106 |  |  |  |  | }
107 |  |  |  |  | else {
108 |  |  |  |  | $msg = quotemeta($sub);
109 |  |  |  |  | if ( $error =~ /\b$msg\b/ ) { $msg = $error; }
110 |  |  |  |  | else {
111 |  |  |  |  | if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
112 |  |  |  |  | else { $msg = "$sub: $error"; }
113 |  |  |  |  | }
114 |  |  |  |  | }
115 |  |  |  |  | $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
116 |  |  |  |  | $error = '';
117 |  |  |  |  | }
118 |  |  |  |  | $msg ||= $error;
119 |  |  |  |  | $msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
120 |  |  |  |  | $msg;
121 |  |  |  |  | }
122 |  |  |  |  |
123 |  |  |  |  | # _shortmsg() is called by carp() and croak() to skip all the way up to
124 |  |  |  |  | # the top-level caller's package and report the error from there. confess()
125 |  |  |  |  | # and cluck() generate a full stack trace so they call _longmsg() to
126 |  |  |  |  | # generate that. In verbose mode _shortmsg() calls _longmsg() so you
127 |  |  |  |  | # always get a stack trace.
128 |  |  |  |  |
129 |  |  |  |  | sub _shortmsg {
130 |  |  |  |  | my $pattern = shift;
131 |  |  |  |  | my $verbose = shift;
132 |  |  |  |  | return (@_) if ( ref $_[0] );
133 |  |  |  |  | goto &_longmsg if ( $Verbose or $verbose );
134 |  |  |  |  | my ( $pack, $file, $line, $sub );
135 |  |  |  |  | my $error = join( '', @_ );
136 |  |  |  |  | my $msg = '';
137 |  |  |  |  | my $i = 0;
138 |  |  |  |  | while ( ( $pack, $file, $line, $sub ) = caller( $i++ ) ) {
139 |  |  |  |  | next if ( $pack eq 'Carp::Clan' or $pack =~ /$pattern/ );
140 |  |  |  |  | if ( $error eq '' ) { $msg = "$sub() called"; }
141 |  |  |  |  | else {
142 |  |  |  |  | $msg = quotemeta($sub);
143 |  |  |  |  | if ( $error =~ /\b$msg\b/ ) { $msg = $error; }
144 |  |  |  |  | else {
145 |  |  |  |  | if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
146 |  |  |  |  | else { $msg = "$sub: $error"; }
147 |  |  |  |  | }
148 |  |  |  |  | }
149 |  |  |  |  | $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
150 |  |  |  |  | $msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
151 |  |  |  |  | return $msg;
152 |  |  |  |  | }
153 |  |  |  |  | goto &_longmsg;
154 |  |  |  |  | }
155 |  |  |  |  |
156 |  |  |  |  | # In the two identical regular expressions (immediately after the two occurrences of
157 |  |  |  |  | # "quotemeta") above, the "\b ... \b" helps to avoid confusion between function names
158 |  |  |  |  | # which are prefixes of each other, e.g. "My::Class::print" and "My::Class::println".
159 |  |  |  |  |
160 |  |  |  |  | # The following four functions call _longmsg() or _shortmsg() depending on
161 |  |  |  |  | # whether they should generate a full stack trace (confess() and cluck())
162 |  |  |  |  | # or simply report the caller's package (croak() and carp()), respectively.
163 |  |  |  |  | # confess() and croak() die, carp() and cluck() warn.
164 |  |  |  |  |
165 |  |  |  |  | # Following code kept for calls with fully qualified subroutine names:
166 |  |  |  |  | # (For backward compatibility with the original Carp.pm)
167 |  |  |  |  |
168 |  |  |  |  | sub croak {
169 |  |  |  |  | my $callpkg = caller(0);
170 |  |  |  |  | my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
171 |  |  |  |  | die _shortmsg( $pattern, 0, @_ );
172 |  |  |  |  | }
173 |  |  |  |  | sub confess { die _longmsg(@_); }
174 |  |  |  |  |
175 |  |  |  |  | sub carp {
176 |  |  |  |  | my $callpkg = caller(0);
177 |  |  |  |  | my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
178 |  |  |  |  | warn _shortmsg( $pattern, 0, @_ );
179 |  |  |  |  | }
180 |  |  |  |  | sub cluck { warn _longmsg(@_); }
181 |  |  |  |  |
182 |  |  |  |  | # The following method imports a different closure for every caller.
183 |  |  |  |  | # I.e., different modules can use this module at the same time
184 |  |  |  |  | # and in parallel and still use different patterns.
185 |  |  |  |  |
186 |  |  |  |  | # spent 349µs (282+67) within Carp::Clan::import which was called 4 times, avg 87µs/call: # once (74µs+29µs) by MooseX::Types::UndefinedType::BEGIN@13 at line 13 of MooseX/Types/UndefinedType.pm # once (77µs+15µs) by MooseX::Types::Base::BEGIN@10 at line 10 of MooseX/Types/Base.pm # once (71µs+12µs) by MooseX::Types::TypeDecorator::BEGIN@7 at line 7 of MooseX/Types/TypeDecorator.pm # once (60µs+12µs) by MooseX::Types::BEGIN@16 at line 16 of MooseX/Types.pm sub import {
187 | 4 | 3µs |  |  | my $pkg = shift;
188 | 4 | 2µs |  |  | my $callpkg = caller(0);
189 | 4 | 5µs |  |  | my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
190 | 4 | 700ns |  |  | my $verbose = 0;
191 | 4 | 200ns |  |  | my $item;
192 | 4 | 400ns |  |  | my $file;
193 |  |  |  |  |
194 | 4 | 4µs |  |  | for $item (@_) {
195 | 4 | 35µs | 8 | 10µs | if ( $item =~ /^\d/ ) { # spent 10µs making 8 calls to Carp::Clan::CORE:match, avg 1µs/call
196 |  |  |  |  | if ( $VERSION < $item ) {
197 |  |  |  |  | $file = "$pkg.pm";
198 |  |  |  |  | $file =~ s!::!/!g;
199 |  |  |  |  | $file = $INC{$file};
200 |  |  |  |  | die _shortmsg( '^:::', 0,
201 |  |  |  |  | "$pkg $item required--this is only version $VERSION ($file)"
202 |  |  |  |  | );
203 |  |  |  |  | }
204 |  |  |  |  | }
205 |  |  |  |  | elsif ( $item =~ /^verbose$/i ) { $verbose = 1; }
206 | 4 | 2µs |  |  | else { $pattern = $item; }
207 |  |  |  |  | }
208 |  |  |  |  |
209 |  |  |  |  | # Speed up pattern matching in Perl versions >= 5.005:
210 |  |  |  |  | # (Uses "eval ''" because qr// is a syntax error in previous Perl versions)
211 | 4 | 6µs |  |  | if ( $] >= 5.005 ) {
212 | 4 | 194µs | 8 | 57µs | eval '$pattern = qr/$pattern/;'; # spent 43µs making 4 calls to Carp::Clan::CORE:regcomp, avg 11µs/call # spent 15µs making 4 calls to Carp::Clan::CORE:qr, avg 4µs/call
213 |  |  |  |  | }
214 |  |  |  |  | else {
215 |  |  |  |  | eval { $pkg =~ /$pattern/; };
216 |  |  |  |  | }
217 | 4 | 700ns |  |  | if ($@) {
218 |  |  |  |  | $@ =~ s/\s+$//;
219 |  |  |  |  | $@ =~ s/\s+at\s.+$//;
220 |  |  |  |  | die _shortmsg( '^:::', 0, $@ );
221 |  |  |  |  | }
222 |  |  |  |  | {
223 | 8 | 24µs |  |  | local ($^W) = 0;
224 | 3 | 199µs | 2 | 50µs | # spent 31µs (12+19) within Carp::Clan::BEGIN@224 which was called # once (12µs+19µs) by MooseX::Types::TypeDecorator::BEGIN@7 at line 224 no strict "refs"; # spent 31µs making 1 call to Carp::Clan::BEGIN@224 # spent 19µs making 1 call to strict::unimport
225 | 4 | 20µs |  |  | *{"${callpkg}::croak"} = sub { die _shortmsg( $pattern, $verbose, @_ ); };
226 | 4 | 21µs |  |  | *{"${callpkg}::confess"} = sub { die _longmsg ( @_ ); };
227 | 4 | 12µs |  |  | *{"${callpkg}::carp"} = sub { warn _shortmsg( $pattern, $verbose, @_ ); };
228 | 4 | 17µs |  |  | *{"${callpkg}::cluck"} = sub { warn _longmsg ( @_ ); };
229 |  |  |  |  | }
230 |  |  |  |  | }
231 |  |  |  |  |
232 | 1 | 8µs |  |  | 1;
233 |  |  |  |  |
|  |  |  |  | # spent 10µs within Carp::Clan::CORE:match which was called 8 times, avg 1µs/call: # 8 times (10µs+0s) by Carp::Clan::import at line 195 of Carp/Clan.pm, avg 1µs/call sub Carp::Clan::CORE:match; # xsub
|  |  |  |  | # spent 15µs within Carp::Clan::CORE:qr which was called 4 times, avg 4µs/call: # once (5µs+0s) by Carp::Clan::import at line 1 of (eval 0)[Carp/Clan.pm:212] at line 212 of Carp/Clan.pm # once (4µs+0s) by Carp::Clan::import at line 1 of (eval 0)[Carp/Clan.pm:212] at line 212 of Carp/Clan.pm # once (3µs+0s) by Carp::Clan::import at line 1 of (eval 0)[Carp/Clan.pm:212] at line 212 of Carp/Clan.pm # once (3µs+0s) by Carp::Clan::import at line 1 of (eval 0)[Carp/Clan.pm:212] at line 212 of Carp/Clan.pm sub Carp::Clan::CORE:qr; # xsub
|  |  |  |  | # spent 43µs within Carp::Clan::CORE:regcomp which was called 4 times, avg 11µs/call: # once (22µs+0s) by Carp::Clan::import at line 1 of (eval 0)[Carp/Clan.pm:212] at line 212 of Carp/Clan.pm # once (8µs+0s) by Carp::Clan::import at line 1 of (eval 0)[Carp/Clan.pm:212] at line 212 of Carp/Clan.pm # once (7µs+0s) by Carp::Clan::import at line 1 of (eval 0)[Carp/Clan.pm:212] at line 212 of Carp/Clan.pm # once (6µs+0s) by Carp::Clan::import at line 1 of (eval 0)[Carp/Clan.pm:212] at line 212 of Carp/Clan.pm sub Carp::Clan::CORE:regcomp; # xsub