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