Commit | Line | Data |
3b5ca523 |
1 | package Carp; |
ca24dfc6 |
2 | |
3 | =head1 NAME |
4 | |
5 | Carp::Heavy - Carp guts |
6 | |
7 | =head1 SYNOPIS |
8 | |
9 | (internal use only) |
10 | |
11 | =head1 DESCRIPTION |
12 | |
13 | No user-serviceable parts inside. |
14 | |
15 | =cut |
16 | |
3b5ca523 |
17 | # This package is heavily used. Be small. Be fast. Be good. |
18 | |
19 | # Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an |
20 | # _almost_ complete understanding of the package. Corrections and |
21 | # comments are welcome. |
22 | |
23 | # longmess() crawls all the way up the stack reporting on all the function |
24 | # calls made. The error string, $error, is originally constructed from the |
25 | # arguments passed into longmess() via confess(), cluck() or shortmess(). |
26 | # This gets appended with the stack trace messages which are generated for |
27 | # each function call on the stack. |
28 | |
29 | sub longmess_heavy { |
30 | return @_ if ref $_[0]; |
31 | my $error = join '', @_; |
32 | my $mess = ""; |
33 | my $i = 1 + $CarpLevel; |
34 | my ($pack,$file,$line,$sub,$hargs,$eval,$require); |
35 | my (@a); |
36 | # |
37 | # crawl up the stack.... |
38 | # |
39 | while (do { { package DB; @a = caller($i++) } } ) { |
40 | # get copies of the variables returned from caller() |
41 | ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; |
42 | # |
43 | # if the $error error string is newline terminated then it |
44 | # is copied into $mess. Otherwise, $mess gets set (at the end of |
45 | # the 'else {' section below) to one of two things. The first time |
46 | # through, it is set to the "$error at $file line $line" message. |
47 | # $error is then set to 'called' which triggers subsequent loop |
48 | # iterations to append $sub to $mess before appending the "$error |
49 | # at $file line $line" which now actually reads "called at $file line |
50 | # $line". Thus, the stack trace message is constructed: |
51 | # |
52 | # first time: $mess = $error at $file line $line |
53 | # subsequent times: $mess .= $sub $error at $file line $line |
54 | # ^^^^^^ |
55 | # "called" |
56 | if ($error =~ m/\n$/) { |
57 | $mess .= $error; |
58 | } else { |
59 | # Build a string, $sub, which names the sub-routine called. |
60 | # This may also be "require ...", "eval '...' or "eval {...}" |
61 | if (defined $eval) { |
62 | if ($require) { |
63 | $sub = "require $eval"; |
64 | } else { |
65 | $eval =~ s/([\\\'])/\\$1/g; |
66 | if ($MaxEvalLen && length($eval) > $MaxEvalLen) { |
67 | substr($eval,$MaxEvalLen) = '...'; |
68 | } |
69 | $sub = "eval '$eval'"; |
70 | } |
71 | } elsif ($sub eq '(eval)') { |
72 | $sub = 'eval {...}'; |
73 | } |
74 | # if there are any arguments in the sub-routine call, format |
75 | # them according to the format variables defined earlier in |
76 | # this file and join them onto the $sub sub-routine string |
77 | if ($hargs) { |
78 | # we may trash some of the args so we take a copy |
79 | @a = @DB::args; # must get local copy of args |
80 | # don't print any more than $MaxArgNums |
81 | if ($MaxArgNums and @a > $MaxArgNums) { |
82 | # cap the length of $#a and set the last element to '...' |
83 | $#a = $MaxArgNums; |
84 | $a[$#a] = "..."; |
85 | } |
86 | for (@a) { |
87 | # set args to the string "undef" if undefined |
88 | $_ = "undef", next unless defined $_; |
89 | if (ref $_) { |
90 | # dunno what this is for... |
91 | $_ .= ''; |
92 | s/'/\\'/g; |
93 | } |
94 | else { |
95 | s/'/\\'/g; |
96 | # terminate the string early with '...' if too long |
97 | substr($_,$MaxArgLen) = '...' |
98 | if $MaxArgLen and $MaxArgLen < length; |
99 | } |
100 | # 'quote' arg unless it looks like a number |
101 | $_ = "'$_'" unless /^-?[\d.]+$/; |
102 | # print high-end chars as 'M-<char>' |
103 | s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; |
104 | # print remaining control chars as ^<char> |
105 | s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; |
106 | } |
107 | # append ('all', 'the', 'arguments') to the $sub string |
108 | $sub .= '(' . join(', ', @a) . ')'; |
109 | } |
110 | # here's where the error message, $mess, gets constructed |
111 | $mess .= "\t$sub " if $error eq "called"; |
112 | $mess .= "$error at $file line $line"; |
1db3cb89 |
113 | if (defined &Thread::tid) { |
3b5ca523 |
114 | my $tid = Thread->self->tid; |
115 | $mess .= " thread $tid" if $tid; |
116 | } |
117 | $mess .= "\n"; |
118 | } |
119 | # we don't need to print the actual error message again so we can |
120 | # change this to "called" so that the string "$error at $file line |
121 | # $line" makes sense as "called at $file line $line". |
122 | $error = "called"; |
123 | } |
124 | # this kludge circumvents die's incorrect handling of NUL |
125 | my $msg = \($mess || $error); |
126 | $$msg =~ tr/\0//d; |
127 | $$msg; |
128 | } |
129 | |
130 | |
131 | # shortmess() is called by carp() and croak() to skip all the way up to |
132 | # the top-level caller's package and report the error from there. confess() |
133 | # and cluck() generate a full stack trace so they call longmess() to |
134 | # generate that. In verbose mode shortmess() calls longmess() so |
135 | # you always get a stack trace |
136 | |
137 | sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages |
138 | goto &longmess_heavy if $Verbose; |
139 | return @_ if ref $_[0]; |
140 | my $error = join '', @_; |
141 | my ($prevpack) = caller(1); |
142 | my $extra = $CarpLevel; |
143 | my $i = 2; |
144 | my ($pack,$file,$line); |
145 | # when reporting an error, we want to report it from the context of the |
146 | # calling package. So what is the calling package? Within a module, |
147 | # there may be many calls between methods and perhaps between sub-classes |
148 | # and super-classes, but the user isn't interested in what happens |
149 | # inside the package. We start by building a hash array which keeps |
150 | # track of all the packages to which the calling package belongs. We |
151 | # do this by examining its @ISA variable. Any call from a base class |
152 | # method (one of our caller's @ISA packages) can be ignored |
153 | my %isa = ($prevpack,1); |
154 | |
155 | # merge all the caller's @ISA packages into %isa. |
156 | @isa{@{"${prevpack}::ISA"}} = () |
157 | if(@{"${prevpack}::ISA"}); |
158 | |
159 | # now we crawl up the calling stack and look at all the packages in |
160 | # there. For each package, we look to see if it has an @ISA and then |
161 | # we see if our caller features in that list. That would imply that |
162 | # our caller is a derived class of that package and its calls can also |
163 | # be ignored |
164 | while (($pack,$file,$line) = caller($i++)) { |
165 | if(@{$pack . "::ISA"}) { |
166 | my @i = @{$pack . "::ISA"}; |
167 | my %i; |
168 | @i{@i} = (); |
169 | # merge any relevant packages into %isa |
170 | @isa{@i,$pack} = () |
171 | if(exists $i{$prevpack} || exists $isa{$pack}); |
172 | } |
173 | |
174 | # and here's where we do the ignoring... if the package in |
175 | # question is one of our caller's base or derived packages then |
176 | # we can ignore it (skip it) and go onto the next (but note that |
177 | # the continue { } block below gets called every time) |
178 | next |
179 | if(exists $isa{$pack}); |
180 | |
181 | # Hey! We've found a package that isn't one of our caller's |
182 | # clan....but wait, $extra refers to the number of 'extra' levels |
183 | # we should skip up. If $extra > 0 then this is a false alarm. |
184 | # We must merge the package into the %isa hash (so we can ignore it |
185 | # if it pops up again), decrement $extra, and continue. |
186 | if ($extra-- > 0) { |
187 | %isa = ($pack,1); |
188 | @isa{@{$pack . "::ISA"}} = () |
189 | if(@{$pack . "::ISA"}); |
190 | } |
191 | else { |
192 | # OK! We've got a candidate package. Time to construct the |
193 | # relevant error message and return it. die() doesn't like |
194 | # to be given NUL characters (which $msg may contain) so we |
195 | # remove them first. |
196 | my $msg; |
197 | $msg = "$error at $file line $line"; |
1db3cb89 |
198 | if (defined &Thread::tid) { |
3b5ca523 |
199 | my $tid = Thread->self->tid; |
200 | $mess .= " thread $tid" if $tid; |
201 | } |
202 | $msg .= "\n"; |
203 | $msg =~ tr/\0//d; |
204 | return $msg; |
205 | } |
206 | } |
207 | continue { |
208 | $prevpack = $pack; |
209 | } |
210 | |
211 | # uh-oh! It looks like we crawled all the way up the stack and |
212 | # never found a candidate package. Oh well, let's call longmess |
213 | # to generate a full stack trace. We use the magical form of 'goto' |
214 | # so that this shortmess() function doesn't appear on the stack |
215 | # to further confuse longmess() about it's calling package. |
216 | goto &longmess_heavy; |
217 | } |
218 | |
219 | 1; |