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