This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
avoid warnings in diagnostics.pm; pod tweaks (from Peter Prymmer
[perl5.git] / lib / diagnostics.pm
CommitLineData
4633a7c4 1package diagnostics;
4633a7c4
LW
2
3=head1 NAME
4
5diagnostics - Perl compiler pragma to force verbose warning diagnostics
6
ae2c041d 7splain - standalone program to do the same thing
4633a7c4
LW
8
9=head1 SYNOPSIS
10
11As a pragma:
12
13 use diagnostics;
14 use diagnostics -verbose;
15
16 enable diagnostics;
17 disable diagnostics;
18
19Aa 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
29This module extends the terse diagnostics normally emitted by both the
f610777f 30perl compiler and the perl interpreter, augmenting them with the more
4633a7c4 31explicative and endearing descriptions found in L<perldiag>. Like the
1fef88e7 32other pragmata, it affects the compilation phase of your program rather
4633a7c4
LW
33than merely the execution phase.
34
35To use in your program as a pragma, merely invoke
36
37 use diagnostics;
38
39at the start (or near the start) of your program. (Note
40that this I<does> enable perl's B<-w> flag.) Your whole
41compilation will then be subject(ed :-) to the enhanced diagnostics.
42These still go out B<STDERR>.
43
ae2c041d 44Due to the interaction between runtime and compiletime issues,
4633a7c4 45and because it's probably not a very good idea anyway,
ae2c041d 46you may not use C<no diagnostics> to turn them off at compiletime.
3d0ae7ba 47However, you may control their behaviour at runtime using the
4633a7c4
LW
48disable() and enable() methods to turn them off and on respectively.
49
50The B<-verbose> flag first prints out the L<perldiag> introduction before
1fef88e7
JM
51any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
52escape sequences for pagers.
4633a7c4 53
097b73fc
BB
54Warnings dispatched from perl itself (or more accurately, those that match
55descriptions found in L<perldiag>) are only displayed once (no duplicate
56descriptions). User code generated warnings ala warn() are unaffected,
57allowing duplicate user messages to be displayed.
58
4633a7c4
LW
59=head2 The I<splain> Program
60
61While apparently a whole nuther program, I<splain> is actually nothing
62more than a link to the (executable) F<diagnostics.pm> module, as well as
63a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
64the C<use diagnostics -verbose> directive.
65The B<-p> flag is like the
66$diagnostics::PRETTY variable. Since you're post-processing with
67I<splain>, there's no sense in being able to enable() or disable() processing.
68
69Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
70
71=head1 EXAMPLES
72
73The following file is certain to trigger a few errors at both
ae2c041d 74runtime and compiletime:
4633a7c4
LW
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
85If you prefer to run your program first and look at its problem
86afterwards, do this:
87
88 perl -w test.pl 2>test.out
89 ./splain < test.out
90
91Note that this is not in general possible in shells of more dubious heritage,
1fef88e7 92as the theoretical
4633a7c4
LW
93
94 (perl -w test.pl >/dev/tty) >& test.out
95 ./splain < test.out
96
97Because you just moved the existing B<stdout> to somewhere else.
98
99If you don't want to modify your source code, but still have on-the-fly
100warnings, do this:
101
102 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
103
104Nifty, eh?
105
106If you want to control warnings on the fly, do something like this.
107Make sure you do the C<use> first, or you won't be able to get
108at 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
132Diagnostic messages derive from the F<perldiag.pod> file when available at
133runtime. Otherwise, they may be embedded in the file itself when the
134splain package is built. See the F<Makefile> for details.
135
136If an extant $SIG{__WARN__} handler is discovered, it will continue
1fef88e7 137to be honored, but only after the diagnostics::splainthis() function
4633a7c4
LW
138(the module's $SIG{__WARN__} interceptor) has had its way with your
139warnings.
140
141There is a $diagnostics::DEBUG variable you may set if you're desperately
142curious what sorts of things are being intercepted.
143
144 BEGIN { $diagnostics::DEBUG = 1 }
145
146
147=head1 BUGS
148
149Not being able to say "no diagnostics" is annoying, but may not be
150insurmountable.
151
152The C<-pretty> directive is called too late to affect matters.
864e1151 153You have to do this instead, and I<before> you load the module.
4633a7c4
LW
154
155 BEGIN { $diagnostics::PRETTY = 1 }
156
157I could start up faster by delaying compilation until it should be
a6006777
PP
158needed, but this gets a "panic: top_level" when using the pragma form
159in Perl 5.001e.
4633a7c4
LW
160
161While it's true that this documentation is somewhat subserious, if you use
162a program named I<splain>, you should expect a bit of whimsy.
163
164=head1 AUTHOR
165
352854fa 166Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
4633a7c4
LW
167
168=cut
169
7a4340ed 170use strict;
17f410f9 171use 5.005_64;
5f05dabc
PP
172use Carp;
173
7a4340ed
GS
174our $VERSION = v1.0;
175our $DEBUG;
176our $VERBOSE;
177our $PRETTY;
1e4e2d84 178
5f05dabc 179use Config;
7a4340ed 180my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
5f05dabc 181if ($^O eq 'VMS') {
91a06757
CS
182 require VMS::Filespec;
183 $privlib = VMS::Filespec::unixify($privlib);
184 $archlib = VMS::Filespec::unixify($archlib);
5f05dabc 185}
7a4340ed 186my @trypod = (
7ec2cea4 187 "$archlib/pod/perldiag.pod",
0ff3fa1a 188 "$privlib/pod/perldiag-$Config{version}.pod",
5459498c 189 "$privlib/pod/perldiag.pod",
7ec2cea4 190 "$archlib/pods/perldiag.pod",
0ff3fa1a 191 "$privlib/pods/perldiag-$Config{version}.pod",
5459498c 192 "$privlib/pods/perldiag.pod",
7ec2cea4 193 );
fb73857a
PP
194# handy for development testing of new warnings etc
195unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
7a4340ed 196(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
5f05dabc 197
4633a7c4
LW
198$DEBUG ||= 0;
199my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
200
7a4340ed 201local $| = 1;
4633a7c4
LW
202local $_;
203
7a4340ed
GS
204my $standalone;
205my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
206
4633a7c4 207CONFIG: {
7a4340ed 208 our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
4633a7c4 209
7a4340ed 210 unless (caller) {
4633a7c4
LW
211 $standalone++;
212 require Getopt::Std;
91a06757
CS
213 Getopt::Std::getopts('pdvf:')
214 or die "Usage: $0 [-v] [-p] [-f splainpod]";
4633a7c4
LW
215 $PODFILE = $opt_f if $opt_f;
216 $DEBUG = 2 if $opt_d;
217 $VERBOSE = $opt_v;
218 $PRETTY = $opt_p;
7a4340ed 219 }
4633a7c4
LW
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: {
7a4340ed 228 for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
4633a7c4
LW
229 warn "Checking $file\n" if $DEBUG;
230 if (open(POD_DIAG, $file)) {
231 while (<POD_DIAG>) {
7a4340ed
GS
232 next unless
233 /^__END__\s*# wish diag dbase were more accessible/;
4633a7c4
LW
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}
245if (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
7a4340ed 282our %HTML_Escapes;
4633a7c4
LW
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
7a4340ed 293my $transmo = <<EOFUNC;
4633a7c4 294sub transmo {
599cee73 295 #local \$^W = 0; # recursive warnings we do NOT need!
4633a7c4
LW
296 study;
297EOFUNC
298
7a4340ed
GS
299my %msg;
300{
4633a7c4 301 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
7a4340ed 302 local $/ = '';
4633a7c4 303 local $_;
7a4340ed
GS
304 my $header;
305 my $for_item;
4633a7c4 306 while (<POD_DIAG>) {
4633a7c4
LW
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} .= $_;
7a4340ed 330 undef $for_item;
4633a7c4
LW
331 }
332 next;
333 }
7a4340ed 334 unless ( s/=item (.*?)\s*\z//) {
4633a7c4
LW
335
336 if ( s/=head1\sDESCRIPTION//) {
337 $msg{$header = 'DESCRIPTION'} = '';
7a4340ed 338 undef $for_item;
4633a7c4 339 }
7a4340ed
GS
340 elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
341 $for_item = $1;
342 }
4633a7c4
LW
343 next;
344 }
4fdae800
PP
345
346 # strip formatting directives in =item line
7a4340ed
GS
347 $header = $for_item || $1;
348 undef $for_item;
349 $header =~ s/[A-Z]<(.*?)>/$1/g;
4633a7c4 350
9a7dcd9c 351 if ($header =~ /%[csd]/) {
7a4340ed
GS
352 my $rhs = my $lhs = $header;
353 if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g) {
4633a7c4
LW
354 $lhs =~ s/\\%s/.*?/g;
355 } else {
7a4340ed
GS
356 # if i had lookbehind negations,
357 # i wouldn't have to do this \377 noise
4633a7c4 358 $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
4633a7c4
LW
359 $lhs =~ s/\377([^\377]*)$/\Q$1\E/;
360 $lhs =~ s/\377//g;
e7ea3e70 361 $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
4633a7c4 362 }
9a7dcd9c 363 $lhs =~ s/\\%c/./g;
e7ea3e70 364 $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n";
4633a7c4
LW
365 } else {
366 $transmo .= " m{^\Q$header\E} && return 1;\n";
367 }
368
eff9c6e2
CS
369 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
370 if $msg{$header};
4633a7c4
LW
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 $@;
7a4340ed 384}
4633a7c4
LW
385
386if ($standalone) {
387 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
7a4340ed 388 while (defined (my $error = <>)) {
4633a7c4
LW
389 splainthis($error) || print THITHER $error;
390 }
391 exit;
7a4340ed
GS
392}
393
394my $olddie;
395my $oldwarn;
4633a7c4
LW
396
397sub import {
398 shift;
7a4340ed
GS
399 $^W = 1; # yup, clobbered the global variable;
400 # tough, if you want diags, you want diags.
4633a7c4
LW
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
430sub enable { &import }
431
432sub disable {
433 shift;
4633a7c4 434 return unless $SIG{__WARN__} eq \&warn_trap;
3d0ae7ba
GS
435 $SIG{__WARN__} = $oldwarn || '';
436 $SIG{__DIE__} = $olddie || '';
4633a7c4
LW
437}
438
439sub warn_trap {
440 my $warning = $_[0];
441 if (caller eq $WHOAMI or !splainthis($warning)) {
442 print STDERR $warning;
443 }
37120919 444 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
4633a7c4
LW
445};
446
447sub death_trap {
448 my $exception = $_[0];
55497cff
PP
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;
4633a7c4 463 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
37120919 464 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
55497cff
PP
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;
6f48387a
PP
470 local($Carp::CarpLevel) = 1;
471 confess "Uncaught exception from user code:\n\t$exception";
4633a7c4
LW
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
7a4340ed
GS
477my %exact_duplicate;
478my %old_diag;
479my $count;
480my $wantspace;
4633a7c4
LW
481sub splainthis {
482 local $_ = shift;
5025c45a 483 local $\;
4633a7c4
LW
484 ### &finish_compilation unless %msg;
485 s/\.?\n+$//;
486 my $orig = $_;
487 # return unless defined;
4633a7c4 488 s/, <.*?> (?:line|chunk).*$//;
7a4340ed 489 my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
4633a7c4 490 s/^\((.*)\)$/$1/;
097b73fc
BB
491 if ($exact_duplicate{$orig}++) {
492 return &transmo;
493 }
494 else {
495 return 0 unless &transmo;
496 }
4633a7c4
LW
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
522sub autodescribe {
523 if ($VERBOSE and not $count) {
524 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
525 "\n$msg{DESCRIPTION}\n";
526 }
527}
528
529sub 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 {
f02a87df 539 warn "Unknown escape: E<$1> in $_";
4633a7c4
LW
540 "E<$1>";
541 }
542 }
543 }egx;
544}
545
546sub shorten {
547 my $line = $_[0];
774d564b 548 if (length($line) > 79 and index($line, "\n") == -1) {
4633a7c4
LW
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
4633a7c4
LW
5581 unless $standalone; # or it'll complain about itself
559__END__ # wish diag dbase were more accessible