lib/diagnostics.pm

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