lib/diagnostics.pm

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