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