← 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:22:21 2010

File /usr/local/lib/perl5/site_perl/5.10.1/Carp/Clan.pm
Statements Executed 92
Statement Execution Time 1.55ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
444282µs349µsCarp::Clan::::importCarp::Clan::import
44543µs43µsCarp::Clan::::CORE:regcompCarp::Clan::CORE:regcomp (opcode)
11119µs22µsCarp::Clan::::BEGIN@16Carp::Clan::BEGIN@16
44515µs15µsCarp::Clan::::CORE:qrCarp::Clan::CORE:qr (opcode)
11112µs31µsCarp::Clan::::BEGIN@224Carp::Clan::BEGIN@224
81210µs10µsCarp::Clan::::CORE:matchCarp::Clan::CORE:match (opcode)
1117µs72µsCarp::Clan::::BEGIN@17Carp::Clan::BEGIN@17
1114µs4µsCarp::Clan::::BEGIN@18Carp::Clan::BEGIN@18
0000s0sCarp::Clan::::__ANON__[:225]Carp::Clan::__ANON__[:225]
0000s0sCarp::Clan::::__ANON__[:226]Carp::Clan::__ANON__[:226]
0000s0sCarp::Clan::::__ANON__[:227]Carp::Clan::__ANON__[:227]
0000s0sCarp::Clan::::__ANON__[:228]Carp::Clan::__ANON__[:228]
0000s0sCarp::Clan::::_longmsgCarp::Clan::_longmsg
0000s0sCarp::Clan::::_shortmsgCarp::Clan::_shortmsg
0000s0sCarp::Clan::::carpCarp::Clan::carp
0000s0sCarp::Clan::::cluckCarp::Clan::cluck
0000s0sCarp::Clan::::confessCarp::Clan::confess
0000s0sCarp::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
121600ns@DB::args = (); # Avoid warning "used only once" in Perl 5.003
13
14package Carp::Clan;
15
16332µs225µ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
17323µs2137µ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
183940µs14µ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
251300ns$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
261100ns$MaxArgLen = 64; # How much of each argument to print. 0 = all.
271100ns$MaxArgNums = 8; # How many arguments to print. 0 = all.
28
2910s$Verbose = 0; # If true then make _shortmsg call _longmsg instead.
30
311400ns$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
39sub _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
129sub _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
168sub croak {
169 my $callpkg = caller(0);
170 my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
171 die _shortmsg( $pattern, 0, @_ );
172}
173sub confess { die _longmsg(@_); }
174
175sub carp {
176 my $callpkg = caller(0);
177 my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
178 warn _shortmsg( $pattern, 0, @_ );
179}
180sub 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 {
18772233µs my $pkg = shift;
188 my $callpkg = caller(0);
189 my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
190 my $verbose = 0;
191 my $item;
192 my $file;
193
194 for $item (@_) {
195 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 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 if ( $] >= 5.005 ) {
2121114µs857µ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 if ($@) {
218 $@ =~ s/\s+$//;
219 $@ =~ s/\s+at\s.+$//;
220 die _shortmsg( '^:::', 0, $@ );
221 }
222 {
223 local ($^W) = 0;
2243199µs250µ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 *{"${callpkg}::croak"} = sub { die _shortmsg( $pattern, $verbose, @_ ); };
226 *{"${callpkg}::confess"} = sub { die _longmsg ( @_ ); };
227 *{"${callpkg}::carp"} = sub { warn _shortmsg( $pattern, $verbose, @_ ); };
228 *{"${callpkg}::cluck"} = sub { warn _longmsg ( @_ ); };
229 }
230}
231
23218µs1;
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