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 interpeter, 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 54=head2 The I<splain> Program 55 56While apparently a whole nuther program, I<splain> is actually nothing 57more than a link to the (executable) F<diagnostics.pm> module, as well as 58a link to the F<diagnostics.pod> documentation. The B<-v> flag is like 59the C<use diagnostics -verbose> directive. 60The B<-p> flag is like the 61$diagnostics::PRETTY variable. Since you're post-processing with 62I<splain>, there's no sense in being able to enable() or disable() processing. 63 64Output from I<splain> is directed to B<STDOUT>, unlike the pragma. 65 66=head1 EXAMPLES 67 68The following file is certain to trigger a few errors at both 69runtime and compiletime: 70 71 use diagnostics; 72 print NOWHERE "nothing\n"; 73 print STDERR "\n\tThis message should be unadorned.\n"; 74 warn "\tThis is a user warning"; 75 print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: "; 76 my $a, $b = scalar <STDIN>; 77 print "\n"; 78 print $x/$y; 79 80If you prefer to run your program first and look at its problem 81afterwards, do this: 82 83 perl -w test.pl 2>test.out 84 ./splain < test.out 85 86Note that this is not in general possible in shells of more dubious heritage, 87as the theoretical 88 89 (perl -w test.pl >/dev/tty) >& test.out 90 ./splain < test.out 91 92Because you just moved the existing B<stdout> to somewhere else. 93 94If you don't want to modify your source code, but still have on-the-fly 95warnings, do this: 96 97 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- 98 99Nifty, eh? 100 101If you want to control warnings on the fly, do something like this. 102Make sure you do the C<use> first, or you won't be able to get 103at the enable() or disable() methods. 104 105 use diagnostics; # checks entire compilation phase 106 print "\ntime for 1st bogus diags: SQUAWKINGS\n"; 107 print BOGUS1 'nada'; 108 print "done with 1st bogus\n"; 109 110 disable diagnostics; # only turns off runtime warnings 111 print "\ntime for 2nd bogus: (squelched)\n"; 112 print BOGUS2 'nada'; 113 print "done with 2nd bogus\n"; 114 115 enable diagnostics; # turns back on runtime warnings 116 print "\ntime for 3rd bogus: SQUAWKINGS\n"; 117 print BOGUS3 'nada'; 118 print "done with 3rd bogus\n"; 119 120 disable diagnostics; 121 print "\ntime for 4th bogus: (squelched)\n"; 122 print BOGUS4 'nada'; 123 print "done with 4th bogus\n"; 124 125=head1 INTERNALS 126 127Diagnostic messages derive from the F<perldiag.pod> file when available at 128runtime. Otherwise, they may be embedded in the file itself when the 129splain package is built. See the F<Makefile> for details. 130 131If an extant $SIG{__WARN__} handler is discovered, it will continue 132to be honored, but only after the diagnostics::splainthis() function 133(the module's $SIG{__WARN__} interceptor) has had its way with your 134warnings. 135 136There is a $diagnostics::DEBUG variable you may set if you're desperately 137curious what sorts of things are being intercepted. 138 139 BEGIN { $diagnostics::DEBUG = 1 } 140 141 142=head1 BUGS 143 144Not being able to say "no diagnostics" is annoying, but may not be 145insurmountable. 146 147The C<-pretty> directive is called too late to affect matters. 148You have to do this instead, and I<before> you load the module. 149 150 BEGIN { $diagnostics::PRETTY = 1 } 151 152I could start up faster by delaying compilation until it should be 153needed, but this gets a "panic: top_level" when using the pragma form 154in Perl 5.001e. 155 156While it's true that this documentation is somewhat subserious, if you use 157a program named I<splain>, you should expect a bit of whimsy. 158 159=head1 AUTHOR 160 161Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. 162 163=cut 164 165require 5.001; 166use Carp; 167 168use Config; 169($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; 170if ($^O eq 'VMS') { 171 require VMS::Filespec; 172 $privlib = VMS::Filespec::unixify($privlib); 173 $archlib = VMS::Filespec::unixify($archlib); 174} 175@trypod = ("$archlib/pod/perldiag.pod", 176 "$privlib/pod/perldiag-$].pod", 177 "$privlib/pod/perldiag.pod"); 178# handy for development testing of new warnings etc 179unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; 180($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; 181 182$DEBUG ||= 0; 183my $WHOAMI = ref bless []; # nobody's business, prolly not even mine 184 185$| = 1; 186 187local $_; 188 189CONFIG: { 190 $opt_p = $opt_d = $opt_v = $opt_f = ''; 191 %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = (); 192 %exact_duplicate = (); 193 194 unless (caller) { 195 $standalone++; 196 require Getopt::Std; 197 Getopt::Std::getopts('pdvf:') 198 or die "Usage: $0 [-v] [-p] [-f splainpod]"; 199 $PODFILE = $opt_f if $opt_f; 200 $DEBUG = 2 if $opt_d; 201 $VERBOSE = $opt_v; 202 $PRETTY = $opt_p; 203 } 204 205 if (open(POD_DIAG, $PODFILE)) { 206 warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; 207 last CONFIG; 208 } 209 210 if (caller) { 211 INCPATH: { 212 for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { 213 warn "Checking $file\n" if $DEBUG; 214 if (open(POD_DIAG, $file)) { 215 while (<POD_DIAG>) { 216 next unless /^__END__\s*# wish diag dbase were more accessible/; 217 print STDERR "podfile is $file\n" if $DEBUG; 218 last INCPATH; 219 } 220 } 221 } 222 } 223 } else { 224 print STDERR "podfile is <DATA>\n" if $DEBUG; 225 *POD_DIAG = *main::DATA; 226 } 227} 228if (eof(POD_DIAG)) { 229 die "couldn't find diagnostic data in $PODFILE @INC $0"; 230} 231 232 233%HTML_2_Troff = ( 234 'amp' => '&', # ampersand 235 'lt' => '<', # left chevron, less-than 236 'gt' => '>', # right chevron, greater-than 237 'quot' => '"', # double quote 238 239 "Aacute" => "A\\*'", # capital A, acute accent 240 # etc 241 242); 243 244%HTML_2_Latin_1 = ( 245 'amp' => '&', # ampersand 246 'lt' => '<', # left chevron, less-than 247 'gt' => '>', # right chevron, greater-than 248 'quot' => '"', # double quote 249 250 "Aacute" => "\xC1" # capital A, acute accent 251 252 # etc 253); 254 255%HTML_2_ASCII_7 = ( 256 'amp' => '&', # ampersand 257 'lt' => '<', # left chevron, less-than 258 'gt' => '>', # right chevron, greater-than 259 'quot' => '"', # double quote 260 261 "Aacute" => "A" # capital A, acute accent 262 # etc 263); 264 265*HTML_Escapes = do { 266 if ($standalone) { 267 $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; 268 } else { 269 \%HTML_2_Latin_1; 270 } 271}; 272 273*THITHER = $standalone ? *STDOUT : *STDERR; 274 275$transmo = <<EOFUNC; 276sub transmo { 277 local \$^W = 0; # recursive warnings we do NOT need! 278 study; 279EOFUNC 280 281### sub finish_compilation { # 5.001e panic: top_level for embedded version 282 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG; 283 ### local 284 $RS = ''; 285 local $_; 286 while (<POD_DIAG>) { 287 #s/(.*)\n//; 288 #$header = $1; 289 290 unescape(); 291 if ($PRETTY) { 292 sub noop { return $_[0] } # spensive for a noop 293 sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; } 294 sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; } 295 s/[BC]<(.*?)>/bold($1)/ges; 296 s/[LIF]<(.*?)>/italic($1)/ges; 297 } else { 298 s/[BC]<(.*?)>/$1/gs; 299 s/[LIF]<(.*?)>/$1/gs; 300 } 301 unless (/^=/) { 302 if (defined $header) { 303 if ( $header eq 'DESCRIPTION' && 304 ( /Optional warnings are enabled/ 305 || /Some of these messages are generic./ 306 ) ) 307 { 308 next; 309 } 310 s/^/ /gm; 311 $msg{$header} .= $_; 312 } 313 next; 314 } 315 unless ( s/=item (.*)\s*\Z//) { 316 317 if ( s/=head1\sDESCRIPTION//) { 318 $msg{$header = 'DESCRIPTION'} = ''; 319 } 320 next; 321 } 322 323 # strip formatting directives in =item line 324 ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g; 325 326 if ($header =~ /%[sd]/) { 327 $rhs = $lhs = $header; 328 #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) { 329 if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) { 330 $lhs =~ s/\\%s/.*?/g; 331 } else { 332 # if i had lookbehind negations, i wouldn't have to do this \377 noise 333 $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g; 334 #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/; 335 $lhs =~ s/\377([^\377]*)$/\Q$1\E/; 336 $lhs =~ s/\377//g; 337 $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all 338 } 339 $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n"; 340 } else { 341 $transmo .= " m{^\Q$header\E} && return 1;\n"; 342 } 343 344 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n" 345 if $msg{$header}; 346 347 $msg{$header} = ''; 348 } 349 350 351 close POD_DIAG unless *main::DATA eq *POD_DIAG; 352 353 die "No diagnostics?" unless %msg; 354 355 $transmo .= " return 0;\n}\n"; 356 print STDERR $transmo if $DEBUG; 357 eval $transmo; 358 die $@ if $@; 359 $RS = "\n"; 360### } 361 362if ($standalone) { 363 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 364 while (defined ($error = <>)) { 365 splainthis($error) || print THITHER $error; 366 } 367 exit; 368} else { 369 $old_w = 0; $oldwarn = ''; $olddie = ''; 370} 371 372sub import { 373 shift; 374 $old_w = $^W; 375 $^W = 1; # yup, clobbered the global variable; tough, if you 376 # want diags, you want diags. 377 return if $SIG{__WARN__} eq \&warn_trap; 378 379 for (@_) { 380 381 /^-d(ebug)?$/ && do { 382 $DEBUG++; 383 next; 384 }; 385 386 /^-v(erbose)?$/ && do { 387 $VERBOSE++; 388 next; 389 }; 390 391 /^-p(retty)?$/ && do { 392 print STDERR "$0: I'm afraid it's too late for prettiness.\n"; 393 $PRETTY++; 394 next; 395 }; 396 397 warn "Unknown flag: $_"; 398 } 399 400 $oldwarn = $SIG{__WARN__}; 401 $olddie = $SIG{__DIE__}; 402 $SIG{__WARN__} = \&warn_trap; 403 $SIG{__DIE__} = \&death_trap; 404} 405 406sub enable { &import } 407 408sub disable { 409 shift; 410 $^W = $old_w; 411 return unless $SIG{__WARN__} eq \&warn_trap; 412 $SIG{__WARN__} = $oldwarn; 413 $SIG{__DIE__} = $olddie; 414} 415 416sub warn_trap { 417 my $warning = $_[0]; 418 if (caller eq $WHOAMI or !splainthis($warning)) { 419 print STDERR $warning; 420 } 421 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap; 422}; 423 424sub death_trap { 425 my $exception = $_[0]; 426 427 # See if we are coming from anywhere within an eval. If so we don't 428 # want to explain the exception because it's going to get caught. 429 my $in_eval = 0; 430 my $i = 0; 431 while (1) { 432 my $caller = (caller($i++))[3] or last; 433 if ($caller eq '(eval)') { 434 $in_eval = 1; 435 last; 436 } 437 } 438 439 splainthis($exception) unless $in_eval; 440 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } 441 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; 442 443 # We don't want to unset these if we're coming from an eval because 444 # then we've turned off diagnostics. (Actually what does this next 445 # line do? -PSeibel) 446 $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval; 447 local($Carp::CarpLevel) = 1; 448 confess "Uncaught exception from user code:\n\t$exception"; 449 # up we go; where we stop, nobody knows, but i think we die now 450 # but i'm deeply afraid of the &$olddie guy reraising and us getting 451 # into an indirect recursion loop 452}; 453 454sub splainthis { 455 local $_ = shift; 456 local $\; 457 ### &finish_compilation unless %msg; 458 s/\.?\n+$//; 459 my $orig = $_; 460 # return unless defined; 461 if ($exact_duplicate{$_}++) { 462 return 1; 463 } 464 s/, <.*?> (?:line|chunk).*$//; 465 $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; 466 s/^\((.*)\)$/$1/; 467 return 0 unless &transmo; 468 $orig = shorten($orig); 469 if ($old_diag{$_}) { 470 autodescribe(); 471 print THITHER "$orig (#$old_diag{$_})\n"; 472 $wantspace = 1; 473 } else { 474 autodescribe(); 475 $old_diag{$_} = ++$count; 476 print THITHER "\n" if $wantspace; 477 $wantspace = 0; 478 print THITHER "$orig (#$old_diag{$_})\n"; 479 if ($msg{$_}) { 480 print THITHER $msg{$_}; 481 } else { 482 if (0 and $standalone) { 483 print THITHER " **** Error #$old_diag{$_} ", 484 ($real ? "is" : "appears to be"), 485 " an unknown diagnostic message.\n\n"; 486 } 487 return 0; 488 } 489 } 490 return 1; 491} 492 493sub autodescribe { 494 if ($VERBOSE and not $count) { 495 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"), 496 "\n$msg{DESCRIPTION}\n"; 497 } 498} 499 500sub unescape { 501 s { 502 E< 503 ( [A-Za-z]+ ) 504 > 505 } { 506 do { 507 exists $HTML_Escapes{$1} 508 ? do { $HTML_Escapes{$1} } 509 : do { 510 warn "Unknown escape: E<$1> in $_"; 511 "E<$1>"; 512 } 513 } 514 }egx; 515} 516 517sub shorten { 518 my $line = $_[0]; 519 if (length($line) > 79 and index($line, "\n") == -1) { 520 my $space_place = rindex($line, ' ', 79); 521 if ($space_place != -1) { 522 substr($line, $space_place, 1) = "\n\t"; 523 } 524 } 525 return $line; 526} 527 528 529# have to do this: RS isn't set until run time, but we're executing at compile time 530$RS = "\n"; 531 5321 unless $standalone; # or it'll complain about itself 533__END__ # wish diag dbase were more accessible 534