This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow items in perldiag.pod to match warnings when they have periods at the end
[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 caused the death. The B<-traceonly> (or
63 just B<-t>) flag turns off the explanations 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.009001;
185 use Carp;
186 $Carp::Internal{__PACKAGE__.""}++;
187
188 our $VERSION = '1.22';
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 $DEBUG ||= 0;
215 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
216
217 local $| = 1;
218 my $_;
219 local $.;
220
221 my $standalone;
222 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
223
224 CONFIG: {
225     our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
226
227     unless (caller) {
228         $standalone++;
229         require Getopt::Std;
230         Getopt::Std::getopts('pdvf:')
231             or die "Usage: $0 [-v] [-p] [-f splainpod]";
232         $PODFILE = $opt_f if $opt_f;
233         $DEBUG = 2 if $opt_d;
234         $VERBOSE = $opt_v;
235         $PRETTY = $opt_p;
236     }
237
238     if (open(POD_DIAG, $PODFILE)) {
239         warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
240         last CONFIG;
241     } 
242
243     if (caller) {
244         INCPATH: {
245             for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
246                 warn "Checking $file\n" if $DEBUG;
247                 if (open(POD_DIAG, $file)) {
248                     while (<POD_DIAG>) {
249                         next unless
250                             /^__END__\s*# wish diag dbase were more accessible/;
251                         print STDERR "podfile is $file\n" if $DEBUG;
252                         last INCPATH;
253                     }
254                 }
255             } 
256         }
257     } else { 
258         print STDERR "podfile is <DATA>\n" if $DEBUG;
259         *POD_DIAG = *main::DATA;
260     }
261 }
262 if (eof(POD_DIAG)) { 
263     die "couldn't find diagnostic data in $PODFILE @INC $0";
264 }
265
266
267 %HTML_2_Troff = (
268     'amp'       =>      '&',    #   ampersand
269     'lt'        =>      '<',    #   left chevron, less-than
270     'gt'        =>      '>',    #   right chevron, greater-than
271     'quot'      =>      '"',    #   double quote
272
273     "Aacute"    =>      "A\\*'",        #   capital A, acute accent
274     # etc
275
276 );
277
278 %HTML_2_Latin_1 = (
279     'amp'       =>      '&',    #   ampersand
280     'lt'        =>      '<',    #   left chevron, less-than
281     'gt'        =>      '>',    #   right chevron, greater-than
282     'quot'      =>      '"',    #   double quote
283
284     "Aacute"    =>      "\xC1"  #   capital A, acute accent
285
286     # etc
287 );
288
289 %HTML_2_ASCII_7 = (
290     'amp'       =>      '&',    #   ampersand
291     'lt'        =>      '<',    #   left chevron, less-than
292     'gt'        =>      '>',    #   right chevron, greater-than
293     'quot'      =>      '"',    #   double quote
294
295     "Aacute"    =>      "A"     #   capital A, acute accent
296     # etc
297 );
298
299 our %HTML_Escapes;
300 *HTML_Escapes = do {
301     if ($standalone) {
302         $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; 
303     } else {
304         \%HTML_2_Latin_1; 
305     }
306 }; 
307
308 *THITHER = $standalone ? *STDOUT : *STDERR;
309
310 my %transfmt = (); 
311 my $transmo = <<EOFUNC;
312 sub transmo {
313     #local \$^W = 0;  # recursive warnings we do NOT need!
314     study;
315 EOFUNC
316
317 my %msg;
318 {
319     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
320     local $/ = '';
321     my $header;
322     my @headers;
323     my $for_item;
324     my $seen_body;
325     while (<POD_DIAG>) {
326
327         sub _split_pod_link {
328             $_[0] =~ '(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?';
329             ($1,$2,$4);
330         }
331
332         unescape();
333         if ($PRETTY) {
334             sub noop   { return $_[0] }  # spensive for a noop
335             sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; } 
336             sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; } 
337             s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
338             s/[IF]<(.*?)>/italic($1)/ges;
339             s/L<(.*?)>/
340                my($text,$page,$sect) = _split_pod_link($1);
341                defined $text
342                 ? $text
343                 : defined $sect
344                    ? italic($sect) . ' in ' . italic($page)
345                    : italic($page)
346              /ges;
347         } else {
348             s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
349             s/[IF]<(.*?)>/$1/gs;
350             s/L<(.*?)>/
351                my($text,$page,$sect) = _split_pod_link($1);
352                defined $text
353                 ? $text
354                 : defined $sect
355                    ? qq '"$sect" in $page'
356                    : $page
357              /ges;
358         } 
359         unless (/^=/) {
360             if (defined $header) { 
361                 if ( $header eq 'DESCRIPTION' && 
362                     (   /Optional warnings are enabled/ 
363                      || /Some of these messages are generic./
364                     ) )
365                 {
366                     next;
367                 }
368                 s/^/    /gm;
369                 $msg{$header} .= $_;
370                 for my $h(@headers) { $msg{$h} .= $_ }
371                 ++$seen_body;
372                 undef $for_item;        
373             }
374             next;
375         } 
376
377         # If we have not come across the body of the description yet, then
378         # the previous header needs to share the same description.
379         if ($seen_body) {
380             @headers = ();
381         }
382         else {
383             push @headers, $header if defined $header;
384         }
385
386         unless ( s/=item (.*?)\s*\z//) {
387
388             if ( s/=head1\sDESCRIPTION//) {
389                 $msg{$header = 'DESCRIPTION'} = '';
390                 undef $for_item;
391             }
392             elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
393                 $for_item = $1;
394             } 
395             next;
396         }
397
398         if( $for_item ) { $header = $for_item; undef $for_item } 
399         else {
400             $header = $1;
401             while( $header =~ /[;,]\z/ ) {
402                 <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
403                 $header .= ' '.$1;
404             }
405         }
406
407         # strip formatting directives from =item line
408         $header =~ s/[A-Z]<(.*?)>/$1/g;
409
410         # Since we strip "\.\n" when we search a warning, strip it here as well
411         $header =~ s/\.?$//;
412
413         my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?[fs])/, $header );
414         if (@toks > 1) {
415             my $conlen = 0;
416             for my $i (0..$#toks){
417                 if( $i % 2 ){
418                     if(      $toks[$i] eq '%c' ){
419                         $toks[$i] = '.';
420                     } elsif( $toks[$i] eq '%d' ){
421                         $toks[$i] = '\d+';
422                     } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
423                         $toks[$i] = $i == $#toks ? '.*' : '.*?';
424                     } elsif( $toks[$i] =~ '%.(\d+)s' ){
425                         $toks[$i] = ".{$1}";
426                      } elsif( $toks[$i] =~ '^%l*x$' ){
427                         $toks[$i] = '[\da-f]+';
428                    }
429                 } elsif( length( $toks[$i] ) ){
430                     $toks[$i] = quotemeta $toks[$i];
431                     $conlen += length( $toks[$i] );
432                 }
433             }  
434             my $lhs = join( '', @toks );
435             $transfmt{$header}{pat} =
436               "    s{^$lhs}\n     {\Q$header\E}s\n\t&& return 1;\n";
437             $transfmt{$header}{len} = $conlen;
438         } else {
439             $transfmt{$header}{pat} =
440               "    m{^\Q$header\E} && return 1;\n";
441             $transfmt{$header}{len} = length( $header );
442         } 
443
444         print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
445             if $msg{$header};
446
447         $msg{$header} = '';
448         $seen_body = 0;
449     } 
450
451
452     close POD_DIAG unless *main::DATA eq *POD_DIAG;
453
454     die "No diagnostics?" unless %msg;
455
456     # Apply patterns in order of decreasing sum of lengths of fixed parts
457     # Seems the best way of hitting the right one.
458     for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
459                   keys %transfmt ){
460         $transmo .= $transfmt{$hdr}{pat};
461     }
462     $transmo .= "    return 0;\n}\n";
463     print STDERR $transmo if $DEBUG;
464     eval $transmo;
465     die $@ if $@;
466 }
467
468 if ($standalone) {
469     if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 
470     while (defined (my $error = <>)) {
471         splainthis($error) || print THITHER $error;
472     } 
473     exit;
474
475
476 my $olddie;
477 my $oldwarn;
478
479 sub import {
480     shift;
481     $^W = 1; # yup, clobbered the global variable; 
482              # tough, if you want diags, you want diags.
483     return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
484
485     for (@_) {
486
487         /^-d(ebug)?$/           && do {
488                                     $DEBUG++;
489                                     next;
490                                    };
491
492         /^-v(erbose)?$/         && do {
493                                     $VERBOSE++;
494                                     next;
495                                    };
496
497         /^-p(retty)?$/          && do {
498                                     print STDERR "$0: I'm afraid it's too late for prettiness.\n";
499                                     $PRETTY++;
500                                     next;
501                                };
502         # matches trace and traceonly for legacy doc mixup reasons
503         /^-t(race(only)?)?$/    && do {
504                                     $TRACEONLY++;
505                                     next;
506                                };
507         /^-w(arntrace)?$/       && do {
508                                     $WARNTRACE++;
509                                     next;
510                                };
511
512         warn "Unknown flag: $_";
513     } 
514
515     $oldwarn = $SIG{__WARN__};
516     $olddie = $SIG{__DIE__};
517     $SIG{__WARN__} = \&warn_trap;
518     $SIG{__DIE__} = \&death_trap;
519
520
521 sub enable { &import }
522
523 sub disable {
524     shift;
525     return unless $SIG{__WARN__} eq \&warn_trap;
526     $SIG{__WARN__} = $oldwarn || '';
527     $SIG{__DIE__} = $olddie || '';
528
529
530 sub warn_trap {
531     my $warning = $_[0];
532     if (caller eq $WHOAMI or !splainthis($warning)) {
533         if ($WARNTRACE) {
534             print STDERR Carp::longmess($warning);
535         } else {
536             print STDERR $warning;
537         }
538     } 
539     goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
540 };
541
542 sub death_trap {
543     my $exception = $_[0];
544
545     # See if we are coming from anywhere within an eval. If so we don't
546     # want to explain the exception because it's going to get caught.
547     my $in_eval = 0;
548     my $i = 0;
549     while (my $caller = (caller($i++))[3]) {
550       if ($caller eq '(eval)') {
551         $in_eval = 1;
552         last;
553       }
554     }
555
556     splainthis($exception) unless $in_eval;
557     if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } 
558     &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
559
560     return if $in_eval;
561
562     # We don't want to unset these if we're coming from an eval because
563     # then we've turned off diagnostics.
564
565     # Switch off our die/warn handlers so we don't wind up in our own
566     # traps.
567     $SIG{__DIE__} = $SIG{__WARN__} = '';
568
569     # Have carp skip over death_trap() when showing the stack trace.
570     local($Carp::CarpLevel) = 1;
571
572     confess "Uncaught exception from user code:\n\t$exception";
573         # up we go; where we stop, nobody knows, but i think we die now
574         # but i'm deeply afraid of the &$olddie guy reraising and us getting
575         # into an indirect recursion loop
576 };
577
578 my %exact_duplicate;
579 my %old_diag;
580 my $count;
581 my $wantspace;
582 sub splainthis {
583     return 0 if $TRACEONLY;
584     $_ = shift;
585     local $\;
586     local $!;
587     ### &finish_compilation unless %msg;
588     s/\.?\n+$//;
589     my $orig = $_;
590     # return unless defined;
591
592     # get rid of the where-are-we-in-input part
593     s/, <.*?> (?:line|chunk).*$//;
594
595     # Discard 1st " at <file> line <no>" and all text beyond
596     # but be aware of messages containing " at this-or-that"
597     my $real = 0;
598     my @secs = split( / at / );
599     return unless @secs;
600     $_ = $secs[0];
601     for my $i ( 1..$#secs ){
602         if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
603             $real = 1;
604             last;
605         } else {
606             $_ .= ' at ' . $secs[$i];
607         }
608     }
609     
610     # remove parenthesis occurring at the end of some messages 
611     s/^\((.*)\)$/$1/;
612
613     if ($exact_duplicate{$orig}++) {
614         return &transmo;
615     } else {
616         return 0 unless &transmo;
617     }
618
619     $orig = shorten($orig);
620     if ($old_diag{$_}) {
621         autodescribe();
622         print THITHER "$orig (#$old_diag{$_})\n";
623         $wantspace = 1;
624     } else {
625         autodescribe();
626         $old_diag{$_} = ++$count;
627         print THITHER "\n" if $wantspace;
628         $wantspace = 0;
629         print THITHER "$orig (#$old_diag{$_})\n";
630         if ($msg{$_}) {
631             print THITHER $msg{$_};
632         } else {
633             if (0 and $standalone) { 
634                 print THITHER "    **** Error #$old_diag{$_} ",
635                         ($real ? "is" : "appears to be"),
636                         " an unknown diagnostic message.\n\n";
637             }
638             return 0;
639         } 
640     }
641     return 1;
642
643
644 sub autodescribe {
645     if ($VERBOSE and not $count) {
646         print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
647                 "\n$msg{DESCRIPTION}\n";
648     } 
649
650
651 sub unescape { 
652     s {
653             E<  
654             ( [A-Za-z]+ )       
655             >   
656     } { 
657          do {   
658              exists $HTML_Escapes{$1}
659                 ? do { $HTML_Escapes{$1} }
660                 : do {
661                     warn "Unknown escape: E<$1> in $_";
662                     "E<$1>";
663                 } 
664          } 
665     }egx;
666 }
667
668 sub shorten {
669     my $line = $_[0];
670     if (length($line) > 79 and index($line, "\n") == -1) {
671         my $space_place = rindex($line, ' ', 79);
672         if ($space_place != -1) {
673             substr($line, $space_place, 1) = "\n\t";
674         } 
675     } 
676     return $line;
677
678
679
680 1 unless $standalone;  # or it'll complain about itself
681 __END__ # wish diag dbase were more accessible