1package diagnostics; 2 3=head1 NAME 4 5diagnostics - Perl compiler pragma to force verbose warning diagnostics 6 7splain - standalone program to do the same thing 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 30perl compiler and the perl interpreter, augmenting them with the more 31explicative and endearing descriptions found in L<perldiag>. Like the 32other pragmata, it affects the compilation phase of your program rather 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 44Due to the interaction between runtime and compiletime issues, 45and because it's probably not a very good idea anyway, 46you may not use C<no diagnostics> to turn them off at compiletime. 47However, you may control their 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 51any other diagnostics. The $diagnostics::PRETTY variable can generate nicer 52escape sequences for pagers. 53 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 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 74runtime and compiletime: 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, 92as the theoretical 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 137to be honored, but only after the diagnostics::splainthis() function 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. 153You have to do this instead, and I<before> you load the module. 154 155 BEGIN { $diagnostics::PRETTY = 1 } 156 157I could start up faster by delaying compilation until it should be 158needed, but this gets a "panic: top_level" when using the pragma form 159in Perl 5.001e. 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 166Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. 167 168=cut 169 170use strict; 171use 5.006; 172use Carp; 173 174our $VERSION = 1.1; 175our $DEBUG; 176our $VERBOSE; 177our $PRETTY; 178 179use Config; 180my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; 181if ($^O eq 'VMS') { 182 require VMS::Filespec; 183 $privlib = VMS::Filespec::unixify($privlib); 184 $archlib = VMS::Filespec::unixify($archlib); 185} 186my @trypod = ( 187 "$archlib/pod/perldiag.pod", 188 "$privlib/pod/perldiag-$Config{version}.pod", 189 "$privlib/pod/perldiag.pod", 190 "$archlib/pods/perldiag.pod", 191 "$privlib/pods/perldiag-$Config{version}.pod", 192 "$privlib/pods/perldiag.pod", 193 ); 194# handy for development testing of new warnings etc 195unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; 196(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; 197 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 204$DEBUG ||= 0; 205my $WHOAMI = ref bless []; # nobody's business, prolly not even mine 206 207local $| = 1; 208local $_; 209 210my $standalone; 211my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7); 212 213CONFIG: { 214 our $opt_p = our $opt_d = our $opt_v = our $opt_f = ''; 215 216 unless (caller) { 217 $standalone++; 218 require Getopt::Std; 219 Getopt::Std::getopts('pdvf:') 220 or die "Usage: $0 [-v] [-p] [-f splainpod]"; 221 $PODFILE = $opt_f if $opt_f; 222 $DEBUG = 2 if $opt_d; 223 $VERBOSE = $opt_v; 224 $PRETTY = $opt_p; 225 } 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: { 234 for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { 235 warn "Checking $file\n" if $DEBUG; 236 if (open(POD_DIAG, $file)) { 237 while (<POD_DIAG>) { 238 next unless 239 /^__END__\s*# wish diag dbase were more accessible/; 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 288our %HTML_Escapes; 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 299my $transmo = <<EOFUNC; 300sub transmo { 301 #local \$^W = 0; # recursive warnings we do NOT need! 302 study; 303EOFUNC 304 305my %msg; 306{ 307 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG; 308 local $/ = ''; 309 local $_; 310 my $header; 311 my $for_item; 312 while (<POD_DIAG>) { 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} .= $_; 336 undef $for_item; 337 } 338 next; 339 } 340 unless ( s/=item (.*?)\s*\z//) { 341 342 if ( s/=head1\sDESCRIPTION//) { 343 $msg{$header = 'DESCRIPTION'} = ''; 344 undef $for_item; 345 } 346 elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) { 347 $for_item = $1; 348 } 349 next; 350 } 351 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 361 # strip formatting directives in =item line 362 $header =~ s/[A-Z]<(.*?)>/$1/g; 363 364 if ($header =~ /%[csd]/) { 365 my $rhs = my $lhs = $header; 366 if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g) { 367 $lhs =~ s/\\%s/.*?/g; 368 } else { 369 # if i had lookbehind negations, 370 # i wouldn't have to do this \377 noise 371 $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g; 372 $lhs =~ s/\377([^\377]*)$/\Q$1\E/; 373 $lhs =~ s/\377//g; 374 $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all 375 } 376 $lhs =~ s/\\%c/./g; 377 $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n"; 378 } else { 379 $transmo .= " m{^\Q$header\E} && return 1;\n"; 380 } 381 382 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n" 383 if $msg{$header}; 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 $@; 397} 398 399if ($standalone) { 400 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 401 while (defined (my $error = <>)) { 402 splainthis($error) || print THITHER $error; 403 } 404 exit; 405} 406 407my $olddie; 408my $oldwarn; 409 410sub import { 411 shift; 412 $^W = 1; # yup, clobbered the global variable; 413 # tough, if you want diags, you want diags. 414 return if defined $SIG{__WARN__} && ($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; 447 return unless $SIG{__WARN__} eq \&warn_trap; 448 $SIG{__WARN__} = $oldwarn || ''; 449 $SIG{__DIE__} = $olddie || ''; 450} 451 452sub warn_trap { 453 my $warning = $_[0]; 454 if (caller eq $WHOAMI or !splainthis($warning)) { 455 print STDERR $warning; 456 } 457 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap; 458}; 459 460sub death_trap { 461 my $exception = $_[0]; 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; 476 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } 477 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; 478 479 return if $in_eval; 480 481 # We don't want to unset these if we're coming from an eval because 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. 489 local($Carp::CarpLevel) = 1; 490 491 confess "Uncaught exception from user code:\n\t$exception"; 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 497my %exact_duplicate; 498my %old_diag; 499my $count; 500my $wantspace; 501sub splainthis { 502 local $_ = shift; 503 local $\; 504 ### &finish_compilation unless %msg; 505 s/\.?\n+$//; 506 my $orig = $_; 507 # return unless defined; 508 s/, <.*?> (?:line|chunk).*$//; 509 my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; 510 s/^\((.*)\)$/$1/; 511 if ($exact_duplicate{$orig}++) { 512 return &transmo; 513 } 514 else { 515 return 0 unless &transmo; 516 } 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 { 559 warn "Unknown escape: E<$1> in $_"; 560 "E<$1>"; 561 } 562 } 563 }egx; 564} 565 566sub shorten { 567 my $line = $_[0]; 568 if (length($line) > 79 and index($line, "\n") == -1) { 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 5781 unless $standalone; # or it'll complain about itself 579__END__ # wish diag dbase were more accessible 580