| Filename | /home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/5.13.5/Carp.pm |
| Statements | Executed 66 statements in 271µs |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 65µs | 138µs | Carp::short_error_loc |
| 1 | 1 | 1 | 48µs | 81µs | Carp::BEGIN@313 |
| 2 | 2 | 1 | 28µs | 73µs | Carp::trusts |
| 2 | 1 | 1 | 27µs | 45µs | Carp::get_status |
| 2 | 1 | 1 | 18µs | 18µs | Carp::trusts_directly |
| 1 | 1 | 1 | 13µs | 38µs | Carp::BEGIN@314 |
| 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 | 1 | 2µs | our $VERSION = '1.18'; | ||
| 4 | |||||
| 5 | 1 | 1µs | our $MaxEvalLen = 0; | ||
| 6 | 1 | 1µs | our $Verbose = 0; | ||
| 7 | 1 | 1µs | our $CarpLevel = 0; | ||
| 8 | 1 | 1µs | our $MaxArgLen = 64; # How much of each argument to print. 0 = all. | ||
| 9 | 1 | 1µs | our $MaxArgNums = 8; # How many arguments to print. 0 = all. | ||
| 10 | |||||
| 11 | 1 | 2µs | require Exporter; | ||
| 12 | 1 | 8µs | our @ISA = ('Exporter'); | ||
| 13 | 1 | 2µs | our @EXPORT = qw(confess croak carp); | ||
| 14 | 1 | 2µs | our @EXPORT_OK = qw(cluck verbose longmess shortmess); | ||
| 15 | 1 | 1µs | our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode | ||
| 16 | |||||
| 17 | # The members of %Internal are packages that are internal to perl. | ||||
| 18 | # Carp will not report errors from within these packages if it | ||||
| 19 | # can. The members of %CarpInternal are internal to Perl's warning | ||||
| 20 | # system. Carp will not report errors from within these packages | ||||
| 21 | # either, and will not report calls *to* these packages for carp and | ||||
| 22 | # croak. They replace $CarpLevel, which is deprecated. The | ||||
| 23 | # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval | ||||
| 24 | # text and function arguments should be formatted when printed. | ||||
| 25 | |||||
| 26 | # disable these by default, so they can live w/o require Carp | ||||
| 27 | 1 | 2µs | $CarpInternal{Carp}++; | ||
| 28 | 1 | 900ns | $CarpInternal{warnings}++; | ||
| 29 | 1 | 1µs | $Internal{Exporter}++; | ||
| 30 | 1 | 1µs | $Internal{'Exporter::Heavy'}++; | ||
| 31 | |||||
| 32 | # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") | ||||
| 33 | # then the following method will be called by the Exporter which knows | ||||
| 34 | # to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word | ||||
| 35 | # 'verbose'. | ||||
| 36 | |||||
| 37 | sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ } | ||||
| 38 | |||||
| 39 | sub longmess { | ||||
| 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 = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}() : 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 { | ||||
| 57 | # Icky backwards compatibility wrapper. :-( | ||||
| 58 | local @CARP_NOT = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}() : caller(); | ||||
| 59 | shortmess_heavy(@_); | ||||
| 60 | }; | ||||
| 61 | |||||
| 62 | sub croak { die shortmess @_ } | ||||
| 63 | sub confess { die longmess @_ } | ||||
| 64 | sub carp { warn shortmess @_ } | ||||
| 65 | sub cluck { warn longmess @_ } | ||||
| 66 | |||||
| 67 | sub caller_info { | ||||
| 68 | my $i = shift(@_) + 1; | ||||
| 69 | my %call_info; | ||||
| 70 | { | ||||
| 71 | package DB; | ||||
| 72 | |||||
| - - | |||||
| 78 | unless (defined $call_info{pack}) { | ||||
| 79 | return (); | ||||
| 80 | } | ||||
| 81 | |||||
| 82 | my $sub_name = Carp::get_subname(\%call_info); | ||||
| 83 | if ($call_info{has_args}) { | ||||
| 84 | my @args; | ||||
| 85 | if (@DB::args == 1 && ref $DB::args[0] eq ref \$i && $DB::args[0] == \$i) { | ||||
| 86 | @DB::args = (); # Don't let anyone see the address of $i | ||||
| 87 | local $@; | ||||
| 88 | my $where = eval { | ||||
| 89 | my $gv = B::svref_2object(\&CORE::GLOBAL::caller)->GV; | ||||
| 90 | my $package = $gv->STASH->NAME; | ||||
| 91 | my $subname = $gv->NAME; | ||||
| 92 | return unless defined $package && defined $subname; | ||||
| 93 | # returning CORE::GLOBAL::caller isn't useful for tracing the cause: | ||||
| 94 | return if $package eq 'CORE::GLOBAL' && $subname eq 'caller'; | ||||
| 95 | " in &${package}::$subname"; | ||||
| 96 | } // ''; | ||||
| 97 | @args = "** Incomplete caller override detected$where; \@DB::args were not set **"; | ||||
| 98 | } else { | ||||
| 99 | @args = map {Carp::format_arg($_)} @DB::args; | ||||
| 100 | } | ||||
| 101 | if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? | ||||
| 102 | $#args = $MaxArgNums; | ||||
| 103 | push @args, '...'; | ||||
| 104 | } | ||||
| 105 | # Push the args onto the subroutine | ||||
| 106 | $sub_name .= '(' . join (', ', @args) . ')'; | ||||
| 107 | } | ||||
| 108 | $call_info{sub_name} = $sub_name; | ||||
| 109 | return wantarray() ? %call_info : \%call_info; | ||||
| 110 | } | ||||
| 111 | |||||
| 112 | # Transform an argument to a function into a string. | ||||
| 113 | sub format_arg { | ||||
| 114 | my $arg = shift; | ||||
| 115 | if (ref($arg)) { | ||||
| 116 | $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; | ||||
| 117 | } | ||||
| 118 | if (defined($arg)) { | ||||
| 119 | $arg =~ s/'/\\'/g; | ||||
| 120 | $arg = str_len_trim($arg, $MaxArgLen); | ||||
| 121 | |||||
| 122 | # Quote it? | ||||
| 123 | $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; | ||||
| 124 | } else { | ||||
| 125 | $arg = 'undef'; | ||||
| 126 | } | ||||
| 127 | |||||
| 128 | # The following handling of "control chars" is direct from | ||||
| 129 | # the original code - it is broken on Unicode though. | ||||
| 130 | # Suggestions? | ||||
| 131 | utf8::is_utf8($arg) | ||||
| 132 | or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; | ||||
| 133 | return $arg; | ||||
| 134 | } | ||||
| 135 | |||||
| 136 | # Takes an inheritance cache and a package and returns | ||||
| 137 | # an anon hash of known inheritances and anon array of | ||||
| 138 | # inheritances which consequences have not been figured | ||||
| 139 | # for. | ||||
| 140 | # spent 45µs (27+18) within Carp::get_status which was called 2 times, avg 22µs/call:
# 2 times (27µs+18µs) by Carp::trusts at line 296, avg 22µs/call | ||||
| 141 | 2 | 2µs | my $cache = shift; | ||
| 142 | 2 | 2µs | my $pkg = shift; | ||
| 143 | 2 | 11µs | 2 | 18µs | $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; # spent 18µs making 2 calls to Carp::trusts_directly, avg 9µs/call |
| 144 | 2 | 8µs | return @{$cache->{$pkg}}; | ||
| 145 | } | ||||
| 146 | |||||
| 147 | # Takes the info from caller() and figures out the name of | ||||
| 148 | # the sub/require/eval | ||||
| 149 | sub get_subname { | ||||
| 150 | my $info = shift; | ||||
| 151 | if (defined($info->{evaltext})) { | ||||
| 152 | my $eval = $info->{evaltext}; | ||||
| 153 | if ($info->{is_require}) { | ||||
| 154 | return "require $eval"; | ||||
| 155 | } | ||||
| 156 | else { | ||||
| 157 | $eval =~ s/([\\\'])/\\$1/g; | ||||
| 158 | return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'"; | ||||
| 159 | } | ||||
| 160 | } | ||||
| 161 | |||||
| 162 | return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; | ||||
| 163 | } | ||||
| 164 | |||||
| 165 | # Figures out what call (from the point of view of the caller) | ||||
| 166 | # the long error backtrace should start at. | ||||
| 167 | sub long_error_loc { | ||||
| 168 | my $i; | ||||
| 169 | my $lvl = $CarpLevel; | ||||
| 170 | { | ||||
| 171 | ++$i; | ||||
| 172 | my $pkg = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i); | ||||
| 173 | unless(defined($pkg)) { | ||||
| 174 | # This *shouldn't* happen. | ||||
| 175 | if (%Internal) { | ||||
| 176 | local %Internal; | ||||
| 177 | $i = long_error_loc(); | ||||
| 178 | last; | ||||
| 179 | } | ||||
| 180 | else { | ||||
| 181 | # OK, now I am irritated. | ||||
| 182 | return 2; | ||||
| 183 | } | ||||
| 184 | } | ||||
| 185 | redo if $CarpInternal{$pkg}; | ||||
| 186 | redo unless 0 > --$lvl; | ||||
| 187 | redo if $Internal{$pkg}; | ||||
| 188 | } | ||||
| 189 | return $i - 1; | ||||
| 190 | } | ||||
| 191 | |||||
| 192 | |||||
| 193 | sub longmess_heavy { | ||||
| 194 | return @_ if ref($_[0]); # don't break references as exceptions | ||||
| 195 | my $i = long_error_loc(); | ||||
| 196 | return ret_backtrace($i, @_); | ||||
| 197 | } | ||||
| 198 | |||||
| 199 | # Returns a full stack backtrace starting from where it is | ||||
| 200 | # told. | ||||
| 201 | sub ret_backtrace { | ||||
| 202 | my ($i, @error) = @_; | ||||
| 203 | my $mess; | ||||
| 204 | my $err = join '', @error; | ||||
| 205 | $i++; | ||||
| 206 | |||||
| 207 | my $tid_msg = ''; | ||||
| 208 | if (defined &threads::tid) { | ||||
| 209 | my $tid = threads->tid; | ||||
| 210 | $tid_msg = " thread $tid" if $tid; | ||||
| 211 | } | ||||
| 212 | |||||
| 213 | my %i = caller_info($i); | ||||
| 214 | $mess = "$err at $i{file} line $i{line}$tid_msg\n"; | ||||
| 215 | |||||
| 216 | while (my %i = caller_info(++$i)) { | ||||
| 217 | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; | ||||
| 218 | } | ||||
| 219 | |||||
| 220 | return $mess; | ||||
| 221 | } | ||||
| 222 | |||||
| 223 | sub ret_summary { | ||||
| 224 | my ($i, @error) = @_; | ||||
| 225 | my $err = join '', @error; | ||||
| 226 | $i++; | ||||
| 227 | |||||
| 228 | my $tid_msg = ''; | ||||
| 229 | if (defined &threads::tid) { | ||||
| 230 | my $tid = threads->tid; | ||||
| 231 | $tid_msg = " thread $tid" if $tid; | ||||
| 232 | } | ||||
| 233 | |||||
| 234 | my %i = caller_info($i); | ||||
| 235 | return "$err at $i{file} line $i{line}$tid_msg\n"; | ||||
| 236 | } | ||||
| 237 | |||||
| 238 | |||||
| 239 | # spent 138µs (65+73) within Carp::short_error_loc which was called:
# once (65µs+73µs) by warnings::__chk at line 527 of warnings.pm | ||||
| 240 | # You have to create your (hash)ref out here, rather than defaulting it | ||||
| 241 | # inside trusts *on a lexical*, as you want it to persist across calls. | ||||
| 242 | # (You can default it on $_[2], but that gets messy) | ||||
| 243 | 1 | 1µs | my $cache = {}; | ||
| 244 | 1 | 2µs | my $i = 1; | ||
| 245 | 1 | 1µs | my $lvl = $CarpLevel; | ||
| 246 | { | ||||
| 247 | |||||
| 248 | 3 | 7µs | my $called = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i); | ||
| 249 | 2 | 2µs | $i++; | ||
| 250 | 2 | 4µs | my $caller = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i); | ||
| 251 | |||||
| 252 | 2 | 2µs | return 0 unless defined($caller); # What happened? | ||
| 253 | 2 | 3µs | redo if $Internal{$caller}; | ||
| 254 | 2 | 2µs | redo if $CarpInternal{$caller}; | ||
| 255 | 2 | 2µs | redo if $CarpInternal{$called}; | ||
| 256 | 1 | 5µs | 1 | 42µs | redo if trusts($called, $caller, $cache); # spent 42µs making 1 call to Carp::trusts |
| 257 | 1 | 4µs | 1 | 31µs | redo if trusts($caller, $called, $cache); # spent 31µs making 1 call to Carp::trusts |
| 258 | 1 | 2µs | redo unless 0 > --$lvl; | ||
| 259 | } | ||||
| 260 | 1 | 6µs | return $i - 1; | ||
| 261 | } | ||||
| 262 | |||||
| 263 | |||||
| 264 | sub shortmess_heavy { | ||||
| 265 | return longmess_heavy(@_) if $Verbose; | ||||
| 266 | return @_ if ref($_[0]); # don't break references as exceptions | ||||
| 267 | my $i = short_error_loc(); | ||||
| 268 | if ($i) { | ||||
| 269 | ret_summary($i, @_); | ||||
| 270 | } | ||||
| 271 | else { | ||||
| 272 | longmess_heavy(@_); | ||||
| 273 | } | ||||
| 274 | } | ||||
| 275 | |||||
| 276 | # If a string is too long, trims it with ... | ||||
| 277 | sub str_len_trim { | ||||
| 278 | my $str = shift; | ||||
| 279 | my $max = shift || 0; | ||||
| 280 | if (2 < $max and $max < length($str)) { | ||||
| 281 | substr($str, $max - 3) = '...'; | ||||
| 282 | } | ||||
| 283 | return $str; | ||||
| 284 | } | ||||
| 285 | |||||
| 286 | # Takes two packages and an optional cache. Says whether the | ||||
| 287 | # first inherits from the second. | ||||
| 288 | # | ||||
| 289 | # Recursive versions of this have to work to avoid certain | ||||
| 290 | # possible endless loops, and when following long chains of | ||||
| 291 | # inheritance are less efficient. | ||||
| 292 | sub trusts { | ||||
| 293 | 2 | 3µs | my $child = shift; | ||
| 294 | 2 | 2µs | my $parent = shift; | ||
| 295 | 2 | 2µs | my $cache = shift; | ||
| 296 | 2 | 9µs | 2 | 45µs | my ($known, $partial) = get_status($cache, $child); # spent 45µs making 2 calls to Carp::get_status, avg 22µs/call |
| 297 | # Figure out consequences until we have an answer | ||||
| 298 | 2 | 4µs | while (@$partial and not exists $known->{$parent}) { | ||
| 299 | my $anc = shift @$partial; | ||||
| 300 | next if exists $known->{$anc}; | ||||
| 301 | $known->{$anc}++; | ||||
| 302 | my ($anc_knows, $anc_partial) = get_status($cache, $anc); | ||||
| 303 | my @found = keys %$anc_knows; | ||||
| 304 | @$known{@found} = (); | ||||
| 305 | push @$partial, @$anc_partial; | ||||
| 306 | } | ||||
| 307 | 2 | 28µs | return exists $known->{$parent}; | ||
| 308 | } | ||||
| 309 | |||||
| 310 | # Takes a package and gives a list of those trusted directly | ||||
| 311 | # spent 18µs within Carp::trusts_directly which was called 2 times, avg 9µs/call:
# 2 times (18µs+0s) by Carp::get_status at line 143, avg 9µs/call | ||||
| 312 | 2 | 3µs | my $class = shift; | ||
| 313 | 2 | 33µs | 2 | 114µs | # spent 81µs (48+33) within Carp::BEGIN@313 which was called:
# once (48µs+33µs) by Mouse::Exporter::BEGIN@5 at line 313 # spent 81µs making 1 call to Carp::BEGIN@313
# spent 33µs making 1 call to strict::unimport |
| 314 | 2 | 64µs | 2 | 63µs | # spent 38µs (13+25) within Carp::BEGIN@314 which was called:
# once (13µs+25µs) by Mouse::Exporter::BEGIN@5 at line 314 # spent 38µs making 1 call to Carp::BEGIN@314
# spent 25µs making 1 call to warnings::unimport |
| 315 | return @{"$class\::CARP_NOT"} | ||||
| 316 | ? @{"$class\::CARP_NOT"} | ||||
| 317 | 2 | 20µs | : @{"$class\::ISA"}; | ||
| 318 | } | ||||
| 319 | |||||
| 320 | 1 | 9µs | 1; | ||
| 321 | |||||
| 322 | __END__ |