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