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