← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:35 2010

File/wise/base/static/lib/perl5/site_perl/5.10.0/Carp/Clan.pm
Statements Executed164
Total Time0.002403 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
8880.000860.00086Carp::Clan::import
00000Carp::Clan::BEGIN
00000Carp::Clan::__ANON__[:213]
00000Carp::Clan::__ANON__[:214]
00000Carp::Clan::__ANON__[:216]
00000Carp::Clan::__ANON__[:217]
00000Carp::Clan::_longmsg
00000Carp::Clan::_shortmsg
00000Carp::Clan::carp
00000Carp::Clan::cluck
00000Carp::Clan::confess
00000Carp::Clan::croak

LineStmts.Exclusive
Time		Avg.Code
1
2##
3## Based on Carp.pm from Perl 5.005_03.
4## Last modified 12-Jun-2001 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
1211.0e-61.0e-6@DB::args = (); # Avoid warning "used only once" in Perl 5.003
13
14package Carp::Clan;
15
1634.6e-51.5e-5use strict;
# spent 11µs making 1 call to strict::import
1733.6e-51.2e-5use vars qw( $MaxEvalLen $MaxArgLen $MaxArgNums $Verbose $VERSION );
# spent 90µs making 1 call to vars::import
1830.001300.00043use overload ();
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
25100$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
2611.0e-61.0e-6$MaxArgLen = 64; # How much of each argument to print. 0 = all.
27100$MaxArgNums = 8; # How many arguments to print. 0 = all.
28
2911.0e-61.0e-6$Verbose = 0; # If true then make _shortmsg call _longmsg instead.
30
3111.0e-61.0e-6$VERSION = '5.9';
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 if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
109 else { $msg = "$sub: $error"; }
110 }
111 $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
112 $error = '';
113 }
114 $msg ||= $error;
115 $msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
116 $msg;
117}
118
119# _shortmsg() is called by carp() and croak() to skip all the way up to
120# the top-level caller's package and report the error from there. confess()
121# and cluck() generate a full stack trace so they call _longmsg() to
122# generate that. In verbose mode _shortmsg() calls _longmsg() so you
123# always get a stack trace.
124
125sub _shortmsg {
126 my $pattern = shift;
127 my $verbose = shift;
128 return (@_) if ( ref $_[0] );
129 goto &_longmsg if ( $Verbose or $verbose );
130 my ( $pack, $file, $line, $sub );
131 my $error = join( '', @_ );
132 my $msg = '';
133 my $i = 0;
134 while ( ( $pack, $file, $line, $sub ) = caller( $i++ ) ) {
135 next if ( $pack eq 'Carp::Clan' or $pack =~ /$pattern/ );
136 if ( $error eq '' ) { $msg = "$sub() called"; }
137 elsif ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
138 else { $msg = "$sub: $error"; }
139 $msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
140 $msg =~ tr/\0//d
141 ; # Circumvent die's incorrect handling of NUL characters
142 return $msg;
143 }
144 goto &_longmsg;
145}
146
147# The following four functions call _longmsg() or _shortmsg() depending on
148# whether they should generate a full stack trace (confess() and cluck())
149# or simply report the caller's package (croak() and carp()), respectively.
150# confess() and croak() die, carp() and cluck() warn.
151
152# Following code kept for calls with fully qualified subroutine names:
153# (For backward compatibility with the original Carp.pm)
154
155sub croak {
156 my $callpkg = caller(0);
157 my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
158 die _shortmsg( $pattern, 0, @_ );
159}
160sub confess { die _longmsg(@_); }
161
162sub carp {
163 my $callpkg = caller(0);
164 my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
165 warn _shortmsg( $pattern, 0, @_ );
166}
167sub cluck { warn _longmsg(@_); }
168
169# The following method imports a different closure for every caller.
170# I.e., different modules can use this module at the same time
171# and in parallel and still use different patterns.
172
173
# spent 856µs within Carp::Clan::import which was called 8 times, avg 107µs/call: # once (125µs+0) at line 6 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Exception.pm # once (119µs+0) at line 9 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Storage.pm # once (119µs+0) at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Row.pm # once (117µs+0) at line 8 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Componentised.pm # once (101µs+0) at line 9 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSet.pm # once (98µs+0) by DBIx::Class::ResultSourceProxy::BEGIN at line 9 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm # once (92µs+0) at line 8 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSource.pm # once (85µs+0) at line 7 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm
sub import {
174800.000111.4e-6 my $pkg = shift;
175 my $callpkg = caller(0);
176 my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
177 my $verbose = 0;
178 my $item;
179 my $file;
180
181 for $item (@_) {
182165.1e-53.2e-6 if ( $item =~ /^\d/ ) {
183 if ( $VERSION < $item ) {
184 $file = "$pkg.pm";
185 $file =~ s!::!/!g;
186 $file = $INC{$file};
187 die _shortmsg( '^:::', 0,
188 "$pkg $item required--this is only version $VERSION ($file)"
189 );
190 }
191 }
192 elsif ( $item =~ /^verbose$/i ) { $verbose = 1; }
193 else { $pattern = $item; }
194 }
195
196 # Speed up pattern matching in Perl versions >= 5.005:
197 # (Uses "eval ''" because qr// is a syntax error in previous Perl versions)
19880.000222.7e-5 if ( $] >= 5.005 ) {
19910.000160.00016 eval '$pattern = qr/$pattern/;';
200 }
201 else {
202 eval { $pkg =~ /$pattern/; };
203 }
204 if ($@) {
205 $@ =~ s/\s+$//;
206 $@ =~ s/\s+at\s.+$//;
207 die _shortmsg( '^:::', 0, $@ );
208 }
209 {
210400.000266.4e-6 local ($^W) = 0;
21130.000216.9e-5 no strict "refs";
# spent 25µs making 1 call to strict::unimport
212 *{"${callpkg}::croak"}
213 = sub { die _shortmsg( $pattern, $verbose, @_ ); };
214 *{"${callpkg}::confess"} = sub { die _longmsg(@_); };
215 *{"${callpkg}::carp"}
216 = sub { warn _shortmsg( $pattern, $verbose, @_ ); };
217 *{"${callpkg}::cluck"} = sub { warn _longmsg(@_); };
218 }
219}
220
22117.0e-67.0e-61;
222

Report produced by the NYTProf 2.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.