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