lib/diagnostics.pm

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