RE: Combining UTF-16 output with :crlf is awkward
[perl.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.006;
185 use Carp;
186 $Carp::Internal{__PACKAGE__.""}++;
187
188 our $VERSION = 1.16;
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         # matches trace and traceonly for legacy doc mixup reasons
470         /^-t(race(only)?)?$/    && 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     return unless @secs;
566     $_ = $secs[0];
567     for my $i ( 1..$#secs ){
568         if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
569             $real = 1;
570             last;
571         } else {
572             $_ .= ' at ' . $secs[$i];
573         }
574     }
575     
576     # remove parenthesis occurring at the end of some messages 
577     s/^\((.*)\)$/$1/;
578
579     if ($exact_duplicate{$orig}++) {
580         return &transmo;
581     } else {
582         return 0 unless &transmo;
583     }
584
585     $orig = shorten($orig);
586     if ($old_diag{$_}) {
587         autodescribe();
588         print THITHER "$orig (#$old_diag{$_})\n";
589         $wantspace = 1;
590     } else {
591         autodescribe();
592         $old_diag{$_} = ++$count;
593         print THITHER "\n" if $wantspace;
594         $wantspace = 0;
595         print THITHER "$orig (#$old_diag{$_})\n";
596         if ($msg{$_}) {
597             print THITHER $msg{$_};
598         } else {
599             if (0 and $standalone) { 
600                 print THITHER "    **** Error #$old_diag{$_} ",
601                         ($real ? "is" : "appears to be"),
602                         " an unknown diagnostic message.\n\n";
603             }
604             return 0;
605         } 
606     }
607     return 1;
608
609
610 sub autodescribe {
611     if ($VERBOSE and not $count) {
612         print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
613                 "\n$msg{DESCRIPTION}\n";
614     } 
615
616
617 sub unescape { 
618     s {
619             E<  
620             ( [A-Za-z]+ )       
621             >   
622     } { 
623          do {   
624              exists $HTML_Escapes{$1}
625                 ? do { $HTML_Escapes{$1} }
626                 : do {
627                     warn "Unknown escape: E<$1> in $_";
628                     "E<$1>";
629                 } 
630          } 
631     }egx;
632 }
633
634 sub shorten {
635     my $line = $_[0];
636     if (length($line) > 79 and index($line, "\n") == -1) {
637         my $space_place = rindex($line, ' ', 79);
638         if ($space_place != -1) {
639             substr($line, $space_place, 1) = "\n\t";
640         } 
641     } 
642     return $line;
643
644
645
646 1 unless $standalone;  # or it'll complain about itself
647 __END__ # wish diag dbase were more accessible