| 1 |
root |
1.1 |
package diagnostics; |
| 2 |
|
|
|
| 3 |
|
|
=head1 NAME |
| 4 |
|
|
|
| 5 |
|
|
diagnostics, splain - produce verbose warning diagnostics |
| 6 |
|
|
|
| 7 |
|
|
=head1 SYNOPSIS |
| 8 |
|
|
|
| 9 |
|
|
Using the C<diagnostics> pragma: |
| 10 |
|
|
|
| 11 |
|
|
use diagnostics; |
| 12 |
|
|
use diagnostics -verbose; |
| 13 |
|
|
|
| 14 |
|
|
enable diagnostics; |
| 15 |
|
|
disable diagnostics; |
| 16 |
|
|
|
| 17 |
|
|
Using the C<splain> standalone filter program: |
| 18 |
|
|
|
| 19 |
|
|
perl program 2>diag.out |
| 20 |
|
|
splain [-v] [-p] diag.out |
| 21 |
|
|
|
| 22 |
|
|
Using diagnostics to get stack traces from a misbehaving script: |
| 23 |
|
|
|
| 24 |
|
|
perl -Mdiagnostics=-traceonly my_script.pl |
| 25 |
|
|
|
| 26 |
|
|
=head1 DESCRIPTION |
| 27 |
|
|
|
| 28 |
|
|
=head2 The C<diagnostics> Pragma |
| 29 |
|
|
|
| 30 |
|
|
This module extends the terse diagnostics normally emitted by both the |
| 31 |
|
|
perl compiler and the perl interpreter (from running perl with a -w |
| 32 |
|
|
switch or C<use warnings>), augmenting them with the more |
| 33 |
|
|
explicative and endearing descriptions found in L<perldiag>. Like the |
| 34 |
|
|
other pragmata, it affects the compilation phase of your program rather |
| 35 |
|
|
than merely the execution phase. |
| 36 |
|
|
|
| 37 |
|
|
To use in your program as a pragma, merely invoke |
| 38 |
|
|
|
| 39 |
|
|
use diagnostics; |
| 40 |
|
|
|
| 41 |
|
|
at the start (or near the start) of your program. (Note |
| 42 |
|
|
that this I<does> enable perl's B<-w> flag.) Your whole |
| 43 |
|
|
compilation will then be subject(ed :-) to the enhanced diagnostics. |
| 44 |
|
|
These still go out B<STDERR>. |
| 45 |
|
|
|
| 46 |
|
|
Due to the interaction between runtime and compiletime issues, |
| 47 |
|
|
and because it's probably not a very good idea anyway, |
| 48 |
|
|
you may not use C<no diagnostics> to turn them off at compiletime. |
| 49 |
|
|
However, you may control their behaviour at runtime using the |
| 50 |
|
|
disable() and enable() methods to turn them off and on respectively. |
| 51 |
|
|
|
| 52 |
|
|
The B<-verbose> flag first prints out the L<perldiag> introduction before |
| 53 |
|
|
any other diagnostics. The $diagnostics::PRETTY variable can generate nicer |
| 54 |
|
|
escape sequences for pagers. |
| 55 |
|
|
|
| 56 |
|
|
Warnings dispatched from perl itself (or more accurately, those that match |
| 57 |
|
|
descriptions found in L<perldiag>) are only displayed once (no duplicate |
| 58 |
|
|
descriptions). User code generated warnings a la warn() are unaffected, |
| 59 |
|
|
allowing duplicate user messages to be displayed. |
| 60 |
|
|
|
| 61 |
|
|
This module also adds a stack trace to the error message when perl dies. |
| 62 |
|
|
This is useful for pinpointing what caused the death. The B<-traceonly> (or |
| 63 |
|
|
just B<-t>) flag turns off the explantions of warning messages leaving just |
| 64 |
|
|
the stack traces. So if your script is dieing, run it again with |
| 65 |
|
|
|
| 66 |
|
|
perl -Mdiagnostics=-traceonly my_bad_script |
| 67 |
|
|
|
| 68 |
|
|
to see the call stack at the time of death. By supplying the B<-warntrace> |
| 69 |
|
|
(or just B<-w>) flag, any warnings emitted will also come with a stack |
| 70 |
|
|
trace. |
| 71 |
|
|
|
| 72 |
|
|
=head2 The I<splain> Program |
| 73 |
|
|
|
| 74 |
|
|
While apparently a whole nuther program, I<splain> is actually nothing |
| 75 |
|
|
more than a link to the (executable) F<diagnostics.pm> module, as well as |
| 76 |
|
|
a link to the F<diagnostics.pod> documentation. The B<-v> flag is like |
| 77 |
|
|
the C<use diagnostics -verbose> directive. |
| 78 |
|
|
The B<-p> flag is like the |
| 79 |
|
|
$diagnostics::PRETTY variable. Since you're post-processing with |
| 80 |
|
|
I<splain>, there's no sense in being able to enable() or disable() processing. |
| 81 |
|
|
|
| 82 |
|
|
Output from I<splain> is directed to B<STDOUT>, unlike the pragma. |
| 83 |
|
|
|
| 84 |
|
|
=head1 EXAMPLES |
| 85 |
|
|
|
| 86 |
|
|
The following file is certain to trigger a few errors at both |
| 87 |
|
|
runtime and compiletime: |
| 88 |
|
|
|
| 89 |
|
|
use diagnostics; |
| 90 |
|
|
print NOWHERE "nothing\n"; |
| 91 |
|
|
print STDERR "\n\tThis message should be unadorned.\n"; |
| 92 |
|
|
warn "\tThis is a user warning"; |
| 93 |
|
|
print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: "; |
| 94 |
|
|
my $a, $b = scalar <STDIN>; |
| 95 |
|
|
print "\n"; |
| 96 |
|
|
print $x/$y; |
| 97 |
|
|
|
| 98 |
|
|
If you prefer to run your program first and look at its problem |
| 99 |
|
|
afterwards, do this: |
| 100 |
|
|
|
| 101 |
|
|
perl -w test.pl 2>test.out |
| 102 |
|
|
./splain < test.out |
| 103 |
|
|
|
| 104 |
|
|
Note that this is not in general possible in shells of more dubious heritage, |
| 105 |
|
|
as the theoretical |
| 106 |
|
|
|
| 107 |
|
|
(perl -w test.pl >/dev/tty) >& test.out |
| 108 |
|
|
./splain < test.out |
| 109 |
|
|
|
| 110 |
|
|
Because you just moved the existing B<stdout> to somewhere else. |
| 111 |
|
|
|
| 112 |
|
|
If you don't want to modify your source code, but still have on-the-fly |
| 113 |
|
|
warnings, do this: |
| 114 |
|
|
|
| 115 |
|
|
exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- |
| 116 |
|
|
|
| 117 |
|
|
Nifty, eh? |
| 118 |
|
|
|
| 119 |
|
|
If you want to control warnings on the fly, do something like this. |
| 120 |
|
|
Make sure you do the C<use> first, or you won't be able to get |
| 121 |
|
|
at the enable() or disable() methods. |
| 122 |
|
|
|
| 123 |
|
|
use diagnostics; # checks entire compilation phase |
| 124 |
|
|
print "\ntime for 1st bogus diags: SQUAWKINGS\n"; |
| 125 |
|
|
print BOGUS1 'nada'; |
| 126 |
|
|
print "done with 1st bogus\n"; |
| 127 |
|
|
|
| 128 |
|
|
disable diagnostics; # only turns off runtime warnings |
| 129 |
|
|
print "\ntime for 2nd bogus: (squelched)\n"; |
| 130 |
|
|
print BOGUS2 'nada'; |
| 131 |
|
|
print "done with 2nd bogus\n"; |
| 132 |
|
|
|
| 133 |
|
|
enable diagnostics; # turns back on runtime warnings |
| 134 |
|
|
print "\ntime for 3rd bogus: SQUAWKINGS\n"; |
| 135 |
|
|
print BOGUS3 'nada'; |
| 136 |
|
|
print "done with 3rd bogus\n"; |
| 137 |
|
|
|
| 138 |
|
|
disable diagnostics; |
| 139 |
|
|
print "\ntime for 4th bogus: (squelched)\n"; |
| 140 |
|
|
print BOGUS4 'nada'; |
| 141 |
|
|
print "done with 4th bogus\n"; |
| 142 |
|
|
|
| 143 |
|
|
=head1 INTERNALS |
| 144 |
|
|
|
| 145 |
|
|
Diagnostic messages derive from the F<perldiag.pod> file when available at |
| 146 |
|
|
runtime. Otherwise, they may be embedded in the file itself when the |
| 147 |
|
|
splain package is built. See the F<Makefile> for details. |
| 148 |
|
|
|
| 149 |
|
|
If an extant $SIG{__WARN__} handler is discovered, it will continue |
| 150 |
|
|
to be honored, but only after the diagnostics::splainthis() function |
| 151 |
|
|
(the module's $SIG{__WARN__} interceptor) has had its way with your |
| 152 |
|
|
warnings. |
| 153 |
|
|
|
| 154 |
|
|
There is a $diagnostics::DEBUG variable you may set if you're desperately |
| 155 |
|
|
curious what sorts of things are being intercepted. |
| 156 |
|
|
|
| 157 |
|
|
BEGIN { $diagnostics::DEBUG = 1 } |
| 158 |
|
|
|
| 159 |
|
|
|
| 160 |
|
|
=head1 BUGS |
| 161 |
|
|
|
| 162 |
|
|
Not being able to say "no diagnostics" is annoying, but may not be |
| 163 |
|
|
insurmountable. |
| 164 |
|
|
|
| 165 |
|
|
The C<-pretty> directive is called too late to affect matters. |
| 166 |
|
|
You have to do this instead, and I<before> you load the module. |
| 167 |
|
|
|
| 168 |
|
|
BEGIN { $diagnostics::PRETTY = 1 } |
| 169 |
|
|
|
| 170 |
|
|
I could start up faster by delaying compilation until it should be |
| 171 |
|
|
needed, but this gets a "panic: top_level" when using the pragma form |
| 172 |
|
|
in Perl 5.001e. |
| 173 |
|
|
|
| 174 |
|
|
While it's true that this documentation is somewhat subserious, if you use |
| 175 |
|
|
a program named I<splain>, you should expect a bit of whimsy. |
| 176 |
|
|
|
| 177 |
|
|
=head1 AUTHOR |
| 178 |
|
|
|
| 179 |
|
|
Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. |
| 180 |
|
|
|
| 181 |
|
|
=cut |
| 182 |
|
|
|
| 183 |
|
|
use strict; |
| 184 |
|
|
use 5.006; |
| 185 |
|
|
use Carp; |
| 186 |
|
|
$Carp::Internal{__PACKAGE__.""}++; |
| 187 |
|
|
|
| 188 |
|
|
our $VERSION = 1.14; |
| 189 |
|
|
our $DEBUG; |
| 190 |
|
|
our $VERBOSE; |
| 191 |
|
|
our $PRETTY; |
| 192 |
|
|
our $TRACEONLY = 0; |
| 193 |
|
|
our $WARNTRACE = 0; |
| 194 |
|
|
|
| 195 |
|
|
use Config; |
| 196 |
|
|
my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; |
| 197 |
|
|
if ($^O eq 'VMS') { |
| 198 |
|
|
require VMS::Filespec; |
| 199 |
|
|
$privlib = VMS::Filespec::unixify($privlib); |
| 200 |
|
|
$archlib = VMS::Filespec::unixify($archlib); |
| 201 |
|
|
} |
| 202 |
|
|
my @trypod = ( |
| 203 |
|
|
"$archlib/pod/perldiag.pod", |
| 204 |
|
|
"$privlib/pod/perldiag-$Config{version}.pod", |
| 205 |
|
|
"$privlib/pod/perldiag.pod", |
| 206 |
|
|
"$archlib/pods/perldiag.pod", |
| 207 |
|
|
"$privlib/pods/perldiag-$Config{version}.pod", |
| 208 |
|
|
"$privlib/pods/perldiag.pod", |
| 209 |
|
|
); |
| 210 |
|
|
# handy for development testing of new warnings etc |
| 211 |
|
|
unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; |
| 212 |
|
|
(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; |
| 213 |
|
|
|
| 214 |
|
|
if ($^O eq 'MacOS') { |
| 215 |
|
|
# just updir one from each lib dir, we'll find it ... |
| 216 |
|
|
($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC; |
| 217 |
|
|
} |
| 218 |
|
|
|
| 219 |
|
|
|
| 220 |
|
|
$DEBUG ||= 0; |
| 221 |
|
|
my $WHOAMI = ref bless []; # nobody's business, prolly not even mine |
| 222 |
|
|
|
| 223 |
|
|
local $| = 1; |
| 224 |
|
|
local $_; |
| 225 |
|
|
|
| 226 |
|
|
my $standalone; |
| 227 |
|
|
my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7); |
| 228 |
|
|
|
| 229 |
|
|
CONFIG: { |
| 230 |
|
|
our $opt_p = our $opt_d = our $opt_v = our $opt_f = ''; |
| 231 |
|
|
|
| 232 |
|
|
unless (caller) { |
| 233 |
|
|
$standalone++; |
| 234 |
|
|
require Getopt::Std; |
| 235 |
|
|
Getopt::Std::getopts('pdvf:') |
| 236 |
|
|
or die "Usage: $0 [-v] [-p] [-f splainpod]"; |
| 237 |
|
|
$PODFILE = $opt_f if $opt_f; |
| 238 |
|
|
$DEBUG = 2 if $opt_d; |
| 239 |
|
|
$VERBOSE = $opt_v; |
| 240 |
|
|
$PRETTY = $opt_p; |
| 241 |
|
|
} |
| 242 |
|
|
|
| 243 |
|
|
if (open(POD_DIAG, $PODFILE)) { |
| 244 |
|
|
warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; |
| 245 |
|
|
last CONFIG; |
| 246 |
|
|
} |
| 247 |
|
|
|
| 248 |
|
|
if (caller) { |
| 249 |
|
|
INCPATH: { |
| 250 |
|
|
for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { |
| 251 |
|
|
warn "Checking $file\n" if $DEBUG; |
| 252 |
|
|
if (open(POD_DIAG, $file)) { |
| 253 |
|
|
while (<POD_DIAG>) { |
| 254 |
|
|
next unless |
| 255 |
|
|
/^__END__\s*# wish diag dbase were more accessible/; |
| 256 |
|
|
print STDERR "podfile is $file\n" if $DEBUG; |
| 257 |
|
|
last INCPATH; |
| 258 |
|
|
} |
| 259 |
|
|
} |
| 260 |
|
|
} |
| 261 |
|
|
} |
| 262 |
|
|
} else { |
| 263 |
|
|
print STDERR "podfile is <DATA>\n" if $DEBUG; |
| 264 |
|
|
*POD_DIAG = *main::DATA; |
| 265 |
|
|
} |
| 266 |
|
|
} |
| 267 |
|
|
if (eof(POD_DIAG)) { |
| 268 |
|
|
die "couldn't find diagnostic data in $PODFILE @INC $0"; |
| 269 |
|
|
} |
| 270 |
|
|
|
| 271 |
|
|
|
| 272 |
|
|
%HTML_2_Troff = ( |
| 273 |
|
|
'amp' => '&', # ampersand |
| 274 |
|
|
'lt' => '<', # left chevron, less-than |
| 275 |
|
|
'gt' => '>', # right chevron, greater-than |
| 276 |
|
|
'quot' => '"', # double quote |
| 277 |
|
|
|
| 278 |
|
|
"Aacute" => "A\\*'", # capital A, acute accent |
| 279 |
|
|
# etc |
| 280 |
|
|
|
| 281 |
|
|
); |
| 282 |
|
|
|
| 283 |
|
|
%HTML_2_Latin_1 = ( |
| 284 |
|
|
'amp' => '&', # ampersand |
| 285 |
|
|
'lt' => '<', # left chevron, less-than |
| 286 |
|
|
'gt' => '>', # right chevron, greater-than |
| 287 |
|
|
'quot' => '"', # double quote |
| 288 |
|
|
|
| 289 |
|
|
"Aacute" => "\xC1" # capital A, acute accent |
| 290 |
|
|
|
| 291 |
|
|
# etc |
| 292 |
|
|
); |
| 293 |
|
|
|
| 294 |
|
|
%HTML_2_ASCII_7 = ( |
| 295 |
|
|
'amp' => '&', # ampersand |
| 296 |
|
|
'lt' => '<', # left chevron, less-than |
| 297 |
|
|
'gt' => '>', # right chevron, greater-than |
| 298 |
|
|
'quot' => '"', # double quote |
| 299 |
|
|
|
| 300 |
|
|
"Aacute" => "A" # capital A, acute accent |
| 301 |
|
|
# etc |
| 302 |
|
|
); |
| 303 |
|
|
|
| 304 |
|
|
our %HTML_Escapes; |
| 305 |
|
|
*HTML_Escapes = do { |
| 306 |
|
|
if ($standalone) { |
| 307 |
|
|
$PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; |
| 308 |
|
|
} else { |
| 309 |
|
|
\%HTML_2_Latin_1; |
| 310 |
|
|
} |
| 311 |
|
|
}; |
| 312 |
|
|
|
| 313 |
|
|
*THITHER = $standalone ? *STDOUT : *STDERR; |
| 314 |
|
|
|
| 315 |
|
|
my %transfmt = (); |
| 316 |
|
|
my $transmo = <<EOFUNC; |
| 317 |
|
|
sub transmo { |
| 318 |
|
|
#local \$^W = 0; # recursive warnings we do NOT need! |
| 319 |
|
|
study; |
| 320 |
|
|
EOFUNC |
| 321 |
|
|
|
| 322 |
|
|
my %msg; |
| 323 |
|
|
{ |
| 324 |
|
|
print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG; |
| 325 |
|
|
local $/ = ''; |
| 326 |
|
|
local $_; |
| 327 |
|
|
my $header; |
| 328 |
|
|
my $for_item; |
| 329 |
|
|
while (<POD_DIAG>) { |
| 330 |
|
|
|
| 331 |
|
|
unescape(); |
| 332 |
|
|
if ($PRETTY) { |
| 333 |
|
|
sub noop { return $_[0] } # spensive for a noop |
| 334 |
|
|
sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; } |
| 335 |
|
|
sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; } |
| 336 |
|
|
s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges; |
| 337 |
|
|
s/[LIF]<(.*?)>/italic($1)/ges; |
| 338 |
|
|
} else { |
| 339 |
|
|
s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs; |
| 340 |
|
|
s/[LIF]<(.*?)>/$1/gs; |
| 341 |
|
|
} |
| 342 |
|
|
unless (/^=/) { |
| 343 |
|
|
if (defined $header) { |
| 344 |
|
|
if ( $header eq 'DESCRIPTION' && |
| 345 |
|
|
( /Optional warnings are enabled/ |
| 346 |
|
|
|| /Some of these messages are generic./ |
| 347 |
|
|
) ) |
| 348 |
|
|
{ |
| 349 |
|
|
next; |
| 350 |
|
|
} |
| 351 |
|
|
s/^/ /gm; |
| 352 |
|
|
$msg{$header} .= $_; |
| 353 |
|
|
undef $for_item; |
| 354 |
|
|
} |
| 355 |
|
|
next; |
| 356 |
|
|
} |
| 357 |
|
|
unless ( s/=item (.*?)\s*\z//) { |
| 358 |
|
|
|
| 359 |
|
|
if ( s/=head1\sDESCRIPTION//) { |
| 360 |
|
|
$msg{$header = 'DESCRIPTION'} = ''; |
| 361 |
|
|
undef $for_item; |
| 362 |
|
|
} |
| 363 |
|
|
elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) { |
| 364 |
|
|
$for_item = $1; |
| 365 |
|
|
} |
| 366 |
|
|
next; |
| 367 |
|
|
} |
| 368 |
|
|
|
| 369 |
|
|
if( $for_item ) { $header = $for_item; undef $for_item } |
| 370 |
|
|
else { |
| 371 |
|
|
$header = $1; |
| 372 |
|
|
while( $header =~ /[;,]\z/ ) { |
| 373 |
|
|
<POD_DIAG> =~ /^\s*(.*?)\s*\z/; |
| 374 |
|
|
$header .= ' '.$1; |
| 375 |
|
|
} |
| 376 |
|
|
} |
| 377 |
|
|
|
| 378 |
|
|
# strip formatting directives from =item line |
| 379 |
|
|
$header =~ s/[A-Z]<(.*?)>/$1/g; |
| 380 |
|
|
|
| 381 |
|
|
my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header ); |
| 382 |
|
|
if (@toks > 1) { |
| 383 |
|
|
my $conlen = 0; |
| 384 |
|
|
for my $i (0..$#toks){ |
| 385 |
|
|
if( $i % 2 ){ |
| 386 |
|
|
if( $toks[$i] eq '%c' ){ |
| 387 |
|
|
$toks[$i] = '.'; |
| 388 |
|
|
} elsif( $toks[$i] eq '%d' ){ |
| 389 |
|
|
$toks[$i] = '\d+'; |
| 390 |
|
|
} elsif( $toks[$i] eq '%s' ){ |
| 391 |
|
|
$toks[$i] = $i == $#toks ? '.*' : '.*?'; |
| 392 |
|
|
} elsif( $toks[$i] =~ '%.(\d+)s' ){ |
| 393 |
|
|
$toks[$i] = ".{$1}"; |
| 394 |
|
|
} elsif( $toks[$i] =~ '^%l*x$' ){ |
| 395 |
|
|
$toks[$i] = '[\da-f]+'; |
| 396 |
|
|
} |
| 397 |
|
|
} elsif( length( $toks[$i] ) ){ |
| 398 |
|
|
$toks[$i] =~ s/^.*$/\Q$&\E/; |
| 399 |
|
|
$conlen += length( $toks[$i] ); |
| 400 |
|
|
} |
| 401 |
|
|
} |
| 402 |
|
|
my $lhs = join( '', @toks ); |
| 403 |
|
|
$transfmt{$header}{pat} = |
| 404 |
|
|
" s{^$lhs}\n {\Q$header\E}s\n\t&& return 1;\n"; |
| 405 |
|
|
$transfmt{$header}{len} = $conlen; |
| 406 |
|
|
} else { |
| 407 |
|
|
$transfmt{$header}{pat} = |
| 408 |
|
|
" m{^\Q$header\E} && return 1;\n"; |
| 409 |
|
|
$transfmt{$header}{len} = length( $header ); |
| 410 |
|
|
} |
| 411 |
|
|
|
| 412 |
|
|
print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n" |
| 413 |
|
|
if $msg{$header}; |
| 414 |
|
|
|
| 415 |
|
|
$msg{$header} = ''; |
| 416 |
|
|
} |
| 417 |
|
|
|
| 418 |
|
|
|
| 419 |
|
|
close POD_DIAG unless *main::DATA eq *POD_DIAG; |
| 420 |
|
|
|
| 421 |
|
|
die "No diagnostics?" unless %msg; |
| 422 |
|
|
|
| 423 |
|
|
# Apply patterns in order of decreasing sum of lengths of fixed parts |
| 424 |
|
|
# Seems the best way of hitting the right one. |
| 425 |
|
|
for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} } |
| 426 |
|
|
keys %transfmt ){ |
| 427 |
|
|
$transmo .= $transfmt{$hdr}{pat}; |
| 428 |
|
|
} |
| 429 |
|
|
$transmo .= " return 0;\n}\n"; |
| 430 |
|
|
print STDERR $transmo if $DEBUG; |
| 431 |
|
|
eval $transmo; |
| 432 |
|
|
die $@ if $@; |
| 433 |
|
|
} |
| 434 |
|
|
|
| 435 |
|
|
if ($standalone) { |
| 436 |
|
|
if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } |
| 437 |
|
|
while (defined (my $error = <>)) { |
| 438 |
|
|
splainthis($error) || print THITHER $error; |
| 439 |
|
|
} |
| 440 |
|
|
exit; |
| 441 |
|
|
} |
| 442 |
|
|
|
| 443 |
|
|
my $olddie; |
| 444 |
|
|
my $oldwarn; |
| 445 |
|
|
|
| 446 |
|
|
sub import { |
| 447 |
|
|
shift; |
| 448 |
|
|
$^W = 1; # yup, clobbered the global variable; |
| 449 |
|
|
# tough, if you want diags, you want diags. |
| 450 |
|
|
return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap); |
| 451 |
|
|
|
| 452 |
|
|
for (@_) { |
| 453 |
|
|
|
| 454 |
|
|
/^-d(ebug)?$/ && do { |
| 455 |
|
|
$DEBUG++; |
| 456 |
|
|
next; |
| 457 |
|
|
}; |
| 458 |
|
|
|
| 459 |
|
|
/^-v(erbose)?$/ && do { |
| 460 |
|
|
$VERBOSE++; |
| 461 |
|
|
next; |
| 462 |
|
|
}; |
| 463 |
|
|
|
| 464 |
|
|
/^-p(retty)?$/ && do { |
| 465 |
|
|
print STDERR "$0: I'm afraid it's too late for prettiness.\n"; |
| 466 |
|
|
$PRETTY++; |
| 467 |
|
|
next; |
| 468 |
|
|
}; |
| 469 |
|
|
|
| 470 |
|
|
/^-t(race)?$/ && do { |
| 471 |
|
|
$TRACEONLY++; |
| 472 |
|
|
next; |
| 473 |
|
|
}; |
| 474 |
|
|
/^-w(arntrace)?$/ && do { |
| 475 |
|
|
$WARNTRACE++; |
| 476 |
|
|
next; |
| 477 |
|
|
}; |
| 478 |
|
|
|
| 479 |
|
|
warn "Unknown flag: $_"; |
| 480 |
|
|
} |
| 481 |
|
|
|
| 482 |
|
|
$oldwarn = $SIG{__WARN__}; |
| 483 |
|
|
$olddie = $SIG{__DIE__}; |
| 484 |
|
|
$SIG{__WARN__} = \&warn_trap; |
| 485 |
|
|
$SIG{__DIE__} = \&death_trap; |
| 486 |
|
|
} |
| 487 |
|
|
|
| 488 |
|
|
sub enable { &import } |
| 489 |
|
|
|
| 490 |
|
|
sub disable { |
| 491 |
|
|
shift; |
| 492 |
|
|
return unless $SIG{__WARN__} eq \&warn_trap; |
| 493 |
|
|
$SIG{__WARN__} = $oldwarn || ''; |
| 494 |
|
|
$SIG{__DIE__} = $olddie || ''; |
| 495 |
|
|
} |
| 496 |
|
|
|
| 497 |
|
|
sub warn_trap { |
| 498 |
|
|
my $warning = $_[0]; |
| 499 |
|
|
if (caller eq $WHOAMI or !splainthis($warning)) { |
| 500 |
|
|
if ($WARNTRACE) { |
| 501 |
|
|
print STDERR Carp::longmess($warning); |
| 502 |
|
|
} else { |
| 503 |
|
|
print STDERR $warning; |
| 504 |
|
|
} |
| 505 |
|
|
} |
| 506 |
|
|
goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap; |
| 507 |
|
|
}; |
| 508 |
|
|
|
| 509 |
|
|
sub death_trap { |
| 510 |
|
|
my $exception = $_[0]; |
| 511 |
|
|
|
| 512 |
|
|
# See if we are coming from anywhere within an eval. If so we don't |
| 513 |
|
|
# want to explain the exception because it's going to get caught. |
| 514 |
|
|
my $in_eval = 0; |
| 515 |
|
|
my $i = 0; |
| 516 |
|
|
while (my $caller = (caller($i++))[3]) { |
| 517 |
|
|
if ($caller eq '(eval)') { |
| 518 |
|
|
$in_eval = 1; |
| 519 |
|
|
last; |
| 520 |
|
|
} |
| 521 |
|
|
} |
| 522 |
|
|
|
| 523 |
|
|
splainthis($exception) unless $in_eval; |
| 524 |
|
|
if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } |
| 525 |
|
|
&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; |
| 526 |
|
|
|
| 527 |
|
|
return if $in_eval; |
| 528 |
|
|
|
| 529 |
|
|
# We don't want to unset these if we're coming from an eval because |
| 530 |
|
|
# then we've turned off diagnostics. |
| 531 |
|
|
|
| 532 |
|
|
# Switch off our die/warn handlers so we don't wind up in our own |
| 533 |
|
|
# traps. |
| 534 |
|
|
$SIG{__DIE__} = $SIG{__WARN__} = ''; |
| 535 |
|
|
|
| 536 |
|
|
# Have carp skip over death_trap() when showing the stack trace. |
| 537 |
|
|
local($Carp::CarpLevel) = 1; |
| 538 |
|
|
|
| 539 |
|
|
confess "Uncaught exception from user code:\n\t$exception"; |
| 540 |
|
|
# up we go; where we stop, nobody knows, but i think we die now |
| 541 |
|
|
# but i'm deeply afraid of the &$olddie guy reraising and us getting |
| 542 |
|
|
# into an indirect recursion loop |
| 543 |
|
|
}; |
| 544 |
|
|
|
| 545 |
|
|
my %exact_duplicate; |
| 546 |
|
|
my %old_diag; |
| 547 |
|
|
my $count; |
| 548 |
|
|
my $wantspace; |
| 549 |
|
|
sub splainthis { |
| 550 |
|
|
return 0 if $TRACEONLY; |
| 551 |
|
|
local $_ = shift; |
| 552 |
|
|
local $\; |
| 553 |
|
|
### &finish_compilation unless %msg; |
| 554 |
|
|
s/\.?\n+$//; |
| 555 |
|
|
my $orig = $_; |
| 556 |
|
|
# return unless defined; |
| 557 |
|
|
|
| 558 |
|
|
# get rid of the where-are-we-in-input part |
| 559 |
|
|
s/, <.*?> (?:line|chunk).*$//; |
| 560 |
|
|
|
| 561 |
|
|
# Discard 1st " at <file> line <no>" and all text beyond |
| 562 |
|
|
# but be aware of messsages containing " at this-or-that" |
| 563 |
|
|
my $real = 0; |
| 564 |
|
|
my @secs = split( / at / ); |
| 565 |
|
|
$_ = $secs[0]; |
| 566 |
|
|
for my $i ( 1..$#secs ){ |
| 567 |
|
|
if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){ |
| 568 |
|
|
$real = 1; |
| 569 |
|
|
last; |
| 570 |
|
|
} else { |
| 571 |
|
|
$_ .= ' at ' . $secs[$i]; |
| 572 |
|
|
} |
| 573 |
|
|
} |
| 574 |
|
|
|
| 575 |
|
|
# remove parenthesis occurring at the end of some messages |
| 576 |
|
|
s/^\((.*)\)$/$1/; |
| 577 |
|
|
|
| 578 |
|
|
if ($exact_duplicate{$orig}++) { |
| 579 |
|
|
return &transmo; |
| 580 |
|
|
} else { |
| 581 |
|
|
return 0 unless &transmo; |
| 582 |
|
|
} |
| 583 |
|
|
|
| 584 |
|
|
$orig = shorten($orig); |
| 585 |
|
|
if ($old_diag{$_}) { |
| 586 |
|
|
autodescribe(); |
| 587 |
|
|
print THITHER "$orig (#$old_diag{$_})\n"; |
| 588 |
|
|
$wantspace = 1; |
| 589 |
|
|
} else { |
| 590 |
|
|
autodescribe(); |
| 591 |
|
|
$old_diag{$_} = ++$count; |
| 592 |
|
|
print THITHER "\n" if $wantspace; |
| 593 |
|
|
$wantspace = 0; |
| 594 |
|
|
print THITHER "$orig (#$old_diag{$_})\n"; |
| 595 |
|
|
if ($msg{$_}) { |
| 596 |
|
|
print THITHER $msg{$_}; |
| 597 |
|
|
} else { |
| 598 |
|
|
if (0 and $standalone) { |
| 599 |
|
|
print THITHER " **** Error #$old_diag{$_} ", |
| 600 |
|
|
($real ? "is" : "appears to be"), |
| 601 |
|
|
" an unknown diagnostic message.\n\n"; |
| 602 |
|
|
} |
| 603 |
|
|
return 0; |
| 604 |
|
|
} |
| 605 |
|
|
} |
| 606 |
|
|
return 1; |
| 607 |
|
|
} |
| 608 |
|
|
|
| 609 |
|
|
sub autodescribe { |
| 610 |
|
|
if ($VERBOSE and not $count) { |
| 611 |
|
|
print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"), |
| 612 |
|
|
"\n$msg{DESCRIPTION}\n"; |
| 613 |
|
|
} |
| 614 |
|
|
} |
| 615 |
|
|
|
| 616 |
|
|
sub unescape { |
| 617 |
|
|
s { |
| 618 |
|
|
E< |
| 619 |
|
|
( [A-Za-z]+ ) |
| 620 |
|
|
> |
| 621 |
|
|
} { |
| 622 |
|
|
do { |
| 623 |
|
|
exists $HTML_Escapes{$1} |
| 624 |
|
|
? do { $HTML_Escapes{$1} } |
| 625 |
|
|
: do { |
| 626 |
|
|
warn "Unknown escape: E<$1> in $_"; |
| 627 |
|
|
"E<$1>"; |
| 628 |
|
|
} |
| 629 |
|
|
} |
| 630 |
|
|
}egx; |
| 631 |
|
|
} |
| 632 |
|
|
|
| 633 |
|
|
sub shorten { |
| 634 |
|
|
my $line = $_[0]; |
| 635 |
|
|
if (length($line) > 79 and index($line, "\n") == -1) { |
| 636 |
|
|
my $space_place = rindex($line, ' ', 79); |
| 637 |
|
|
if ($space_place != -1) { |
| 638 |
|
|
substr($line, $space_place, 1) = "\n\t"; |
| 639 |
|
|
} |
| 640 |
|
|
} |
| 641 |
|
|
return $line; |
| 642 |
|
|
} |
| 643 |
|
|
|
| 644 |
|
|
|
| 645 |
|
|
1 unless $standalone; # or it'll complain about itself |
| 646 |
|
|
__END__ # wish diag dbase were more accessible |
