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
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 =head1 DESCRIPTION
23
24 =head2 The C<diagnostics> Pragma
25
26 This module extends the terse diagnostics normally emitted by both the
27 perl compiler and the perl interpreter, augmenting them with the more
28 explicative and endearing descriptions found in L<perldiag>.  Like the
29 other pragmata, it affects the compilation phase of your program rather
30 than merely the execution phase.
31
32 To use in your program as a pragma, merely invoke
33
34     use diagnostics;
35
36 at the start (or near the start) of your program.  (Note 
37 that this I<does> enable perl's B<-w> flag.)  Your whole
38 compilation will then be subject(ed :-) to the enhanced diagnostics.
39 These still go out B<STDERR>.
40
41 Due to the interaction between runtime and compiletime issues,
42 and because it's probably not a very good idea anyway,
43 you may not use C<no diagnostics> to turn them off at compiletime.
44 However, you may control their behaviour at runtime using the 
45 disable() and enable() methods to turn them off and on respectively.
46
47 The B<-verbose> flag first prints out the L<perldiag> introduction before
48 any other diagnostics.  The $diagnostics::PRETTY variable can generate nicer
49 escape sequences for pagers.
50
51 Warnings dispatched from perl itself (or more accurately, those that match
52 descriptions found in L<perldiag>) are only displayed once (no duplicate
53 descriptions).  User code generated warnings a la warn() are unaffected,
54 allowing duplicate user messages to be displayed.
55
56 =head2 The I<splain> Program
57
58 While apparently a whole nuther program, I<splain> is actually nothing
59 more than a link to the (executable) F<diagnostics.pm> module, as well as
60 a link to the F<diagnostics.pod> documentation.  The B<-v> flag is like
61 the C<use diagnostics -verbose> directive.
62 The B<-p> flag is like the
63 $diagnostics::PRETTY variable.  Since you're post-processing with 
64 I<splain>, there's no sense in being able to enable() or disable() processing.
65
66 Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
67
68 =head1 EXAMPLES
69
70 The following file is certain to trigger a few errors at both
71 runtime and compiletime:
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
82 If you prefer to run your program first and look at its problem
83 afterwards, do this:
84
85     perl -w test.pl 2>test.out
86     ./splain < test.out
87
88 Note that this is not in general possible in shells of more dubious heritage, 
89 as the theoretical 
90
91     (perl -w test.pl >/dev/tty) >& test.out
92     ./splain < test.out
93
94 Because you just moved the existing B<stdout> to somewhere else.
95
96 If you don't want to modify your source code, but still have on-the-fly
97 warnings, do this:
98
99     exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- 
100
101 Nifty, eh?
102
103 If you want to control warnings on the fly, do something like this.
104 Make sure you do the C<use> first, or you won't be able to get
105 at 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
129 Diagnostic messages derive from the F<perldiag.pod> file when available at
130 runtime.  Otherwise, they may be embedded in the file itself when the
131 splain package is built.   See the F<Makefile> for details.
132
133 If an extant $SIG{__WARN__} handler is discovered, it will continue
134 to be honored, but only after the diagnostics::splainthis() function 
135 (the module's $SIG{__WARN__} interceptor) has had its way with your
136 warnings.
137
138 There is a $diagnostics::DEBUG variable you may set if you're desperately
139 curious what sorts of things are being intercepted.
140
141     BEGIN { $diagnostics::DEBUG = 1 } 
142
143
144 =head1 BUGS
145
146 Not being able to say "no diagnostics" is annoying, but may not be
147 insurmountable.
148
149 The C<-pretty> directive is called too late to affect matters.
150 You have to do this instead, and I<before> you load the module.
151
152     BEGIN { $diagnostics::PRETTY = 1 } 
153
154 I could start up faster by delaying compilation until it should be
155 needed, but this gets a "panic: top_level" when using the pragma form
156 in Perl 5.001e.
157
158 While it's true that this documentation is somewhat subserious, if you use
159 a program named I<splain>, you should expect a bit of whimsy.
160
161 =head1 AUTHOR
162
163 Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
164
165 =cut
166
167 use strict;
168 use 5.006;
169 use Carp;
170
171 our $VERSION = 1.12;
172 our $DEBUG;
173 our $VERBOSE;
174 our $PRETTY;
175
176 use Config;
177 my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
178 if ($^O eq 'VMS') {
179     require VMS::Filespec;
180     $privlib = VMS::Filespec::unixify($privlib);
181     $archlib = VMS::Filespec::unixify($archlib);
182 }
183 my @trypod = (
184            "$archlib/pod/perldiag.pod",
185            "$privlib/pod/perldiag-$Config{version}.pod",
186            "$privlib/pod/perldiag.pod",
187            "$archlib/pods/perldiag.pod",
188            "$privlib/pods/perldiag-$Config{version}.pod",
189            "$privlib/pods/perldiag.pod",
190           );
191 # handy for development testing of new warnings etc
192 unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
193 (my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
194
195 if ($^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
201 $DEBUG ||= 0;
202 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
203
204 local $| = 1;
205 local $_;
206
207 my $standalone;
208 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
209
210 CONFIG: {
211     our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
212
213     unless (caller) {
214         $standalone++;
215         require Getopt::Std;
216         Getopt::Std::getopts('pdvf:')
217             or die "Usage: $0 [-v] [-p] [-f splainpod]";
218         $PODFILE = $opt_f if $opt_f;
219         $DEBUG = 2 if $opt_d;
220         $VERBOSE = $opt_v;
221         $PRETTY = $opt_p;
222     }
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: {
231             for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
232                 warn "Checking $file\n" if $DEBUG;
233                 if (open(POD_DIAG, $file)) {
234                     while (<POD_DIAG>) {
235                         next unless
236                             /^__END__\s*# wish diag dbase were more accessible/;
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 }
248 if (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
285 our %HTML_Escapes;
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
296 my %transfmt = (); 
297 my $transmo = <<EOFUNC;
298 sub transmo {
299     #local \$^W = 0;  # recursive warnings we do NOT need!
300     study;
301 EOFUNC
302
303 my %msg;
304 {
305     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
306     local $/ = '';
307     local $_;
308     my $header;
309     my $for_item;
310     while (<POD_DIAG>) {
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; } 
317             s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
318             s/[LIF]<(.*?)>/italic($1)/ges;
319         } else {
320             s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
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;
331                 }
332                 s/^/    /gm;
333                 $msg{$header} .= $_;
334                 undef $for_item;        
335             }
336             next;
337         } 
338         unless ( s/=item (.*?)\s*\z//) {
339
340             if ( s/=head1\sDESCRIPTION//) {
341                 $msg{$header = 'DESCRIPTION'} = '';
342                 undef $for_item;
343             }
344             elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
345                 $for_item = $1;
346             } 
347             next;
348         }
349
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
359         # strip formatting directives from =item line
360         $header =~ s/[A-Z]<(.*?)>/$1/g;
361
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;
387         } else {
388             $transfmt{$header}{pat} =
389               "    m{^\Q$header\E} && return 1;\n";
390             $transfmt{$header}{len} = length( $header );
391         } 
392
393         print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
394             if $msg{$header};
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
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     }
410     $transmo .= "    return 0;\n}\n";
411     print STDERR $transmo if $DEBUG;
412     eval $transmo;
413     die $@ if $@;
414 }
415
416 if ($standalone) {
417     if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 
418     while (defined (my $error = <>)) {
419         splainthis($error) || print THITHER $error;
420     } 
421     exit;
422
423
424 my $olddie;
425 my $oldwarn;
426
427 sub import {
428     shift;
429     $^W = 1; # yup, clobbered the global variable; 
430              # tough, if you want diags, you want diags.
431     return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
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
460 sub enable { &import }
461
462 sub disable {
463     shift;
464     return unless $SIG{__WARN__} eq \&warn_trap;
465     $SIG{__WARN__} = $oldwarn || '';
466     $SIG{__DIE__} = $olddie || '';
467
468
469 sub warn_trap {
470     my $warning = $_[0];
471     if (caller eq $WHOAMI or !splainthis($warning)) {
472         print STDERR $warning;
473     } 
474     &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
475 };
476
477 sub death_trap {
478     my $exception = $_[0];
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;
493     if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } 
494     &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
495
496     return if $in_eval;
497
498     # We don't want to unset these if we're coming from an eval because
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.
506     local($Carp::CarpLevel) = 1;
507
508     confess "Uncaught exception from user code:\n\t$exception";
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
514 my %exact_duplicate;
515 my %old_diag;
516 my $count;
517 my $wantspace;
518 sub splainthis {
519     local $_ = shift;
520     local $\;
521     ### &finish_compilation unless %msg;
522     s/\.?\n+$//;
523     my $orig = $_;
524     # return unless defined;
525
526     # get rid of the where-are-we-in-input part
527     s/, <.*?> (?:line|chunk).*$//;
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 
544     s/^\((.*)\)$/$1/;
545
546     if ($exact_duplicate{$orig}++) {
547         return &transmo;
548     } else {
549         return 0 unless &transmo;
550     }
551
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
577 sub autodescribe {
578     if ($VERBOSE and not $count) {
579         print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
580                 "\n$msg{DESCRIPTION}\n";
581     } 
582
583
584 sub 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 {
594                     warn "Unknown escape: E<$1> in $_";
595                     "E<$1>";
596                 } 
597          } 
598     }egx;
599 }
600
601 sub shorten {
602     my $line = $_[0];
603     if (length($line) > 79 and index($line, "\n") == -1) {
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
613 1 unless $standalone;  # or it'll complain about itself
614 __END__ # wish diag dbase were more accessible