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