I don't think trying to bracket the hires time with lores
[p5sagit/p5-mst-13.2.git] / lib / diagnostics.pm
CommitLineData
4633a7c4 1package diagnostics;
4633a7c4 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 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 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 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 51any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
52escape sequences for pagers.
4633a7c4 53
097b73fc 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 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 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 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 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 154
155 BEGIN { $diagnostics::PRETTY = 1 }
156
157I could start up faster by delaying compilation until it should be
a6006777 158needed, but this gets a "panic: top_level" when using the pragma form
159in Perl 5.001e.
4633a7c4 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 167
168=cut
169
7a4340ed 170use strict;
3b825e41 171use 5.006;
5f05dabc 172use Carp;
173
88d01e8d 174our $VERSION = 1.1;
7a4340ed 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 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 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 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 204$DEBUG ||= 0;
205my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
206
7a4340ed 207local $| = 1;
4633a7c4 208local $_;
209
7a4340ed 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 217 $standalone++;
218 require Getopt::Std;
91a06757 219 Getopt::Std::getopts('pdvf:')
220 or die "Usage: $0 [-v] [-p] [-f splainpod]";
4633a7c4 221 $PODFILE = $opt_f if $opt_f;
222 $DEBUG = 2 if $opt_d;
223 $VERBOSE = $opt_v;
224 $PRETTY = $opt_p;
7a4340ed 225 }
4633a7c4 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 235 warn "Checking $file\n" if $DEBUG;
236 if (open(POD_DIAG, $file)) {
237 while (<POD_DIAG>) {
7a4340ed 238 next unless
239 /^__END__\s*# wish diag dbase were more accessible/;
4633a7c4 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 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 302 study;
303EOFUNC
304
7a4340ed 305my %msg;
306{
4633a7c4 307 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
7a4340ed 308 local $/ = '';
4633a7c4 309 local $_;
7a4340ed 310 my $header;
311 my $for_item;
4633a7c4 312 while (<POD_DIAG>) {
4633a7c4 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 337 }
338 next;
339 }
7a4340ed 340 unless ( s/=item (.*?)\s*\z//) {
4633a7c4 341
342 if ( s/=head1\sDESCRIPTION//) {
343 $msg{$header = 'DESCRIPTION'} = '';
7a4340ed 344 undef $for_item;
4633a7c4 345 }
7a4340ed 346 elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
347 $for_item = $1;
348 }
4633a7c4 349 next;
350 }
4fdae800 351
5cd5c422 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 365 my $rhs = my $lhs = $header;
366 if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g) {
4633a7c4 367 $lhs =~ s/\\%s/.*?/g;
368 } else {
7a4340ed 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 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 378 } else {
379 $transmo .= " m{^\Q$header\E} && return 1;\n";
380 }
381
eff9c6e2 382 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
383 if $msg{$header};
4633a7c4 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 398
399if ($standalone) {
400 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
7a4340ed 401 while (defined (my $error = <>)) {
4633a7c4 402 splainthis($error) || print THITHER $error;
403 }
404 exit;
7a4340ed 405}
406
407my $olddie;
408my $oldwarn;
4633a7c4 409
410sub import {
411 shift;
7a4340ed 412 $^W = 1; # yup, clobbered the global variable;
413 # tough, if you want diags, you want diags.
4633a7c4 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 448 $SIG{__WARN__} = $oldwarn || '';
449 $SIG{__DIE__} = $olddie || '';
4633a7c4 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 458};
459
460sub death_trap {
461 my $exception = $_[0];
55497cff 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 478
d23f0205 479 return if $in_eval;
480
55497cff 481 # We don't want to unset these if we're coming from an eval because
d23f0205 482 # then we've turned off diagnostics.
483
484 # Switch off our die/warn handlers so we don't wind up in our own
485 # traps.
486 $SIG{__DIE__} = $SIG{__WARN__} = '';
487
488 # Have carp skip over death_trap() when showing the stack trace.
6f48387a 489 local($Carp::CarpLevel) = 1;
d23f0205 490
6f48387a 491 confess "Uncaught exception from user code:\n\t$exception";
4633a7c4 492 # up we go; where we stop, nobody knows, but i think we die now
493 # but i'm deeply afraid of the &$olddie guy reraising and us getting
494 # into an indirect recursion loop
495};
496
7a4340ed 497my %exact_duplicate;
498my %old_diag;
499my $count;
500my $wantspace;
4633a7c4 501sub splainthis {
502 local $_ = shift;
5025c45a 503 local $\;
4633a7c4 504 ### &finish_compilation unless %msg;
505 s/\.?\n+$//;
506 my $orig = $_;
507 # return unless defined;
4633a7c4 508 s/, <.*?> (?:line|chunk).*$//;
7a4340ed 509 my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
4633a7c4 510 s/^\((.*)\)$/$1/;
097b73fc 511 if ($exact_duplicate{$orig}++) {
512 return &transmo;
513 }
514 else {
515 return 0 unless &transmo;
516 }
4633a7c4 517 $orig = shorten($orig);
518 if ($old_diag{$_}) {
519 autodescribe();
520 print THITHER "$orig (#$old_diag{$_})\n";
521 $wantspace = 1;
522 } else {
523 autodescribe();
524 $old_diag{$_} = ++$count;
525 print THITHER "\n" if $wantspace;
526 $wantspace = 0;
527 print THITHER "$orig (#$old_diag{$_})\n";
528 if ($msg{$_}) {
529 print THITHER $msg{$_};
530 } else {
531 if (0 and $standalone) {
532 print THITHER " **** Error #$old_diag{$_} ",
533 ($real ? "is" : "appears to be"),
534 " an unknown diagnostic message.\n\n";
535 }
536 return 0;
537 }
538 }
539 return 1;
540}
541
542sub autodescribe {
543 if ($VERBOSE and not $count) {
544 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
545 "\n$msg{DESCRIPTION}\n";
546 }
547}
548
549sub unescape {
550 s {
551 E<
552 ( [A-Za-z]+ )
553 >
554 } {
555 do {
556 exists $HTML_Escapes{$1}
557 ? do { $HTML_Escapes{$1} }
558 : do {
f02a87df 559 warn "Unknown escape: E<$1> in $_";
4633a7c4 560 "E<$1>";
561 }
562 }
563 }egx;
564}
565
566sub shorten {
567 my $line = $_[0];
774d564b 568 if (length($line) > 79 and index($line, "\n") == -1) {
4633a7c4 569 my $space_place = rindex($line, ' ', 79);
570 if ($space_place != -1) {
571 substr($line, $space_place, 1) = "\n\t";
572 }
573 }
574 return $line;
575}
576
577
4633a7c4 5781 unless $standalone; # or it'll complain about itself
579__END__ # wish diag dbase were more accessible