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