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