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