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