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, augmenting them with the more
  32 explicative and endearing descriptions found in L<perldiag>.  Like the
  33 other pragmata, it affects the compilation phase of your program rather
  34 than merely the execution phase.
  35
  36 To use in your program as a pragma, merely invoke
  37
  38     use diagnostics;
  39
  40 at the start (or near the start) of your program.  (Note
  41 that this I<does> enable perl's B<-w> flag.)  Your whole
  42 compilation will then be subject(ed :-) to the enhanced diagnostics.
  43 These still go out B<STDERR>.
  44
  45 Due to the interaction between runtime and compiletime issues,
  46 and because it's probably not a very good idea anyway,
  47 you may not use C<no diagnostics> to turn them off at compiletime.
  48 However, you may control their behaviour at runtime using the
  49 disable() and enable() methods to turn them off and on respectively.
  50
  51 The B<-verbose> flag first prints out the L<perldiag> introduction before
  52 any other diagnostics.  The $diagnostics::PRETTY variable can generate nicer
  53 escape sequences for pagers.
  54
  55 Warnings dispatched from perl itself (or more accurately, those that match
  56 descriptions found in L<perldiag>) are only displayed once (no duplicate
  57 descriptions).  User code generated warnings a la warn() are unaffected,
  58 allowing duplicate user messages to be displayed.
  59
  60 This module also adds a stack trace to the error message when perl dies.
  61 This is useful for pinpointing what caused the death. The B<-traceonly> (or
  62 just B<-t>) flag turns off the explantions of warning messages leaving just
  63 the stack traces. So if your script is dieing, run it again with
  64
  65   perl -Mdiagnostics=-traceonly my_bad_script
  66
  67 to see the call stack at the time of death. By supplying the B<-warntrace>
  68 (or just B<-w>) flag, any warnings emitted will also come with a stack
  69 trace.
  70
  71 =head2 The I<splain> Program
  72
  73 While apparently a whole nuther program, I<splain> is actually nothing
  74 more than a link to the (executable) F<diagnostics.pm> module, as well as
  75 a link to the F<diagnostics.pod> documentation.  The B<-v> flag is like
  76 the C<use diagnostics -verbose> directive.
  77 The B<-p> flag is like the
  78 $diagnostics::PRETTY variable.  Since you're post-processing with
  79 I<splain>, there's no sense in being able to enable() or disable() processing.
  80
  81 Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
  82
  83 =head1 EXAMPLES
  84
  85 The following file is certain to trigger a few errors at both
  86 runtime and compiletime:
  87
  88     use diagnostics;
  89     print NOWHERE "nothing\n";
  90     print STDERR "\n\tThis message should be unadorned.\n";
  91     warn "\tThis is a user warning";
  92     print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
  93     my $a, $b = scalar <STDIN>;
  94     print "\n";
  95     print $x/$y;
  96
  97 If you prefer to run your program first and look at its problem
  98 afterwards, do this:
  99
 100     perl -w test.pl 2>test.out
 101     ./splain < test.out
 102
 103 Note that this is not in general possible in shells of more dubious heritage,
 104 as the theoretical
 105
 106     (perl -w test.pl >/dev/tty) >& test.out
 107     ./splain < test.out
 108
 109 Because you just moved the existing B<stdout> to somewhere else.
 110
 111 If you don't want to modify your source code, but still have on-the-fly
 112 warnings, do this:
 113
 114     exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
 115
 116 Nifty, eh?
 117
 118 If you want to control warnings on the fly, do something like this.
 119 Make sure you do the C<use> first, or you won't be able to get
 120 at the enable() or disable() methods.
 121
 122     use diagnostics; # checks entire compilation phase
 123         print "\ntime for 1st bogus diags: SQUAWKINGS\n";
 124         print BOGUS1 'nada';
 125         print "done with 1st bogus\n";
 126
 127     disable diagnostics; # only turns off runtime warnings
 128         print "\ntime for 2nd bogus: (squelched)\n";
 129         print BOGUS2 'nada';
 130         print "done with 2nd bogus\n";
 131
 132     enable diagnostics; # turns back on runtime warnings
 133         print "\ntime for 3rd bogus: SQUAWKINGS\n";
 134         print BOGUS3 'nada';
 135         print "done with 3rd bogus\n";
 136
 137     disable diagnostics;
 138         print "\ntime for 4th bogus: (squelched)\n";
 139         print BOGUS4 'nada';
 140         print "done with 4th bogus\n";
 141
 142 =head1 INTERNALS
 143
 144 Diagnostic messages derive from the F<perldiag.pod> file when available at
 145 runtime.  Otherwise, they may be embedded in the file itself when the
 146 splain package is built.   See the F<Makefile> for details.
 147
 148 If an extant $SIG{__WARN__} handler is discovered, it will continue
 149 to be honored, but only after the diagnostics::splainthis() function
 150 (the module's $SIG{__WARN__} interceptor) has had its way with your
 151 warnings.
 152
 153 There is a $diagnostics::DEBUG variable you may set if you're desperately
 154 curious what sorts of things are being intercepted.
 155
 156     BEGIN { $diagnostics::DEBUG = 1 }
 157
 158
 159 =head1 BUGS
 160
 161 Not being able to say "no diagnostics" is annoying, but may not be
 162 insurmountable.
 163
 164 The C<-pretty> directive is called too late to affect matters.
 165 You have to do this instead, and I<before> you load the module.
 166
 167     BEGIN { $diagnostics::PRETTY = 1 }
 168
 169 I could start up faster by delaying compilation until it should be
 170 needed, but this gets a "panic: top_level" when using the pragma form
 171 in Perl 5.001e.
 172
 173 While it's true that this documentation is somewhat subserious, if you use
 174 a program named I<splain>, you should expect a bit of whimsy.
 175
 176 =head1 AUTHOR
 177
 178 Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
 179
 180 =cut
 181
 182 use strict;
 183 use 5.006;
 184 use Carp;
 185 $Carp::Internal{__PACKAGE__.""}++;
 186
 187 our $VERSION = 1.14;
 188 our $DEBUG;
 189 our $VERBOSE;
 190 our $PRETTY;
 191 our $TRACEONLY = 0;
 192 our $WARNTRACE = 0;
 193
 194 use Config;
 195 my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
 196 if ($^O eq 'VMS') {
 197     require VMS::Filespec;
 198     $privlib = VMS::Filespec::unixify($privlib);
 199     $archlib = VMS::Filespec::unixify($archlib);
 200 }
 201 my @trypod = (
 202            "$archlib/pod/perldiag.pod",
 203            "$privlib/pod/perldiag-$Config{version}.pod",
 204            "$privlib/pod/perldiag.pod",
 205            "$archlib/pods/perldiag.pod",
 206            "$privlib/pods/perldiag-$Config{version}.pod",
 207            "$privlib/pods/perldiag.pod",
 208           );
 209 # handy for development testing of new warnings etc
 210 unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
 211 (my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
 212
 213 if ($^O eq 'MacOS') {
 214     # just updir one from each lib dir, we'll find it ...
 215     ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
 216 }
 217
 218
 219 $DEBUG ||= 0;
 220 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
 221
 222 local $| = 1;
 223 local $_;
 224
 225 my $standalone;
 226 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
 227
 228 CONFIG: {
 229     our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
 230
 231     unless (caller) {
 232         $standalone++;
 233         require Getopt::Std;
 234         Getopt::Std::getopts('pdvf:')
 235             or die "Usage: $0 [-v] [-p] [-f splainpod]";
 236         $PODFILE = $opt_f if $opt_f;
 237         $DEBUG = 2 if $opt_d;
 238         $VERBOSE = $opt_v;
 239         $PRETTY = $opt_p;
 240     }
 241
 242     if (open(POD_DIAG, $PODFILE)) {
 243         warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
 244         last CONFIG;
 245     }
 246
 247     if (caller) {
 248         INCPATH: {
 249             for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
 250                 warn "Checking $file\n" if $DEBUG;
 251                 if (open(POD_DIAG, $file)) {
 252                     while (<POD_DIAG>) {
 253                         next unless
 254                             /^__END__\s*# wish diag dbase were more accessible/;
 255                         print STDERR "podfile is $file\n" if $DEBUG;
 256                         last INCPATH;
 257                     }
 258                 }
 259             }
 260         }
 261     } else {
 262         print STDERR "podfile is <DATA>\n" if $DEBUG;
 263         *POD_DIAG = *main::DATA;
 264     }
 265 }
 266 if (eof(POD_DIAG)) {
 267     die "couldn't find diagnostic data in $PODFILE @INC $0";
 268 }
 269
 270
 271 %HTML_2_Troff = (
 272     'amp'       =>      '&',    #   ampersand
 273     'lt'        =>      '<',    #   left chevron, less-than
 274     'gt'        =>      '>',    #   right chevron, greater-than
 275     'quot'      =>      '"',    #   double quote
 276
 277     "Aacute"    =>      "A\\*'",        #   capital A, acute accent
 278     # etc
 279
 280 );
 281
 282 %HTML_2_Latin_1 = (
 283     'amp'       =>      '&',    #   ampersand
 284     'lt'        =>      '<',    #   left chevron, less-than
 285     'gt'        =>      '>',    #   right chevron, greater-than
 286     'quot'      =>      '"',    #   double quote
 287
 288     "Aacute"    =>      "\xC1"  #   capital A, acute accent
 289
 290     # etc
 291 );
 292
 293 %HTML_2_ASCII_7 = (
 294     'amp'       =>      '&',    #   ampersand
 295     'lt'        =>      '<',    #   left chevron, less-than
 296     'gt'        =>      '>',    #   right chevron, greater-than
 297     'quot'      =>      '"',    #   double quote
 298
 299     "Aacute"    =>      "A"     #   capital A, acute accent
 300     # etc
 301 );
 302
 303 our %HTML_Escapes;
 304 *HTML_Escapes = do {
 305     if ($standalone) {
 306         $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
 307     } else {
 308         \%HTML_2_Latin_1;
 309     }
 310 };
 311
 312 *THITHER = $standalone ? *STDOUT : *STDERR;
 313
 314 my %transfmt = ();
 315 my $transmo = <<EOFUNC;
 316 sub transmo {
 317     #local \$^W = 0;  # recursive warnings we do NOT need!
 318     study;
 319 EOFUNC
 320
 321 my %msg;
 322 {
 323     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
 324     local $/ = '';
 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] =~ s/^.*$/\Q$&\E/;
 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
 469         /^-t(race)?$/           && 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     local $_ = shift;
 551     local $\;
 552     ### &finish_compilation unless %msg;
 553     s/\.?\n+$//;
 554     my $orig = $_;
 555     # return unless defined;
 556
 557     # get rid of the where-are-we-in-input part
 558     s/, <.*?> (?:line|chunk).*$//;
 559
 560     # Discard 1st " at <file> line <no>" and all text beyond
 561     # but be aware of messsages containing " at this-or-that"
 562     my $real = 0;
 563     my @secs = split( / at / );
 564     $_ = $secs[0];
 565     for my $i ( 1..$#secs ){
 566         if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
 567             $real = 1;
 568             last;
 569         } else {
 570             $_ .= ' at ' . $secs[$i];
 571         }
 572     }
 573
 574     # remove parenthesis occurring at the end of some messages
 575     s/^\((.*)\)$/$1/;
 576
 577     if ($exact_duplicate{$orig}++) {
 578         return &transmo;
 579     } else {
 580         return 0 unless &transmo;
 581     }
 582
 583     $orig = shorten($orig);
 584     if ($old_diag{$_}) {
 585         autodescribe();
 586         print THITHER "$orig (#$old_diag{$_})\n";
 587         $wantspace = 1;
 588     } else {
 589         autodescribe();
 590         $old_diag{$_} = ++$count;
 591         print THITHER "\n" if $wantspace;
 592         $wantspace = 0;
 593         print THITHER "$orig (#$old_diag{$_})\n";
 594         if ($msg{$_}) {
 595             print THITHER $msg{$_};
 596         } else {
 597             if (0 and $standalone) {
 598                 print THITHER "    **** Error #$old_diag{$_} ",
 599                         ($real ? "is" : "appears to be"),
 600                         " an unknown diagnostic message.\n\n";
 601             }
 602             return 0;
 603         }
 604     }
 605     return 1;
 606 }
 607
 608 sub autodescribe {
 609     if ($VERBOSE and not $count) {
 610         print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
 611                 "\n$msg{DESCRIPTION}\n";
 612     }
 613 }
 614
 615 sub unescape {
 616     s {
 617             E<
 618             ( [A-Za-z]+ )
 619             >
 620     } {
 621          do {
 622              exists $HTML_Escapes{$1}
 623                 ? do { $HTML_Escapes{$1} }
 624                 : do {
 625                     warn "Unknown escape: E<$1> in $_";
 626                     "E<$1>";
 627                 }
 628          }
 629     }egx;
 630 }
 631
 632 sub shorten {
 633     my $line = $_[0];
 634     if (length($line) > 79 and index($line, "\n") == -1) {
 635         my $space_place = rindex($line, ' ', 79);
 636         if ($space_place != -1) {
 637             substr($line, $space_place, 1) = "\n\t";
 638         }
 639     }
 640     return $line;
 641 }
 642
 643
 644 1 unless $standalone;  # or it'll complain about itself
 645 __END__ # wish diag dbase were more accessible