Commit | Line | Data |
---|---|---|
3b5ca523 GS |
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"; | |
98 | if (exists $main::{'Thread::'}) { | |
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"; | |
183 | if (exists $main::{'Thread::'}) { | |
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; |