| 1 | # Carp::Heavy uses some variables in common with Carp. |
| 2 | package Carp; |
| 3 | |
| 4 | =head1 NAME |
| 5 | |
| 6 | Carp heavy machinery - no user serviceable parts inside |
| 7 | |
| 8 | =cut |
| 9 | |
| 10 | # use strict; # not yet |
| 11 | |
| 12 | # On one line so MakeMaker will see it. |
| 13 | use Carp; our $VERSION = $Carp::VERSION; |
| 14 | |
| 15 | our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxLenArg, $Verbose); |
| 16 | |
| 17 | sub caller_info { |
| 18 | my $i = shift(@_) + 1; |
| 19 | package DB; |
| 20 | my %call_info; |
| 21 | @call_info{ |
| 22 | qw(pack file line sub has_args wantarray evaltext is_require) |
| 23 | } = caller($i); |
| 24 | |
| 25 | unless (defined $call_info{pack}) { |
| 26 | return (); |
| 27 | } |
| 28 | |
| 29 | my $sub_name = Carp::get_subname(\%call_info); |
| 30 | if ($call_info{has_args}) { |
| 31 | my @args = map {Carp::format_arg($_)} @args; |
| 32 | if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? |
| 33 | $#args = $MaxArgNums; |
| 34 | push @args, '...'; |
| 35 | } |
| 36 | # Push the args onto the subroutine |
| 37 | $sub_name .= '(' . join (',', @args) . ')'; |
| 38 | } |
| 39 | $call_info{sub_name} = $sub_name; |
| 40 | return wantarray() ? %call_info : \%call_info; |
| 41 | } |
| 42 | |
| 43 | # Transform an argument to a function into a string. |
| 44 | sub format_arg { |
| 45 | my $arg = shift; |
| 46 | if (not defined($arg)) { |
| 47 | $arg = 'undef'; |
| 48 | } |
| 49 | elsif (ref($arg)) { |
| 50 | $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; |
| 51 | } |
| 52 | $arg =~ s/'/\\'/g; |
| 53 | $arg = str_len_trim($arg, $MaxLenArg); |
| 54 | |
| 55 | # Quote it? |
| 56 | $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; |
| 57 | |
| 58 | # The following handling of "control chars" is direct from |
| 59 | # the original code - I think it is broken on Unicode though. |
| 60 | # Suggestions? |
| 61 | $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; |
| 62 | return $arg; |
| 63 | } |
| 64 | |
| 65 | # Takes an inheritance cache and a package and returns |
| 66 | # an anon hash of known inheritances and anon array of |
| 67 | # inheritances which consequences have not been figured |
| 68 | # for. |
| 69 | sub get_status { |
| 70 | my $cache = shift; |
| 71 | my $pkg = shift; |
| 72 | $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; |
| 73 | return @{$cache->{$pkg}}; |
| 74 | } |
| 75 | |
| 76 | # Takes the info from caller() and figures out the name of |
| 77 | # the sub/require/eval |
| 78 | sub get_subname { |
| 79 | my $info = shift; |
| 80 | if (defined($info->{eval})) { |
| 81 | my $eval = $info->{eval}; |
| 82 | if ($info->{is_require}) { |
| 83 | return "require $eval"; |
| 84 | } |
| 85 | else { |
| 86 | $eval =~ s/([\\\'])/\\$1/g; |
| 87 | return str_len_trim($eval, $MaxEvalLen); |
| 88 | } |
| 89 | } |
| 90 | |
| 91 | return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; |
| 92 | } |
| 93 | |
| 94 | # Figures out what call (from the point of view of the caller) |
| 95 | # the long error backtrace should start at. |
| 96 | sub long_error_loc { |
| 97 | my $i; |
| 98 | my $lvl = $CarpLevel; |
| 99 | { |
| 100 | my $pkg = caller(++$i); |
| 101 | unless(defined($pkg)) { |
| 102 | # This *shouldn't* happen. |
| 103 | if (%Internal) { |
| 104 | local %Internal; |
| 105 | $i = long_error_loc(); |
| 106 | last; |
| 107 | } |
| 108 | else { |
| 109 | # OK, now I am irritated. |
| 110 | return 2; |
| 111 | } |
| 112 | } |
| 113 | redo if $CarpInternal{$pkg}; |
| 114 | redo unless 0 > --$lvl; |
| 115 | redo if $Internal{$pkg}; |
| 116 | } |
| 117 | return $i - 1; |
| 118 | } |
| 119 | |
| 120 | |
| 121 | sub longmess_heavy { |
| 122 | return @_ if ref($_[0]); # don't break references as exceptions |
| 123 | my $i = long_error_loc(); |
| 124 | return ret_backtrace($i, @_); |
| 125 | } |
| 126 | |
| 127 | # Returns a full stack backtrace starting from where it is |
| 128 | # told. |
| 129 | sub ret_backtrace { |
| 130 | my ($i, @error) = @_; |
| 131 | my $mess; |
| 132 | my $err = join '', @error; |
| 133 | $i++; |
| 134 | |
| 135 | my $tid_msg = ''; |
| 136 | if (defined &Thread::tid) { |
| 137 | my $tid = Thread->self->tid; |
| 138 | $tid_msg = " thread $tid" if $tid; |
| 139 | } |
| 140 | |
| 141 | { if ($err =~ /\n$/) { # extra block to localise $1 etc |
| 142 | $mess = $err; |
| 143 | } |
| 144 | else { |
| 145 | my %i = caller_info($i); |
| 146 | $mess = "$err at $i{file} line $i{line}$tid_msg\n"; |
| 147 | }} |
| 148 | |
| 149 | while (my %i = caller_info(++$i)) { |
| 150 | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; |
| 151 | } |
| 152 | |
| 153 | return $mess; |
| 154 | } |
| 155 | |
| 156 | sub ret_summary { |
| 157 | my ($i, @error) = @_; |
| 158 | my $mess; |
| 159 | my $err = join '', @error; |
| 160 | $i++; |
| 161 | |
| 162 | my $tid_msg = ''; |
| 163 | if (defined &Thread::tid) { |
| 164 | my $tid = Thread->self->tid; |
| 165 | $tid_msg = " thread $tid" if $tid; |
| 166 | } |
| 167 | |
| 168 | my %i = caller_info($i); |
| 169 | return "$err at $i{file} line $i{line}$tid_msg\n"; |
| 170 | } |
| 171 | |
| 172 | |
| 173 | sub short_error_loc { |
| 174 | my $cache; |
| 175 | my $i = 1; |
| 176 | my $lvl = $CarpLevel; |
| 177 | { |
| 178 | my $called = caller($i++); |
| 179 | my $caller = caller($i); |
| 180 | return 0 unless defined($caller); # What happened? |
| 181 | redo if $Internal{$caller}; |
| 182 | redo if $CarpInternal{$called}; |
| 183 | redo if trusts($called, $caller, $cache); |
| 184 | redo if trusts($caller, $called, $cache); |
| 185 | redo unless 0 > --$lvl; |
| 186 | } |
| 187 | return $i - 1; |
| 188 | } |
| 189 | |
| 190 | sub shortmess_heavy { |
| 191 | return longmess_heavy(@_) if $Verbose; |
| 192 | return @_ if ref($_[0]); # don't break references as exceptions |
| 193 | my $i = short_error_loc(); |
| 194 | if ($i) { |
| 195 | ret_summary($i, @_); |
| 196 | } |
| 197 | else { |
| 198 | longmess_heavy(@_); |
| 199 | } |
| 200 | } |
| 201 | |
| 202 | # If a string is too long, trims it with ... |
| 203 | sub str_len_trim { |
| 204 | my $str = shift; |
| 205 | my $max = shift || 0; |
| 206 | if (2 < $max and $max < length($str)) { |
| 207 | substr($str, $max - 3) = '...'; |
| 208 | } |
| 209 | return $str; |
| 210 | } |
| 211 | |
| 212 | # Takes two packages and an optional cache. Says whether the |
| 213 | # first inherits from the second. |
| 214 | # |
| 215 | # Recursive versions of this have to work to avoid certain |
| 216 | # possible endless loops, and when following long chains of |
| 217 | # inheritance are less efficient. |
| 218 | sub trusts { |
| 219 | my $child = shift; |
| 220 | my $parent = shift; |
| 221 | my $cache = shift || {}; |
| 222 | my ($known, $partial) = get_status($cache, $child); |
| 223 | # Figure out consequences until we have an answer |
| 224 | while (@$partial and not exists $known->{$parent}) { |
| 225 | my $anc = shift @$partial; |
| 226 | next if exists $known->{$anc}; |
| 227 | $known->{$anc}++; |
| 228 | my ($anc_knows, $anc_partial) = get_status($cache, $anc); |
| 229 | my @found = keys %$anc_knows; |
| 230 | @$known{@found} = (); |
| 231 | push @$partial, @$anc_partial; |
| 232 | } |
| 233 | return exists $known->{$parent}; |
| 234 | } |
| 235 | |
| 236 | # Takes a package and gives a list of those trusted directly |
| 237 | sub trusts_directly { |
| 238 | my $class = shift; |
| 239 | return @{"$class\::ISA"}; |
| 240 | } |
| 241 | |
| 242 | 1; |
| 243 | |