| Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/site_perl/5.14.1/Carp.pm |
| Statements | Executed 202 statements in 13.9ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 3 | 1 | 1 | 258µs | 791µs | Carp::short_error_loc |
| 6 | 1 | 1 | 194µs | 318µs | Carp::get_status |
| 6 | 2 | 1 | 166µs | 484µs | Carp::trusts |
| 6 | 1 | 1 | 123µs | 123µs | Carp::trusts_directly |
| 1 | 1 | 1 | 60µs | 60µs | Carp::BEGIN@3 |
| 1 | 1 | 1 | 51µs | 51µs | Carp::BEGIN@105 |
| 6 | 1 | 1 | 49µs | 49µs | Carp::_cgc |
| 1 | 1 | 1 | 43µs | 116µs | Carp::BEGIN@398 |
| 1 | 1 | 1 | 31µs | 31µs | Carp::BEGIN@7 |
| 1 | 1 | 1 | 29µs | 95µs | Carp::BEGIN@399 |
| 1 | 1 | 1 | 28µs | 46µs | Carp::BEGIN@4 |
| 1 | 1 | 1 | 27µs | 62µs | Carp::BEGIN@406 |
| 1 | 1 | 1 | 25µs | 50µs | Carp::BEGIN@5 |
| 1 | 1 | 1 | 25µs | 66µs | Carp::BEGIN@67 |
| 1 | 1 | 1 | 25µs | 80µs | Carp::BEGIN@8 |
| 1 | 1 | 1 | 25µs | 61µs | Carp::BEGIN@413 |
| 1 | 1 | 1 | 23µs | 66µs | Carp::BEGIN@18 |
| 1 | 1 | 1 | 23µs | 23µs | Carp::BEGIN@17 |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:13] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:23] |
| 0 | 0 | 0 | 0s | 0s | Carp::caller_info |
| 0 | 0 | 0 | 0s | 0s | Carp::carp |
| 0 | 0 | 0 | 0s | 0s | Carp::cluck |
| 0 | 0 | 0 | 0s | 0s | Carp::confess |
| 0 | 0 | 0 | 0s | 0s | Carp::croak |
| 0 | 0 | 0 | 0s | 0s | Carp::export_fail |
| 0 | 0 | 0 | 0s | 0s | Carp::format_arg |
| 0 | 0 | 0 | 0s | 0s | Carp::get_subname |
| 0 | 0 | 0 | 0s | 0s | Carp::long_error_loc |
| 0 | 0 | 0 | 0s | 0s | Carp::longmess |
| 0 | 0 | 0 | 0s | 0s | Carp::longmess_heavy |
| 0 | 0 | 0 | 0s | 0s | Carp::ret_backtrace |
| 0 | 0 | 0 | 0s | 0s | Carp::ret_summary |
| 0 | 0 | 0 | 0s | 0s | Carp::shortmess |
| 0 | 0 | 0 | 0s | 0s | Carp::shortmess_heavy |
| 0 | 0 | 0 | 0s | 0s | Carp::str_len_trim |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Carp; | ||||
| 2 | |||||
| 3 | 3 | 169µs | 1 | 60µs | # spent 60µs within Carp::BEGIN@3 which was called:
# once (60µs+0s) by Attribute::Handlers::BEGIN@3 at line 3 # spent 60µs making 1 call to Carp::BEGIN@3 |
| 4 | 2 | 92µs | 2 | 64µs | # spent 46µs (28+18) within Carp::BEGIN@4 which was called:
# once (28µs+18µs) by Attribute::Handlers::BEGIN@3 at line 4 # spent 46µs making 1 call to Carp::BEGIN@4
# spent 18µs making 1 call to strict::import |
| 5 | 2 | 114µs | 2 | 76µs | # spent 50µs (25+25) within Carp::BEGIN@5 which was called:
# once (25µs+25µs) by Attribute::Handlers::BEGIN@3 at line 5 # spent 50µs making 1 call to Carp::BEGIN@5
# spent 25µs making 1 call to warnings::import |
| 6 | |||||
| 7 | # spent 31µs within Carp::BEGIN@7 which was called:
# once (31µs+0s) by Attribute::Handlers::BEGIN@3 at line 15 | ||||
| 8 | 2 | 355µs | 2 | 135µs | # spent 80µs (25+55) within Carp::BEGIN@8 which was called:
# once (25µs+55µs) by Attribute::Handlers::BEGIN@3 at line 8 # spent 80µs making 1 call to Carp::BEGIN@8
# spent 55µs making 1 call to strict::unimport |
| 9 | 1 | 34µs | if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"is_utf8"}) && | ||
| 10 | defined(*{*{$::{"utf8::"}}{HASH}->{"is_utf8"}}{CODE})) { | ||||
| 11 | *is_utf8 = \&{"utf8::is_utf8"}; | ||||
| 12 | } else { | ||||
| 13 | *is_utf8 = sub { 0 }; | ||||
| 14 | } | ||||
| 15 | 1 | 105µs | 1 | 31µs | } # spent 31µs making 1 call to Carp::BEGIN@7 |
| 16 | |||||
| 17 | # spent 23µs within Carp::BEGIN@17 which was called:
# once (23µs+0s) by Attribute::Handlers::BEGIN@3 at line 25 | ||||
| 18 | 2 | 348µs | 2 | 109µs | # spent 66µs (23+43) within Carp::BEGIN@18 which was called:
# once (23µs+43µs) by Attribute::Handlers::BEGIN@3 at line 18 # spent 66µs making 1 call to Carp::BEGIN@18
# spent 43µs making 1 call to strict::unimport |
| 19 | 1 | 26µs | if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"downgrade"}) && | ||
| 20 | defined(*{*{$::{"utf8::"}}{HASH}->{"downgrade"}}{CODE})) { | ||||
| 21 | *downgrade = \&{"utf8::downgrade"}; | ||||
| 22 | } else { | ||||
| 23 | *downgrade = sub {}; | ||||
| 24 | } | ||||
| 25 | 1 | 783µs | 1 | 23µs | } # spent 23µs making 1 call to Carp::BEGIN@17 |
| 26 | |||||
| 27 | 1 | 2µs | our $VERSION = '1.25'; | ||
| 28 | |||||
| 29 | 1 | 1µs | our $MaxEvalLen = 0; | ||
| 30 | 1 | 600ns | our $Verbose = 0; | ||
| 31 | 1 | 500ns | our $CarpLevel = 0; | ||
| 32 | 1 | 900ns | our $MaxArgLen = 64; # How much of each argument to print. 0 = all. | ||
| 33 | 1 | 800ns | our $MaxArgNums = 8; # How many arguments to print. 0 = all. | ||
| 34 | |||||
| 35 | 1 | 2.64ms | require Exporter; | ||
| 36 | 1 | 30µs | our @ISA = ('Exporter'); | ||
| 37 | 1 | 5µs | our @EXPORT = qw(confess croak carp); | ||
| 38 | 1 | 5µs | our @EXPORT_OK = qw(cluck verbose longmess shortmess); | ||
| 39 | 1 | 4µs | our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode | ||
| 40 | |||||
| 41 | # The members of %Internal are packages that are internal to perl. | ||||
| 42 | # Carp will not report errors from within these packages if it | ||||
| 43 | # can. The members of %CarpInternal are internal to Perl's warning | ||||
| 44 | # system. Carp will not report errors from within these packages | ||||
| 45 | # either, and will not report calls *to* these packages for carp and | ||||
| 46 | # croak. They replace $CarpLevel, which is deprecated. The | ||||
| 47 | # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval | ||||
| 48 | # text and function arguments should be formatted when printed. | ||||
| 49 | |||||
| 50 | 1 | 1µs | our %CarpInternal; | ||
| 51 | 1 | 900ns | our %Internal; | ||
| 52 | |||||
| 53 | # disable these by default, so they can live w/o require Carp | ||||
| 54 | 1 | 4µs | $CarpInternal{Carp}++; | ||
| 55 | 1 | 1µs | $CarpInternal{warnings}++; | ||
| 56 | 1 | 2µs | $Internal{Exporter}++; | ||
| 57 | 1 | 2µs | $Internal{'Exporter::Heavy'}++; | ||
| 58 | |||||
| 59 | # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") | ||||
| 60 | # then the following method will be called by the Exporter which knows | ||||
| 61 | # to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word | ||||
| 62 | # 'verbose'. | ||||
| 63 | |||||
| 64 | sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ } | ||||
| 65 | |||||
| 66 | # spent 49µs within Carp::_cgc which was called 6 times, avg 8µs/call:
# 6 times (49µs+0s) by Carp::short_error_loc at line 332, avg 8µs/call | ||||
| 67 | 2 | 1.30ms | 2 | 106µs | # spent 66µs (25+41) within Carp::BEGIN@67 which was called:
# once (25µs+41µs) by Attribute::Handlers::BEGIN@3 at line 67 # spent 66µs making 1 call to Carp::BEGIN@67
# spent 41µs making 1 call to strict::unimport |
| 68 | 6 | 22µs | return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"}; | ||
| 69 | 6 | 50µs | return; | ||
| 70 | } | ||||
| 71 | |||||
| 72 | sub longmess { | ||||
| 73 | # Icky backwards compatibility wrapper. :-( | ||||
| 74 | # | ||||
| 75 | # The story is that the original implementation hard-coded the | ||||
| 76 | # number of call levels to go back, so calls to longmess were off | ||||
| 77 | # by one. Other code began calling longmess and expecting this | ||||
| 78 | # behaviour, so the replacement has to emulate that behaviour. | ||||
| 79 | my $cgc = _cgc(); | ||||
| 80 | my $call_pack = $cgc ? $cgc->() : caller(); | ||||
| 81 | if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) { | ||||
| 82 | return longmess_heavy(@_); | ||||
| 83 | } | ||||
| 84 | else { | ||||
| 85 | local $CarpLevel = $CarpLevel + 1; | ||||
| 86 | return longmess_heavy(@_); | ||||
| 87 | } | ||||
| 88 | } | ||||
| 89 | |||||
| 90 | 1 | 1µs | our @CARP_NOT; | ||
| 91 | |||||
| 92 | sub shortmess { | ||||
| 93 | my $cgc = _cgc(); | ||||
| 94 | |||||
| 95 | # Icky backwards compatibility wrapper. :-( | ||||
| 96 | local @CARP_NOT = $cgc ? $cgc->() : caller(); | ||||
| 97 | shortmess_heavy(@_); | ||||
| 98 | } | ||||
| 99 | |||||
| 100 | sub croak { die shortmess @_ } | ||||
| 101 | sub confess { die longmess @_ } | ||||
| 102 | sub carp { warn shortmess @_ } | ||||
| 103 | sub cluck { warn longmess @_ } | ||||
| 104 | |||||
| 105 | # spent 51µs within Carp::BEGIN@105 which was called:
# once (51µs+0s) by Attribute::Handlers::BEGIN@3 at line 112 | ||||
| 106 | 1 | 46µs | if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) || | ||
| 107 | ("$]" >= 5.012005 && "$]" < 5.013)) { | ||||
| 108 | *CALLER_OVERRIDE_CHECK_OK = sub () { 1 }; | ||||
| 109 | } else { | ||||
| 110 | 1 | 8µs | *CALLER_OVERRIDE_CHECK_OK = sub () { 0 }; | ||
| 111 | } | ||||
| 112 | 1 | 6.11ms | 1 | 51µs | } # spent 51µs making 1 call to Carp::BEGIN@105 |
| 113 | |||||
| 114 | sub caller_info { | ||||
| 115 | my $i = shift(@_) + 1; | ||||
| 116 | my %call_info; | ||||
| 117 | my $cgc = _cgc(); | ||||
| 118 | { | ||||
| 119 | # Some things override caller() but forget to implement the | ||||
| 120 | # @DB::args part of it, which we need. We check for this by | ||||
| 121 | # pre-populating @DB::args with a sentinel which no-one else | ||||
| 122 | # has the address of, so that we can detect whether @DB::args | ||||
| 123 | # has been properly populated. However, on earlier versions | ||||
| 124 | # of perl this check tickles a bug in CORE::caller() which | ||||
| 125 | # leaks memory. So we only check on fixed perls. | ||||
| 126 | @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK; | ||||
| 127 | package DB; | ||||
| 128 | |||||
| - - | |||||
| 133 | unless ( defined $call_info{pack} ) { | ||||
| 134 | return (); | ||||
| 135 | } | ||||
| 136 | |||||
| 137 | my $sub_name = Carp::get_subname( \%call_info ); | ||||
| 138 | if ( $call_info{has_args} ) { | ||||
| 139 | my @args; | ||||
| 140 | if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1 | ||||
| 141 | && ref $DB::args[0] eq ref \$i | ||||
| 142 | && $DB::args[0] == \$i ) { | ||||
| 143 | @DB::args = (); # Don't let anyone see the address of $i | ||||
| 144 | local $@; | ||||
| 145 | my $where = eval { | ||||
| 146 | my $func = $cgc or return ''; | ||||
| 147 | my $gv = | ||||
| 148 | *{ | ||||
| 149 | ( $::{"B::"} || return '') # B stash | ||||
| 150 | ->{svref_2object} || return '' # entry in stash | ||||
| 151 | }{CODE} # coderef in entry | ||||
| 152 | ->($func)->GV; | ||||
| 153 | my $package = $gv->STASH->NAME; | ||||
| 154 | my $subname = $gv->NAME; | ||||
| 155 | return unless defined $package && defined $subname; | ||||
| 156 | |||||
| 157 | # returning CORE::GLOBAL::caller isn't useful for tracing the cause: | ||||
| 158 | return if $package eq 'CORE::GLOBAL' && $subname eq 'caller'; | ||||
| 159 | " in &${package}::$subname"; | ||||
| 160 | } || ''; | ||||
| 161 | @args | ||||
| 162 | = "** Incomplete caller override detected$where; \@DB::args were not set **"; | ||||
| 163 | } | ||||
| 164 | else { | ||||
| 165 | @args = map { Carp::format_arg($_) } @DB::args; | ||||
| 166 | } | ||||
| 167 | if ( $MaxArgNums and @args > $MaxArgNums ) | ||||
| 168 | { # More than we want to show? | ||||
| 169 | $#args = $MaxArgNums; | ||||
| 170 | push @args, '...'; | ||||
| 171 | } | ||||
| 172 | |||||
| 173 | # Push the args onto the subroutine | ||||
| 174 | $sub_name .= '(' . join( ', ', @args ) . ')'; | ||||
| 175 | } | ||||
| 176 | $call_info{sub_name} = $sub_name; | ||||
| 177 | return wantarray() ? %call_info : \%call_info; | ||||
| 178 | } | ||||
| 179 | |||||
| 180 | # Transform an argument to a function into a string. | ||||
| 181 | sub format_arg { | ||||
| 182 | my $arg = shift; | ||||
| 183 | if ( ref($arg) ) { | ||||
| 184 | $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; | ||||
| 185 | } | ||||
| 186 | if ( defined($arg) ) { | ||||
| 187 | $arg =~ s/'/\\'/g; | ||||
| 188 | $arg = str_len_trim( $arg, $MaxArgLen ); | ||||
| 189 | |||||
| 190 | # Quote it? | ||||
| 191 | # Downgrade, and use [0-9] rather than \d, to avoid loading | ||||
| 192 | # Unicode tables, which would be liable to fail if we're | ||||
| 193 | # processing a syntax error. | ||||
| 194 | downgrade($arg, 1); | ||||
| 195 | $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/; | ||||
| 196 | } | ||||
| 197 | else { | ||||
| 198 | $arg = 'undef'; | ||||
| 199 | } | ||||
| 200 | |||||
| 201 | # The following handling of "control chars" is direct from | ||||
| 202 | # the original code - it is broken on Unicode though. | ||||
| 203 | # Suggestions? | ||||
| 204 | is_utf8($arg) | ||||
| 205 | or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; | ||||
| 206 | return $arg; | ||||
| 207 | } | ||||
| 208 | |||||
| 209 | # Takes an inheritance cache and a package and returns | ||||
| 210 | # an anon hash of known inheritances and anon array of | ||||
| 211 | # inheritances which consequences have not been figured | ||||
| 212 | # for. | ||||
| 213 | # spent 318µs (194+123) within Carp::get_status which was called 6 times, avg 53µs/call:
# 6 times (194µs+123µs) by Carp::trusts at line 380, avg 53µs/call | ||||
| 214 | 6 | 7µs | my $cache = shift; | ||
| 215 | 6 | 7µs | my $pkg = shift; | ||
| 216 | 6 | 84µs | 6 | 123µs | $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ]; # spent 123µs making 6 calls to Carp::trusts_directly, avg 21µs/call |
| 217 | 6 | 58µs | return @{ $cache->{$pkg} }; | ||
| 218 | } | ||||
| 219 | |||||
| 220 | # Takes the info from caller() and figures out the name of | ||||
| 221 | # the sub/require/eval | ||||
| 222 | sub get_subname { | ||||
| 223 | my $info = shift; | ||||
| 224 | if ( defined( $info->{evaltext} ) ) { | ||||
| 225 | my $eval = $info->{evaltext}; | ||||
| 226 | if ( $info->{is_require} ) { | ||||
| 227 | return "require $eval"; | ||||
| 228 | } | ||||
| 229 | else { | ||||
| 230 | $eval =~ s/([\\\'])/\\$1/g; | ||||
| 231 | return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'"; | ||||
| 232 | } | ||||
| 233 | } | ||||
| 234 | |||||
| 235 | return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub}; | ||||
| 236 | } | ||||
| 237 | |||||
| 238 | # Figures out what call (from the point of view of the caller) | ||||
| 239 | # the long error backtrace should start at. | ||||
| 240 | sub long_error_loc { | ||||
| 241 | my $i; | ||||
| 242 | my $lvl = $CarpLevel; | ||||
| 243 | { | ||||
| 244 | ++$i; | ||||
| 245 | my $cgc = _cgc(); | ||||
| 246 | my $pkg = $cgc ? $cgc->($i) : caller($i); | ||||
| 247 | unless ( defined($pkg) ) { | ||||
| 248 | |||||
| 249 | # This *shouldn't* happen. | ||||
| 250 | if (%Internal) { | ||||
| 251 | local %Internal; | ||||
| 252 | $i = long_error_loc(); | ||||
| 253 | last; | ||||
| 254 | } | ||||
| 255 | else { | ||||
| 256 | |||||
| 257 | # OK, now I am irritated. | ||||
| 258 | return 2; | ||||
| 259 | } | ||||
| 260 | } | ||||
| 261 | redo if $CarpInternal{$pkg}; | ||||
| 262 | redo unless 0 > --$lvl; | ||||
| 263 | redo if $Internal{$pkg}; | ||||
| 264 | } | ||||
| 265 | return $i - 1; | ||||
| 266 | } | ||||
| 267 | |||||
| 268 | sub longmess_heavy { | ||||
| 269 | return @_ if ref( $_[0] ); # don't break references as exceptions | ||||
| 270 | my $i = long_error_loc(); | ||||
| 271 | return ret_backtrace( $i, @_ ); | ||||
| 272 | } | ||||
| 273 | |||||
| 274 | # Returns a full stack backtrace starting from where it is | ||||
| 275 | # told. | ||||
| 276 | sub ret_backtrace { | ||||
| 277 | my ( $i, @error ) = @_; | ||||
| 278 | my $mess; | ||||
| 279 | my $err = join '', @error; | ||||
| 280 | $i++; | ||||
| 281 | |||||
| 282 | my $tid_msg = ''; | ||||
| 283 | if ( defined &threads::tid ) { | ||||
| 284 | my $tid = threads->tid; | ||||
| 285 | $tid_msg = " thread $tid" if $tid; | ||||
| 286 | } | ||||
| 287 | |||||
| 288 | my %i = caller_info($i); | ||||
| 289 | $mess = "$err at $i{file} line $i{line}$tid_msg"; | ||||
| 290 | if( defined $. ) { | ||||
| 291 | local $@ = ''; | ||||
| 292 | local $SIG{__DIE__}; | ||||
| 293 | eval { | ||||
| 294 | die; | ||||
| 295 | }; | ||||
| 296 | if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) { | ||||
| 297 | $mess .= $1; | ||||
| 298 | } | ||||
| 299 | } | ||||
| 300 | $mess .= "\.\n"; | ||||
| 301 | |||||
| 302 | while ( my %i = caller_info( ++$i ) ) { | ||||
| 303 | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; | ||||
| 304 | } | ||||
| 305 | |||||
| 306 | return $mess; | ||||
| 307 | } | ||||
| 308 | |||||
| 309 | sub ret_summary { | ||||
| 310 | my ( $i, @error ) = @_; | ||||
| 311 | my $err = join '', @error; | ||||
| 312 | $i++; | ||||
| 313 | |||||
| 314 | my $tid_msg = ''; | ||||
| 315 | if ( defined &threads::tid ) { | ||||
| 316 | my $tid = threads->tid; | ||||
| 317 | $tid_msg = " thread $tid" if $tid; | ||||
| 318 | } | ||||
| 319 | |||||
| 320 | my %i = caller_info($i); | ||||
| 321 | return "$err at $i{file} line $i{line}$tid_msg\.\n"; | ||||
| 322 | } | ||||
| 323 | |||||
| 324 | # spent 791µs (258+533) within Carp::short_error_loc which was called 3 times, avg 264µs/call:
# 3 times (258µs+533µs) by warnings::__chk at line 538 of warnings.pm, avg 264µs/call | ||||
| 325 | # You have to create your (hash)ref out here, rather than defaulting it | ||||
| 326 | # inside trusts *on a lexical*, as you want it to persist across calls. | ||||
| 327 | # (You can default it on $_[2], but that gets messy) | ||||
| 328 | 3 | 10µs | my $cache = {}; | ||
| 329 | 3 | 4µs | my $i = 1; | ||
| 330 | 3 | 4µs | my $lvl = $CarpLevel; | ||
| 331 | { | ||||
| 332 | 9 | 38µs | 6 | 49µs | my $cgc = _cgc(); # spent 49µs making 6 calls to Carp::_cgc, avg 8µs/call |
| 333 | 6 | 15µs | my $called = $cgc ? $cgc->($i) : caller($i); | ||
| 334 | 6 | 5µs | $i++; | ||
| 335 | 6 | 14µs | my $caller = $cgc ? $cgc->($i) : caller($i); | ||
| 336 | |||||
| 337 | 6 | 4µs | return 0 unless defined($caller); # What happened? | ||
| 338 | 6 | 12µs | redo if $Internal{$caller}; | ||
| 339 | 6 | 8µs | redo if $CarpInternal{$caller}; | ||
| 340 | 6 | 12µs | redo if $CarpInternal{$called}; | ||
| 341 | 3 | 20µs | 3 | 288µs | redo if trusts( $called, $caller, $cache ); # spent 288µs making 3 calls to Carp::trusts, avg 96µs/call |
| 342 | 3 | 17µs | 3 | 196µs | redo if trusts( $caller, $called, $cache ); # spent 196µs making 3 calls to Carp::trusts, avg 65µs/call |
| 343 | 3 | 9µs | redo unless 0 > --$lvl; | ||
| 344 | } | ||||
| 345 | 3 | 52µs | return $i - 1; | ||
| 346 | } | ||||
| 347 | |||||
| 348 | sub shortmess_heavy { | ||||
| 349 | return longmess_heavy(@_) if $Verbose; | ||||
| 350 | return @_ if ref( $_[0] ); # don't break references as exceptions | ||||
| 351 | my $i = short_error_loc(); | ||||
| 352 | if ($i) { | ||||
| 353 | ret_summary( $i, @_ ); | ||||
| 354 | } | ||||
| 355 | else { | ||||
| 356 | longmess_heavy(@_); | ||||
| 357 | } | ||||
| 358 | } | ||||
| 359 | |||||
| 360 | # If a string is too long, trims it with ... | ||||
| 361 | sub str_len_trim { | ||||
| 362 | my $str = shift; | ||||
| 363 | my $max = shift || 0; | ||||
| 364 | if ( 2 < $max and $max < length($str) ) { | ||||
| 365 | substr( $str, $max - 3 ) = '...'; | ||||
| 366 | } | ||||
| 367 | return $str; | ||||
| 368 | } | ||||
| 369 | |||||
| 370 | # Takes two packages and an optional cache. Says whether the | ||||
| 371 | # first inherits from the second. | ||||
| 372 | # | ||||
| 373 | # Recursive versions of this have to work to avoid certain | ||||
| 374 | # possible endless loops, and when following long chains of | ||||
| 375 | # inheritance are less efficient. | ||||
| 376 | sub trusts { | ||||
| 377 | 6 | 10µs | my $child = shift; | ||
| 378 | 6 | 6µs | my $parent = shift; | ||
| 379 | 6 | 5µs | my $cache = shift; | ||
| 380 | 6 | 90µs | 6 | 318µs | my ( $known, $partial ) = get_status( $cache, $child ); # spent 318µs making 6 calls to Carp::get_status, avg 53µs/call |
| 381 | |||||
| 382 | # Figure out consequences until we have an answer | ||||
| 383 | 6 | 15µs | while ( @$partial and not exists $known->{$parent} ) { | ||
| 384 | my $anc = shift @$partial; | ||||
| 385 | next if exists $known->{$anc}; | ||||
| 386 | $known->{$anc}++; | ||||
| 387 | my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc ); | ||||
| 388 | my @found = keys %$anc_knows; | ||||
| 389 | @$known{@found} = (); | ||||
| 390 | push @$partial, @$anc_partial; | ||||
| 391 | } | ||||
| 392 | 6 | 70µs | return exists $known->{$parent}; | ||
| 393 | } | ||||
| 394 | |||||
| 395 | # Takes a package and gives a list of those trusted directly | ||||
| 396 | # spent 123µs within Carp::trusts_directly which was called 6 times, avg 21µs/call:
# 6 times (123µs+0s) by Carp::get_status at line 216, avg 21µs/call | ||||
| 397 | 6 | 9µs | my $class = shift; | ||
| 398 | 2 | 107µs | 2 | 189µs | # spent 116µs (43+73) within Carp::BEGIN@398 which was called:
# once (43µs+73µs) by Attribute::Handlers::BEGIN@3 at line 398 # spent 116µs making 1 call to Carp::BEGIN@398
# spent 73µs making 1 call to strict::unimport |
| 399 | 2 | 287µs | 2 | 161µs | # spent 95µs (29+66) within Carp::BEGIN@399 which was called:
# once (29µs+66µs) by Attribute::Handlers::BEGIN@3 at line 399 # spent 95µs making 1 call to Carp::BEGIN@399
# spent 66µs making 1 call to warnings::unimport |
| 400 | return @{"$class\::CARP_NOT"} | ||||
| 401 | ? @{"$class\::CARP_NOT"} | ||||
| 402 | 6 | 144µs | : @{"$class\::ISA"}; | ||
| 403 | } | ||||
| 404 | |||||
| 405 | 1 | 5µs | if(!defined($warnings::VERSION) || | ||
| 406 | 3 | 152µs | 2 | 96µs | # spent 62µs (27+35) within Carp::BEGIN@406 which was called:
# once (27µs+35µs) by Attribute::Handlers::BEGIN@3 at line 406 # spent 62µs making 1 call to Carp::BEGIN@406
# spent 35µs making 1 call to warnings::unimport |
| 407 | # Very old versions of warnings.pm import from Carp. This can go | ||||
| 408 | # wrong due to the circular dependency. If Carp is invoked before | ||||
| 409 | # warnings, then Carp starts by loading warnings, then warnings | ||||
| 410 | # tries to import from Carp, and gets nothing because Carp is in | ||||
| 411 | # the process of loading and hasn't defined its import method yet. | ||||
| 412 | # So we work around that by manually exporting to warnings here. | ||||
| 413 | 2 | 283µs | 2 | 96µs | # spent 61µs (25+36) within Carp::BEGIN@413 which was called:
# once (25µs+36µs) by Attribute::Handlers::BEGIN@3 at line 413 # spent 61µs making 1 call to Carp::BEGIN@413
# spent 36µs making 1 call to strict::unimport |
| 414 | *{"warnings::$_"} = \&$_ foreach @EXPORT; | ||||
| 415 | } | ||||
| 416 | |||||
| 417 | 1 | 55µs | 1; | ||
| 418 | |||||
| 419 | __END__ |