Introduce NVef, NVff, and NVgf, use the middle one.
[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.005_64;
172 use Carp;
173
174 our $VERSION = v1.0;
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 $DEBUG ||= 0;
199 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
200
201 local $| = 1;
202 local $_;
203
204 my $standalone;
205 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
206
207 CONFIG: {
208     our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
209
210     unless (caller) {
211         $standalone++;
212         require Getopt::Std;
213         Getopt::Std::getopts('pdvf:')
214             or die "Usage: $0 [-v] [-p] [-f splainpod]";
215         $PODFILE = $opt_f if $opt_f;
216         $DEBUG = 2 if $opt_d;
217         $VERBOSE = $opt_v;
218         $PRETTY = $opt_p;
219     }
220
221     if (open(POD_DIAG, $PODFILE)) {
222         warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
223         last CONFIG;
224     } 
225
226     if (caller) {
227         INCPATH: {
228             for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
229                 warn "Checking $file\n" if $DEBUG;
230                 if (open(POD_DIAG, $file)) {
231                     while (<POD_DIAG>) {
232                         next unless
233                             /^__END__\s*# wish diag dbase were more accessible/;
234                         print STDERR "podfile is $file\n" if $DEBUG;
235                         last INCPATH;
236                     }
237                 }
238             } 
239         }
240     } else { 
241         print STDERR "podfile is <DATA>\n" if $DEBUG;
242         *POD_DIAG = *main::DATA;
243     }
244 }
245 if (eof(POD_DIAG)) { 
246     die "couldn't find diagnostic data in $PODFILE @INC $0";
247 }
248
249
250 %HTML_2_Troff = (
251     'amp'       =>      '&',    #   ampersand
252     'lt'        =>      '<',    #   left chevron, less-than
253     'gt'        =>      '>',    #   right chevron, greater-than
254     'quot'      =>      '"',    #   double quote
255
256     "Aacute"    =>      "A\\*'",        #   capital A, acute accent
257     # etc
258
259 );
260
261 %HTML_2_Latin_1 = (
262     'amp'       =>      '&',    #   ampersand
263     'lt'        =>      '<',    #   left chevron, less-than
264     'gt'        =>      '>',    #   right chevron, greater-than
265     'quot'      =>      '"',    #   double quote
266
267     "Aacute"    =>      "\xC1"  #   capital A, acute accent
268
269     # etc
270 );
271
272 %HTML_2_ASCII_7 = (
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 our %HTML_Escapes;
283 *HTML_Escapes = do {
284     if ($standalone) {
285         $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; 
286     } else {
287         \%HTML_2_Latin_1; 
288     }
289 }; 
290
291 *THITHER = $standalone ? *STDOUT : *STDERR;
292
293 my $transmo = <<EOFUNC;
294 sub transmo {
295     #local \$^W = 0;  # recursive warnings we do NOT need!
296     study;
297 EOFUNC
298
299 my %msg;
300 {
301     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
302     local $/ = '';
303     local $_;
304     my $header;
305     my $for_item;
306     while (<POD_DIAG>) {
307
308         unescape();
309         if ($PRETTY) {
310             sub noop   { return $_[0] }  # spensive for a noop
311             sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; } 
312             sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; } 
313             s/[BC]<(.*?)>/bold($1)/ges;
314             s/[LIF]<(.*?)>/italic($1)/ges;
315         } else {
316             s/[BC]<(.*?)>/$1/gs;
317             s/[LIF]<(.*?)>/$1/gs;
318         } 
319         unless (/^=/) {
320             if (defined $header) { 
321                 if ( $header eq 'DESCRIPTION' && 
322                     (   /Optional warnings are enabled/ 
323                      || /Some of these messages are generic./
324                     ) )
325                 {
326                     next;
327                 } 
328                 s/^/    /gm;
329                 $msg{$header} .= $_;
330                 undef $for_item;        
331             }
332             next;
333         } 
334         unless ( s/=item (.*?)\s*\z//) {
335
336             if ( s/=head1\sDESCRIPTION//) {
337                 $msg{$header = 'DESCRIPTION'} = '';
338                 undef $for_item;
339             }
340             elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
341                 $for_item = $1;
342             } 
343             next;
344         }
345
346         # strip formatting directives in =item line
347         $header = $for_item || $1;
348         undef $for_item;        
349         $header =~ s/[A-Z]<(.*?)>/$1/g;
350
351         if ($header =~ /%[csd]/) {
352             my $rhs = my $lhs = $header;
353             if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g)  {
354                 $lhs =~ s/\\%s/.*?/g;
355             } else {
356                 # if i had lookbehind negations,
357                 # i wouldn't have to do this \377 noise
358                 $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
359                 $lhs =~ s/\377([^\377]*)$/\Q$1\E/;
360                 $lhs =~ s/\377//g;
361                 $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
362             } 
363             $lhs =~ s/\\%c/./g;
364             $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}s\n\t&& return 1;\n";
365         } else {
366             $transmo .= "    m{^\Q$header\E} && return 1;\n";
367         } 
368
369         print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
370             if $msg{$header};
371
372         $msg{$header} = '';
373     } 
374
375
376     close POD_DIAG unless *main::DATA eq *POD_DIAG;
377
378     die "No diagnostics?" unless %msg;
379
380     $transmo .= "    return 0;\n}\n";
381     print STDERR $transmo if $DEBUG;
382     eval $transmo;
383     die $@ if $@;
384 }
385
386 if ($standalone) {
387     if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 
388     while (defined (my $error = <>)) {
389         splainthis($error) || print THITHER $error;
390     } 
391     exit;
392
393
394 my $olddie;
395 my $oldwarn;
396
397 sub import {
398     shift;
399     $^W = 1; # yup, clobbered the global variable; 
400              # tough, if you want diags, you want diags.
401     return if $SIG{__WARN__} eq \&warn_trap;
402
403     for (@_) {
404
405         /^-d(ebug)?$/           && do {
406                                     $DEBUG++;
407                                     next;
408                                    };
409
410         /^-v(erbose)?$/         && do {
411                                     $VERBOSE++;
412                                     next;
413                                    };
414
415         /^-p(retty)?$/          && do {
416                                     print STDERR "$0: I'm afraid it's too late for prettiness.\n";
417                                     $PRETTY++;
418                                     next;
419                                };
420
421         warn "Unknown flag: $_";
422     } 
423
424     $oldwarn = $SIG{__WARN__};
425     $olddie = $SIG{__DIE__};
426     $SIG{__WARN__} = \&warn_trap;
427     $SIG{__DIE__} = \&death_trap;
428
429
430 sub enable { &import }
431
432 sub disable {
433     shift;
434     return unless $SIG{__WARN__} eq \&warn_trap;
435     $SIG{__WARN__} = $oldwarn || '';
436     $SIG{__DIE__} = $olddie || '';
437
438
439 sub warn_trap {
440     my $warning = $_[0];
441     if (caller eq $WHOAMI or !splainthis($warning)) {
442         print STDERR $warning;
443     } 
444     &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
445 };
446
447 sub death_trap {
448     my $exception = $_[0];
449
450     # See if we are coming from anywhere within an eval. If so we don't
451     # want to explain the exception because it's going to get caught.
452     my $in_eval = 0;
453     my $i = 0;
454     while (1) {
455       my $caller = (caller($i++))[3] or last;
456       if ($caller eq '(eval)') {
457         $in_eval = 1;
458         last;
459       }
460     }
461
462     splainthis($exception) unless $in_eval;
463     if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } 
464     &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
465
466     # We don't want to unset these if we're coming from an eval because
467     # then we've turned off diagnostics. (Actually what does this next
468     # line do?  -PSeibel)
469     $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
470     local($Carp::CarpLevel) = 1;
471     confess "Uncaught exception from user code:\n\t$exception";
472         # up we go; where we stop, nobody knows, but i think we die now
473         # but i'm deeply afraid of the &$olddie guy reraising and us getting
474         # into an indirect recursion loop
475 };
476
477 my %exact_duplicate;
478 my %old_diag;
479 my $count;
480 my $wantspace;
481 sub splainthis {
482     local $_ = shift;
483     local $\;
484     ### &finish_compilation unless %msg;
485     s/\.?\n+$//;
486     my $orig = $_;
487     # return unless defined;
488     s/, <.*?> (?:line|chunk).*$//;
489     my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
490     s/^\((.*)\)$/$1/;
491     if ($exact_duplicate{$orig}++) {
492         return &transmo;
493     }
494     else {
495         return 0 unless &transmo;
496     }
497     $orig = shorten($orig);
498     if ($old_diag{$_}) {
499         autodescribe();
500         print THITHER "$orig (#$old_diag{$_})\n";
501         $wantspace = 1;
502     } else {
503         autodescribe();
504         $old_diag{$_} = ++$count;
505         print THITHER "\n" if $wantspace;
506         $wantspace = 0;
507         print THITHER "$orig (#$old_diag{$_})\n";
508         if ($msg{$_}) {
509             print THITHER $msg{$_};
510         } else {
511             if (0 and $standalone) { 
512                 print THITHER "    **** Error #$old_diag{$_} ",
513                         ($real ? "is" : "appears to be"),
514                         " an unknown diagnostic message.\n\n";
515             }
516             return 0;
517         } 
518     }
519     return 1;
520
521
522 sub autodescribe {
523     if ($VERBOSE and not $count) {
524         print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
525                 "\n$msg{DESCRIPTION}\n";
526     } 
527
528
529 sub unescape { 
530     s {
531             E<  
532             ( [A-Za-z]+ )       
533             >   
534     } { 
535          do {   
536              exists $HTML_Escapes{$1}
537                 ? do { $HTML_Escapes{$1} }
538                 : do {
539                     warn "Unknown escape: E<$1> in $_";
540                     "E<$1>";
541                 } 
542          } 
543     }egx;
544 }
545
546 sub shorten {
547     my $line = $_[0];
548     if (length($line) > 79 and index($line, "\n") == -1) {
549         my $space_place = rindex($line, ' ', 79);
550         if ($space_place != -1) {
551             substr($line, $space_place, 1) = "\n\t";
552         } 
553     } 
554     return $line;
555
556
557
558 1 unless $standalone;  # or it'll complain about itself
559 __END__ # wish diag dbase were more accessible