lib/diagnostics.pm

   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.19';
 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 local $.;
 226
 227 my $standalone;
 228 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
 229
 230 CONFIG: {
 231     our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
 232
 233     unless (caller) {
 234         $standalone++;
 235         require Getopt::Std;
 236         Getopt::Std::getopts('pdvf:')
 237             or die "Usage: $0 [-v] [-p] [-f splainpod]";
 238         $PODFILE = $opt_f if $opt_f;
 239         $DEBUG = 2 if $opt_d;
 240         $VERBOSE = $opt_v;
 241         $PRETTY = $opt_p;
 242     }
 243
 244     if (open(POD_DIAG, $PODFILE)) {
 245         warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
 246         last CONFIG;
 247     }
 248
 249     if (caller) {
 250         INCPATH: {
 251             for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
 252                 warn "Checking $file\n" if $DEBUG;
 253                 if (open(POD_DIAG, $file)) {
 254                     while (<POD_DIAG>) {
 255                         next unless
 256                             /^__END__\s*# wish diag dbase were more accessible/;
 257                         print STDERR "podfile is $file\n" if $DEBUG;
 258                         last INCPATH;
 259                     }
 260                 }
 261             }
 262         }
 263     } else {
 264         print STDERR "podfile is <DATA>\n" if $DEBUG;
 265         *POD_DIAG = *main::DATA;
 266     }
 267 }
 268 if (eof(POD_DIAG)) {
 269     die "couldn't find diagnostic data in $PODFILE @INC $0";
 270 }
 271
 272
 273 %HTML_2_Troff = (
 274     'amp'       =>      '&',    #   ampersand
 275     'lt'        =>      '<',    #   left chevron, less-than
 276     'gt'        =>      '>',    #   right chevron, greater-than
 277     'quot'      =>      '"',    #   double quote
 278
 279     "Aacute"    =>      "A\\*'",        #   capital A, acute accent
 280     # etc
 281
 282 );
 283
 284 %HTML_2_Latin_1 = (
 285     'amp'       =>      '&',    #   ampersand
 286     'lt'        =>      '<',    #   left chevron, less-than
 287     'gt'        =>      '>',    #   right chevron, greater-than
 288     'quot'      =>      '"',    #   double quote
 289
 290     "Aacute"    =>      "\xC1"  #   capital A, acute accent
 291
 292     # etc
 293 );
 294
 295 %HTML_2_ASCII_7 = (
 296     'amp'       =>      '&',    #   ampersand
 297     'lt'        =>      '<',    #   left chevron, less-than
 298     'gt'        =>      '>',    #   right chevron, greater-than
 299     'quot'      =>      '"',    #   double quote
 300
 301     "Aacute"    =>      "A"     #   capital A, acute accent
 302     # etc
 303 );
 304
 305 our %HTML_Escapes;
 306 *HTML_Escapes = do {
 307     if ($standalone) {
 308         $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
 309     } else {
 310         \%HTML_2_Latin_1;
 311     }
 312 };
 313
 314 *THITHER = $standalone ? *STDOUT : *STDERR;
 315
 316 my %transfmt = ();
 317 my $transmo = <<EOFUNC;
 318 sub transmo {
 319     #local \$^W = 0;  # recursive warnings we do NOT need!
 320     study;
 321 EOFUNC
 322
 323 my %msg;
 324 {
 325     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
 326     local $/ = '';
 327     my $header;
 328     my $for_item;
 329     while (<POD_DIAG>) {
 330
 331         unescape();
 332         if ($PRETTY) {
 333             sub noop   { return $_[0] }  # spensive for a noop
 334             sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; }
 335             sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; }
 336             s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
 337             s/[LIF]<(.*?)>/italic($1)/ges;
 338         } else {
 339             s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
 340             s/[LIF]<(.*?)>/$1/gs;
 341         }
 342         unless (/^=/) {
 343             if (defined $header) {
 344                 if ( $header eq 'DESCRIPTION' &&
 345                     (   /Optional warnings are enabled/
 346                      || /Some of these messages are generic./
 347                     ) )
 348                 {
 349                     next;
 350                 }
 351                 s/^/    /gm;
 352                 $msg{$header} .= $_;
 353                 undef $for_item;
 354             }
 355             next;
 356         }
 357         unless ( s/=item (.*?)\s*\z//) {
 358
 359             if ( s/=head1\sDESCRIPTION//) {
 360                 $msg{$header = 'DESCRIPTION'} = '';
 361                 undef $for_item;
 362             }
 363             elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
 364                 $for_item = $1;
 365             }
 366             next;
 367         }
 368
 369         if( $for_item ) { $header = $for_item; undef $for_item }
 370         else {
 371             $header = $1;
 372             while( $header =~ /[;,]\z/ ) {
 373                 <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
 374                 $header .= ' '.$1;
 375             }
 376         }
 377
 378         # strip formatting directives from =item line
 379         $header =~ s/[A-Z]<(.*?)>/$1/g;
 380
 381         my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?[fs])/, $header );
 382         if (@toks > 1) {
 383             my $conlen = 0;
 384             for my $i (0..$#toks){
 385                 if( $i % 2 ){
 386                     if(      $toks[$i] eq '%c' ){
 387                         $toks[$i] = '.';
 388                     } elsif( $toks[$i] eq '%d' ){
 389                         $toks[$i] = '\d+';
 390                     } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
 391                         $toks[$i] = $i == $#toks ? '.*' : '.*?';
 392                     } elsif( $toks[$i] =~ '%.(\d+)s' ){
 393                         $toks[$i] = ".{$1}";
 394                      } elsif( $toks[$i] =~ '^%l*x$' ){
 395                         $toks[$i] = '[\da-f]+';
 396                    }
 397                 } elsif( length( $toks[$i] ) ){
 398                     $toks[$i] = quotemeta $toks[$i];
 399                     $conlen += length( $toks[$i] );
 400                 }
 401             }
 402             my $lhs = join( '', @toks );
 403             $transfmt{$header}{pat} =
 404               "    s{^$lhs}\n     {\Q$header\E}s\n\t&& return 1;\n";
 405             $transfmt{$header}{len} = $conlen;
 406         } else {
 407             $transfmt{$header}{pat} =
 408               "    m{^\Q$header\E} && return 1;\n";
 409             $transfmt{$header}{len} = length( $header );
 410         }
 411
 412         print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
 413             if $msg{$header};
 414
 415         $msg{$header} = '';
 416     }
 417
 418
 419     close POD_DIAG unless *main::DATA eq *POD_DIAG;
 420
 421     die "No diagnostics?" unless %msg;
 422
 423     # Apply patterns in order of decreasing sum of lengths of fixed parts
 424     # Seems the best way of hitting the right one.
 425     for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
 426                   keys %transfmt ){
 427         $transmo .= $transfmt{$hdr}{pat};
 428     }
 429     $transmo .= "    return 0;\n}\n";
 430     print STDERR $transmo if $DEBUG;
 431     eval $transmo;
 432     die $@ if $@;
 433 }
 434
 435 if ($standalone) {
 436     if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
 437     while (defined (my $error = <>)) {
 438         splainthis($error) || print THITHER $error;
 439     }
 440     exit;
 441 }
 442
 443 my $olddie;
 444 my $oldwarn;
 445
 446 sub import {
 447     shift;
 448     $^W = 1; # yup, clobbered the global variable;
 449              # tough, if you want diags, you want diags.
 450     return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
 451
 452     for (@_) {
 453
 454         /^-d(ebug)?$/           && do {
 455                                     $DEBUG++;
 456                                     next;
 457                                    };
 458
 459         /^-v(erbose)?$/         && do {
 460                                     $VERBOSE++;
 461                                     next;
 462                                    };
 463
 464         /^-p(retty)?$/          && do {
 465                                     print STDERR "$0: I'm afraid it's too late for prettiness.\n";
 466                                     $PRETTY++;
 467                                     next;
 468                                };
 469         # matches trace and traceonly for legacy doc mixup reasons
 470         /^-t(race(only)?)?$/    && do {
 471                                     $TRACEONLY++;
 472                                     next;
 473                                };
 474         /^-w(arntrace)?$/       && do {
 475                                     $WARNTRACE++;
 476                                     next;
 477                                };
 478
 479         warn "Unknown flag: $_";
 480     }
 481
 482     $oldwarn = $SIG{__WARN__};
 483     $olddie = $SIG{__DIE__};
 484     $SIG{__WARN__} = \&warn_trap;
 485     $SIG{__DIE__} = \&death_trap;
 486 }
 487
 488 sub enable { &import }
 489
 490 sub disable {
 491     shift;
 492     return unless $SIG{__WARN__} eq \&warn_trap;
 493     $SIG{__WARN__} = $oldwarn || '';
 494     $SIG{__DIE__} = $olddie || '';
 495 }
 496
 497 sub warn_trap {
 498     my $warning = $_[0];
 499     if (caller eq $WHOAMI or !splainthis($warning)) {
 500         if ($WARNTRACE) {
 501             print STDERR Carp::longmess($warning);
 502         } else {
 503             print STDERR $warning;
 504         }
 505     }
 506     goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
 507 };
 508
 509 sub death_trap {
 510     my $exception = $_[0];
 511
 512     # See if we are coming from anywhere within an eval. If so we don't
 513     # want to explain the exception because it's going to get caught.
 514     my $in_eval = 0;
 515     my $i = 0;
 516     while (my $caller = (caller($i++))[3]) {
 517       if ($caller eq '(eval)') {
 518         $in_eval = 1;
 519         last;
 520       }
 521     }
 522
 523     splainthis($exception) unless $in_eval;
 524     if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
 525     &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
 526
 527     return if $in_eval;
 528
 529     # We don't want to unset these if we're coming from an eval because
 530     # then we've turned off diagnostics.
 531
 532     # Switch off our die/warn handlers so we don't wind up in our own
 533     # traps.
 534     $SIG{__DIE__} = $SIG{__WARN__} = '';
 535
 536     # Have carp skip over death_trap() when showing the stack trace.
 537     local($Carp::CarpLevel) = 1;
 538
 539     confess "Uncaught exception from user code:\n\t$exception";
 540         # up we go; where we stop, nobody knows, but i think we die now
 541         # but i'm deeply afraid of the &$olddie guy reraising and us getting
 542         # into an indirect recursion loop
 543 };
 544
 545 my %exact_duplicate;
 546 my %old_diag;
 547 my $count;
 548 my $wantspace;
 549 sub splainthis {
 550     return 0 if $TRACEONLY;
 551     $_ = shift;
 552     local $\;
 553     local $!;
 554     ### &finish_compilation unless %msg;
 555     s/\.?\n+$//;
 556     my $orig = $_;
 557     # return unless defined;
 558
 559     # get rid of the where-are-we-in-input part
 560     s/, <.*?> (?:line|chunk).*$//;
 561
 562     # Discard 1st " at <file> line <no>" and all text beyond
 563     # but be aware of messsages containing " at this-or-that"
 564     my $real = 0;
 565     my @secs = split( / at / );
 566     return unless @secs;
 567     $_ = $secs[0];
 568     for my $i ( 1..$#secs ){
 569         if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
 570             $real = 1;
 571             last;
 572         } else {
 573             $_ .= ' at ' . $secs[$i];
 574         }
 575     }
 576
 577     # remove parenthesis occurring at the end of some messages
 578     s/^\((.*)\)$/$1/;
 579
 580     if ($exact_duplicate{$orig}++) {
 581         return &transmo;
 582     } else {
 583         return 0 unless &transmo;
 584     }
 585
 586     $orig = shorten($orig);
 587     if ($old_diag{$_}) {
 588         autodescribe();
 589         print THITHER "$orig (#$old_diag{$_})\n";
 590         $wantspace = 1;
 591     } else {
 592         autodescribe();
 593         $old_diag{$_} = ++$count;
 594         print THITHER "\n" if $wantspace;
 595         $wantspace = 0;
 596         print THITHER "$orig (#$old_diag{$_})\n";
 597         if ($msg{$_}) {
 598             print THITHER $msg{$_};
 599         } else {
 600             if (0 and $standalone) {
 601                 print THITHER "    **** Error #$old_diag{$_} ",
 602                         ($real ? "is" : "appears to be"),
 603                         " an unknown diagnostic message.\n\n";
 604             }
 605             return 0;
 606         }
 607     }
 608     return 1;
 609 }
 610
 611 sub autodescribe {
 612     if ($VERBOSE and not $count) {
 613         print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
 614                 "\n$msg{DESCRIPTION}\n";
 615     }
 616 }
 617
 618 sub unescape {
 619     s {
 620             E<
 621             ( [A-Za-z]+ )
 622             >
 623     } {
 624          do {
 625              exists $HTML_Escapes{$1}
 626                 ? do { $HTML_Escapes{$1} }
 627                 : do {
 628                     warn "Unknown escape: E<$1> in $_";
 629                     "E<$1>";
 630                 }
 631          }
 632     }egx;
 633 }
 634
 635 sub shorten {
 636     my $line = $_[0];
 637     if (length($line) > 79 and index($line, "\n") == -1) {
 638         my $space_place = rindex($line, ' ', 79);
 639         if ($space_place != -1) {
 640             substr($line, $space_place, 1) = "\n\t";
 641         }
 642     }
 643     return $line;
 644 }
 645
 646
 647 1 unless $standalone;  # or it'll complain about itself
 648 __END__ # wish diag dbase were more accessible