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