1package diagnostics; 2 3=head1 NAME 4 5diagnostics, splain - produce verbose warning diagnostics 6 7=head1 SYNOPSIS 8 9Using the C<diagnostics> pragma: 10 11 use diagnostics; 12 use diagnostics -verbose; 13 14 enable diagnostics; 15 disable diagnostics; 16 17Using the C<splain> standalone filter program: 18 19 perl program 2>diag.out 20 splain [-v] [-p] diag.out 21 22=head1 DESCRIPTION 23 24=head2 The C<diagnostics> Pragma 25 26This module extends the terse diagnostics normally emitted by both the 27perl compiler and the perl interpreter, augmenting them with the more 28explicative and endearing descriptions found in L<perldiag>. Like the 29other pragmata, it affects the compilation phase of your program rather 30than merely the execution phase. 31 32To use in your program as a pragma, merely invoke 33 34 use diagnostics; 35 36at the start (or near the start) of your program. (Note 37that this I<does> enable perl's B<-w> flag.) Your whole 38compilation will then be subject(ed :-) to the enhanced diagnostics. 39These still go out B<STDERR>. 40 41Due to the interaction between runtime and compiletime issues, 42and because it's probably not a very good idea anyway, 43you may not use C<no diagnostics> to turn them off at compiletime. 44However, you may control their behaviour at runtime using the 45disable() and enable() methods to turn them off and on respectively. 46 47The B<-verbose> flag first prints out the L<perldiag> introduction before 48any other diagnostics. The $diagnostics::PRETTY variable can generate nicer 49escape sequences for pagers. 50 51Warnings dispatched from perl itself (or more accurately, those that match 52descriptions found in L<perldiag>) are only displayed once (no duplicate 53descriptions). User code generated warnings a la warn() are unaffected, 54allowing duplicate user messages to be displayed. 55 56=head2 The I<splain> Program 57 58While apparently a whole nuther program, I<splain> is actually nothing 59more than a link to the (executable) F<diagnostics.pm> module, as well as 60a link to the F<diagnostics.pod> documentation. The B<-v> flag is like 61the C<use diagnostics -verbose> directive. 62The B<-p> flag is like the 63$diagnostics::PRETTY variable. Since you're post-processing with 64I<splain>, there's no sense in being able to enable() or disable() processing. 65 66Output from I<splain> is directed to B<STDOUT>, unlike the pragma. 67 68=head1 EXAMPLES 69 70The following file is certain to trigger a few errors at both 71runtime and compiletime: 72 73 use diagnostics; 74 print NOWHERE "nothing\n"; 75 print STDERR "\n\tThis message should be unadorned.\n"; 76 warn "\tThis is a user warning"; 77 print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: "; 78 my $a, $b = scalar <STDIN>; 79 print "\n"; 80 print $x/$y; 81 82If you prefer to run your program first and look at its problem 83afterwards, do this: 84 85 perl -w test.pl 2>test.out 86 ./splain < test.out 87 88Note that this is not in general possible in shells of more dubious heritage, 89as the theoretical 90 91 (perl -w test.pl >/dev/tty) >& test.out 92 ./splain < test.out 93 94Because you just moved the existing B<stdout> to somewhere else. 95 96If you don't want to modify your source code, but still have on-the-fly 97warnings, do this: 98 99 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- 100 101Nifty, eh? 102 103If you want to control warnings on the fly, do something like this. 104Make sure you do the C<use> first, or you won't be able to get 105at the enable() or disable() methods. 106 107 use diagnostics; # checks entire compilation phase 108 print "\ntime for 1st bogus diags: SQUAWKINGS\n"; 109 print BOGUS1 'nada'; 110 print "done with 1st bogus\n"; 111 112 disable diagnostics; # only turns off runtime warnings 113 print "\ntime for 2nd bogus: (squelched)\n"; 114 print BOGUS2 'nada'; 115 print "done with 2nd bogus\n"; 116 117 enable diagnostics; # turns back on runtime warnings 118 print "\ntime for 3rd bogus: SQUAWKINGS\n"; 119 print BOGUS3 'nada'; 120 print "done with 3rd bogus\n"; 121 122 disable diagnostics; 123 print "\ntime for 4th bogus: (squelched)\n"; 124 print BOGUS4 'nada'; 125 print "done with 4th bogus\n"; 126 127=head1 INTERNALS 128 129Diagnostic messages derive from the F<perldiag.pod> file when available at 130runtime. Otherwise, they may be embedded in the file itself when the 131splain package is built. See the F<Makefile> for details. 132 133If an extant $SIG{__WARN__} handler is discovered, it will continue 134to be honored, but only after the diagnostics::splainthis() function 135(the module's $SIG{__WARN__} interceptor) has had its way with your 136warnings. 137 138There is a $diagnostics::DEBUG variable you may set if you're desperately 139curious what sorts of things are being intercepted. 140 141 BEGIN { $diagnostics::DEBUG = 1 } 142 143 144=head1 BUGS 145 146Not being able to say "no diagnostics" is annoying, but may not be 147insurmountable. 148 149The C<-pretty> directive is called too late to affect matters. 150You have to do this instead, and I<before> you load the module. 151 152 BEGIN { $diagnostics::PRETTY = 1 } 153 154I could start up faster by delaying compilation until it should be 155needed, but this gets a "panic: top_level" when using the pragma form 156in Perl 5.001e. 157 158While it's true that this documentation is somewhat subserious, if you use 159a program named I<splain>, you should expect a bit of whimsy. 160 161=head1 AUTHOR 162 163Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. 164 165=cut 166 167use strict; 168use 5.006; 169use Carp; 170 171our $VERSION = 1.12; 172our $DEBUG; 173our $VERBOSE; 174our $PRETTY; 175 176use Config; 177my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; 178if ($^O eq 'VMS') { 179 require VMS::Filespec; 180 $privlib = VMS::Filespec::unixify($privlib); 181 $archlib = VMS::Filespec::unixify($archlib); 182} 183my @trypod = ( 184 "$archlib/pod/perldiag.pod", 185 "$privlib/pod/perldiag-$Config{version}.pod", 186 "$privlib/pod/perldiag.pod", 187 "$archlib/pods/perldiag.pod", 188 "$privlib/pods/perldiag-$Config{version}.pod", 189 "$privlib/pods/perldiag.pod", 190 ); 191# handy for development testing of new warnings etc 192unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; 193(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; 194 195if ($^O eq 'MacOS') { 196 # just updir one from each lib dir, we'll find it ... 197 ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC; 198} 199 200 201$DEBUG ||= 0; 202my $WHOAMI = ref bless []; # nobody's business, prolly not even mine 203 204local $| = 1; 205local $_; 206 207my $standalone; 208my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7); 209 210CONFIG: { 211 our $opt_p = our $opt_d = our $opt_v = our $opt_f = ''; 212 213 unless (caller) { 214 $standalone++; 215 require Getopt::Std; 216 Getopt::Std::getopts('pdvf:') 217 or die "Usage: $0 [-v] [-p] [-f splainpod]"; 218 $PODFILE = $opt_f if $opt_f; 219 $DEBUG = 2 if $opt_d; 220 $VERBOSE = $opt_v; 221 $PRETTY = $opt_p; 222 } 223 224 if (open(POD_DIAG, $PODFILE)) { 225 warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; 226 last CONFIG; 227 } 228 229 if (caller) { 230 INCPATH: { 231 for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { 232 warn "Checking $file\n" if $DEBUG; 233 if (open(POD_DIAG, $file)) { 234 while (<POD_DIAG>) { 235 next unless 236 /^__END__\s*# wish diag dbase were more accessible/; 237 print STDERR "podfile is $file\n" if $DEBUG; 238 last INCPATH; 239 } 240 } 241 } 242 } 243 } else { 244 print STDERR "podfile is <DATA>\n" if $DEBUG; 245 *POD_DIAG = *main::DATA; 246 } 247} 248if (eof(POD_DIAG)) { 249 die "couldn't find diagnostic data in $PODFILE @INC $0"; 250} 251 252 253%HTML_2_Troff = ( 254 'amp' => '&', # ampersand 255 'lt' => '<', # left chevron, less-than 256 'gt' => '>', # right chevron, greater-than 257 'quot' => '"', # double quote 258 259 "Aacute" => "A\\*'", # capital A, acute accent 260 # etc 261 262); 263 264%HTML_2_Latin_1 = ( 265 'amp' => '&', # ampersand 266 'lt' => '<', # left chevron, less-than 267 'gt' => '>', # right chevron, greater-than 268 'quot' => '"', # double quote 269 270 "Aacute" => "\xC1" # capital A, acute accent 271 272 # etc 273); 274 275%HTML_2_ASCII_7 = ( 276 'amp' => '&', # ampersand 277 'lt' => '<', # left chevron, less-than 278 'gt' => '>', # right chevron, greater-than 279 'quot' => '"', # double quote 280 281 "Aacute" => "A" # capital A, acute accent 282 # etc 283); 284 285our %HTML_Escapes; 286*HTML_Escapes = do { 287 if ($standalone) { 288 $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; 289 } else { 290 \%HTML_2_Latin_1; 291 } 292}; 293 294*THITHER = $standalone ? *STDOUT : *STDERR; 295 296my %transfmt = (); 297my $transmo = <<EOFUNC; 298sub transmo { 299 #local \$^W = 0; # recursive warnings we do NOT need! 300 study; 301EOFUNC 302 303my %msg; 304{ 305 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG; 306 local $/ = ''; 307 local $_; 308 my $header; 309 my $for_item; 310 while (<POD_DIAG>) { 311 312 unescape(); 313 if ($PRETTY) { 314 sub noop { return $_[0] } # spensive for a noop 315 sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; } 316 sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; } 317 s/[BC]<(.*?)>/bold($1)/ges; 318 s/[LIF]<(.*?)>/italic($1)/ges; 319 } else { 320 s/[BC]<(.*?)>/$1/gs; 321 s/[LIF]<(.*?)>/$1/gs; 322 } 323 unless (/^=/) { 324 if (defined $header) { 325 if ( $header eq 'DESCRIPTION' && 326 ( /Optional warnings are enabled/ 327 || /Some of these messages are generic./ 328 ) ) 329 { 330 next; 331 } 332 s/^/ /gm; 333 $msg{$header} .= $_; 334 undef $for_item; 335 } 336 next; 337 } 338 unless ( s/=item (.*?)\s*\z//) { 339 340 if ( s/=head1\sDESCRIPTION//) { 341 $msg{$header = 'DESCRIPTION'} = ''; 342 undef $for_item; 343 } 344 elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) { 345 $for_item = $1; 346 } 347 next; 348 } 349 350 if( $for_item ) { $header = $for_item; undef $for_item } 351 else { 352 $header = $1; 353 while( $header =~ /[;,]\z/ ) { 354 <POD_DIAG> =~ /^\s*(.*?)\s*\z/; 355 $header .= ' '.$1; 356 } 357 } 358 359 # strip formatting directives from =item line 360 $header =~ s/[A-Z]<(.*?)>/$1/g; 361 362 my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header ); 363 if (@toks > 1) { 364 my $conlen = 0; 365 for my $i (0..$#toks){ 366 if( $i % 2 ){ 367 if( $toks[$i] eq '%c' ){ 368 $toks[$i] = '.'; 369 } elsif( $toks[$i] eq '%d' ){ 370 $toks[$i] = '\d+'; 371 } elsif( $toks[$i] eq '%s' ){ 372 $toks[$i] = $i == $#toks ? '.*' : '.*?'; 373 } elsif( $toks[$i] =~ '%.(\d+)s' ){ 374 $toks[$i] = ".{$1}"; 375 } elsif( $toks[$i] =~ '^%l*x$' ){ 376 $toks[$i] = '[\da-f]+'; 377 } 378 } elsif( length( $toks[$i] ) ){ 379 $toks[$i] =~ s/^.*$/\Q$&\E/; 380 $conlen += length( $toks[$i] ); 381 } 382 } 383 my $lhs = join( '', @toks ); 384 $transfmt{$header}{pat} = 385 " s{^$lhs}\n {\Q$header\E}s\n\t&& return 1;\n"; 386 $transfmt{$header}{len} = $conlen; 387 } else { 388 $transfmt{$header}{pat} = 389 " m{^\Q$header\E} && return 1;\n"; 390 $transfmt{$header}{len} = length( $header ); 391 } 392 393 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n" 394 if $msg{$header}; 395 396 $msg{$header} = ''; 397 } 398 399 400 close POD_DIAG unless *main::DATA eq *POD_DIAG; 401 402 die "No diagnostics?" unless %msg; 403 404 # Apply patterns in order of decreasing sum of lengths of fixed parts 405 # Seems the best way of hitting the right one. 406 for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} } 407 keys %transfmt ){ 408 $transmo .= $transfmt{$hdr}{pat}; 409 } 410 $transmo .= " return 0;\n}\n"; 411 print STDERR $transmo if $DEBUG; 412 eval $transmo; 413 die $@ if $@; 414} 415 416if ($standalone) { 417 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 418 while (defined (my $error = <>)) { 419 splainthis($error) || print THITHER $error; 420 } 421 exit; 422} 423 424my $olddie; 425my $oldwarn; 426 427sub import { 428 shift; 429 $^W = 1; # yup, clobbered the global variable; 430 # tough, if you want diags, you want diags. 431 return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap); 432 433 for (@_) { 434 435 /^-d(ebug)?$/ && do { 436 $DEBUG++; 437 next; 438 }; 439 440 /^-v(erbose)?$/ && do { 441 $VERBOSE++; 442 next; 443 }; 444 445 /^-p(retty)?$/ && do { 446 print STDERR "$0: I'm afraid it's too late for prettiness.\n"; 447 $PRETTY++; 448 next; 449 }; 450 451 warn "Unknown flag: $_"; 452 } 453 454 $oldwarn = $SIG{__WARN__}; 455 $olddie = $SIG{__DIE__}; 456 $SIG{__WARN__} = \&warn_trap; 457 $SIG{__DIE__} = \&death_trap; 458} 459 460sub enable { &import } 461 462sub disable { 463 shift; 464 return unless $SIG{__WARN__} eq \&warn_trap; 465 $SIG{__WARN__} = $oldwarn || ''; 466 $SIG{__DIE__} = $olddie || ''; 467} 468 469sub warn_trap { 470 my $warning = $_[0]; 471 if (caller eq $WHOAMI or !splainthis($warning)) { 472 print STDERR $warning; 473 } 474 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap; 475}; 476 477sub death_trap { 478 my $exception = $_[0]; 479 480 # See if we are coming from anywhere within an eval. If so we don't 481 # want to explain the exception because it's going to get caught. 482 my $in_eval = 0; 483 my $i = 0; 484 while (1) { 485 my $caller = (caller($i++))[3] or last; 486 if ($caller eq '(eval)') { 487 $in_eval = 1; 488 last; 489 } 490 } 491 492 splainthis($exception) unless $in_eval; 493 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } 494 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; 495 496 return if $in_eval; 497 498 # We don't want to unset these if we're coming from an eval because 499 # then we've turned off diagnostics. 500 501 # Switch off our die/warn handlers so we don't wind up in our own 502 # traps. 503 $SIG{__DIE__} = $SIG{__WARN__} = ''; 504 505 # Have carp skip over death_trap() when showing the stack trace. 506 local($Carp::CarpLevel) = 1; 507 508 confess "Uncaught exception from user code:\n\t$exception"; 509 # up we go; where we stop, nobody knows, but i think we die now 510 # but i'm deeply afraid of the &$olddie guy reraising and us getting 511 # into an indirect recursion loop 512}; 513 514my %exact_duplicate; 515my %old_diag; 516my $count; 517my $wantspace; 518sub splainthis { 519 local $_ = shift; 520 local $\; 521 ### &finish_compilation unless %msg; 522 s/\.?\n+$//; 523 my $orig = $_; 524 # return unless defined; 525 526 # get rid of the where-are-we-in-input part 527 s/, <.*?> (?:line|chunk).*$//; 528 529 # Discard 1st " at <file> line <no>" and all text beyond 530 # but be aware of messsages containing " at this-or-that" 531 my $real = 0; 532 my @secs = split( / at / ); 533 $_ = $secs[0]; 534 for my $i ( 1..$#secs ){ 535 if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){ 536 $real = 1; 537 last; 538 } else { 539 $_ .= ' at ' . $secs[$i]; 540 } 541 } 542 543 # remove parenthesis occurring at the end of some messages 544 s/^\((.*)\)$/$1/; 545 546 if ($exact_duplicate{$orig}++) { 547 return &transmo; 548 } else { 549 return 0 unless &transmo; 550 } 551 552 $orig = shorten($orig); 553 if ($old_diag{$_}) { 554 autodescribe(); 555 print THITHER "$orig (#$old_diag{$_})\n"; 556 $wantspace = 1; 557 } else { 558 autodescribe(); 559 $old_diag{$_} = ++$count; 560 print THITHER "\n" if $wantspace; 561 $wantspace = 0; 562 print THITHER "$orig (#$old_diag{$_})\n"; 563 if ($msg{$_}) { 564 print THITHER $msg{$_}; 565 } else { 566 if (0 and $standalone) { 567 print THITHER " **** Error #$old_diag{$_} ", 568 ($real ? "is" : "appears to be"), 569 " an unknown diagnostic message.\n\n"; 570 } 571 return 0; 572 } 573 } 574 return 1; 575} 576 577sub autodescribe { 578 if ($VERBOSE and not $count) { 579 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"), 580 "\n$msg{DESCRIPTION}\n"; 581 } 582} 583 584sub unescape { 585 s { 586 E< 587 ( [A-Za-z]+ ) 588 > 589 } { 590 do { 591 exists $HTML_Escapes{$1} 592 ? do { $HTML_Escapes{$1} } 593 : do { 594 warn "Unknown escape: E<$1> in $_"; 595 "E<$1>"; 596 } 597 } 598 }egx; 599} 600 601sub shorten { 602 my $line = $_[0]; 603 if (length($line) > 79 and index($line, "\n") == -1) { 604 my $space_place = rindex($line, ' ', 79); 605 if ($space_place != -1) { 606 substr($line, $space_place, 1) = "\n\t"; 607 } 608 } 609 return $line; 610} 611 612 6131 unless $standalone; # or it'll complain about itself 614__END__ # wish diag dbase were more accessible 615