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