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 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 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 5.005_64; 171use Carp; 172 173$VERSION = v1.0; 174 175use Config; 176($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; 177if ($^O eq 'VMS') { 178 require VMS::Filespec; 179 $privlib = VMS::Filespec::unixify($privlib); 180 $archlib = VMS::Filespec::unixify($archlib); 181} 182@trypod = ( 183 "$archlib/pod/perldiag.pod", 184 "$privlib/pod/perldiag-$Config{version}.pod", 185 "$privlib/pod/perldiag.pod", 186 "$archlib/pods/perldiag.pod", 187 "$privlib/pods/perldiag-$Config{version}.pod", 188 "$privlib/pods/perldiag.pod", 189 ); 190# handy for development testing of new warnings etc 191unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; 192($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; 193 194$DEBUG ||= 0; 195my $WHOAMI = ref bless []; # nobody's business, prolly not even mine 196 197$| = 1; 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; 209 Getopt::Std::getopts('pdvf:') 210 or die "Usage: $0 [-v] [-p] [-f splainpod]"; 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 { 289 #local \$^W = 0; # recursive warnings we do NOT need! 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 } 334 335 # strip formatting directives in =item line 336 ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g; 337 338 if ($header =~ /%[csd]/) { 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; 349 $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all 350 } 351 $lhs =~ s/\\%c/./g; 352 $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n"; 353 } else { 354 $transmo .= " m{^\Q$header\E} && return 1;\n"; 355 } 356 357 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n" 358 if $msg{$header}; 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" } 377 while (defined ($error = <>)) { 378 splainthis($error) || print THITHER $error; 379 } 380 exit; 381} else { 382 #$old_w = 0; 383 $oldwarn = ''; $olddie = ''; 384} 385 386sub import { 387 shift; 388 #$old_w = $^W; 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; 424 #$^W = $old_w; 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 } 435 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap; 436}; 437 438sub death_trap { 439 my $exception = $_[0]; 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; 454 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } 455 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; 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; 461 local($Carp::CarpLevel) = 1; 462 confess "Uncaught exception from user code:\n\t$exception"; 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; 470 local $\; 471 ### &finish_compilation unless %msg; 472 s/\.?\n+$//; 473 my $orig = $_; 474 # return unless defined; 475 s/, <.*?> (?:line|chunk).*$//; 476 $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; 477 s/^\((.*)\)$/$1/; 478 if ($exact_duplicate{$orig}++) { 479 return &transmo; 480 } 481 else { 482 return 0 unless &transmo; 483 } 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 { 526 warn "Unknown escape: E<$1> in $_"; 527 "E<$1>"; 528 } 529 } 530 }egx; 531} 532 533sub shorten { 534 my $line = $_[0]; 535 if (length($line) > 79 and index($line, "\n") == -1) { 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 545# have to do this: RS isn't set until run time, but we're executing at compiletime 546$RS = "\n"; 547 5481 unless $standalone; # or it'll complain about itself 549__END__ # wish diag dbase were more accessible 550