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 interpeter, 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 =head2 The I<splain> Program
  55
  56 While apparently a whole nuther program, I<splain> is actually nothing
  57 more than a link to the (executable) F<diagnostics.pm> module, as well as
  58 a link to the F<diagnostics.pod> documentation.  The B<-v> flag is like
  59 the C<use diagnostics -verbose> directive.
  60 The B<-p> flag is like the
  61 $diagnostics::PRETTY variable.  Since you're post-processing with
  62 I<splain>, there's no sense in being able to enable() or disable() processing.
  63
  64 Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
  65
  66 =head1 EXAMPLES
  67
  68 The following file is certain to trigger a few errors at both
  69 runtime and compiletime:
  70
  71     use diagnostics;
  72     print NOWHERE "nothing\n";
  73     print STDERR "\n\tThis message should be unadorned.\n";
  74     warn "\tThis is a user warning";
  75     print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
  76     my $a, $b = scalar <STDIN>;
  77     print "\n";
  78     print $x/$y;
  79
  80 If you prefer to run your program first and look at its problem
  81 afterwards, do this:
  82
  83     perl -w test.pl 2>test.out
  84     ./splain < test.out
  85
  86 Note that this is not in general possible in shells of more dubious heritage,
  87 as the theoretical
  88
  89     (perl -w test.pl >/dev/tty) >& test.out
  90     ./splain < test.out
  91
  92 Because you just moved the existing B<stdout> to somewhere else.
  93
  94 If you don't want to modify your source code, but still have on-the-fly
  95 warnings, do this:
  96
  97     exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
  98
  99 Nifty, eh?
 100
 101 If you want to control warnings on the fly, do something like this.
 102 Make sure you do the C<use> first, or you won't be able to get
 103 at the enable() or disable() methods.
 104
 105     use diagnostics; # checks entire compilation phase
 106         print "\ntime for 1st bogus diags: SQUAWKINGS\n";
 107         print BOGUS1 'nada';
 108         print "done with 1st bogus\n";
 109
 110     disable diagnostics; # only turns off runtime warnings
 111         print "\ntime for 2nd bogus: (squelched)\n";
 112         print BOGUS2 'nada';
 113         print "done with 2nd bogus\n";
 114
 115     enable diagnostics; # turns back on runtime warnings
 116         print "\ntime for 3rd bogus: SQUAWKINGS\n";
 117         print BOGUS3 'nada';
 118         print "done with 3rd bogus\n";
 119
 120     disable diagnostics;
 121         print "\ntime for 4th bogus: (squelched)\n";
 122         print BOGUS4 'nada';
 123         print "done with 4th bogus\n";
 124
 125 =head1 INTERNALS
 126
 127 Diagnostic messages derive from the F<perldiag.pod> file when available at
 128 runtime.  Otherwise, they may be embedded in the file itself when the
 129 splain package is built.   See the F<Makefile> for details.
 130
 131 If an extant $SIG{__WARN__} handler is discovered, it will continue
 132 to be honored, but only after the diagnostics::splainthis() function
 133 (the module's $SIG{__WARN__} interceptor) has had its way with your
 134 warnings.
 135
 136 There is a $diagnostics::DEBUG variable you may set if you're desperately
 137 curious what sorts of things are being intercepted.
 138
 139     BEGIN { $diagnostics::DEBUG = 1 }
 140
 141
 142 =head1 BUGS
 143
 144 Not being able to say "no diagnostics" is annoying, but may not be
 145 insurmountable.
 146
 147 The C<-pretty> directive is called too late to affect matters.
 148 You have to to this instead, and I<before> you load the module.
 149
 150     BEGIN { $diagnostics::PRETTY = 1 }
 151
 152 I could start up faster by delaying compilation until it should be
 153 needed, but this gets a "panic: top_level" when using the pragma form
 154 in Perl 5.001e.
 155
 156 While it's true that this documentation is somewhat subserious, if you use
 157 a program named I<splain>, you should expect a bit of whimsy.
 158
 159 =head1 AUTHOR
 160
 161 Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995.
 162
 163 =cut
 164
 165 require 5.001;
 166 use English;
 167 use Carp;
 168
 169 use Config;
 170 if ($^O eq 'VMS') {
 171     $PODFILE = VMS::Filespec::unixify($Config{privlibexp}).'/pod/perldiag.pod';
 172 }
 173 else {
 174     $PODFILE = $Config{privlibexp} . "/pod/perldiag.pod";
 175 }
 176
 177 $DEBUG ||= 0;
 178 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
 179
 180 $OUTPUT_AUTOFLUSH = 1;
 181
 182 local $_;
 183
 184 CONFIG: {
 185     $opt_p = $opt_d = $opt_v = $opt_f = '';
 186     %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();
 187     %exact_duplicate = ();
 188
 189     unless (caller) {
 190         $standalone++;
 191         require Getopt::Std;
 192         Getopt::Std::getopts('pdvf:') || die "Usage: $0 [-v] [-p] [-f splainpod]";
 193         $PODFILE = $opt_f if $opt_f;
 194         $DEBUG = 2 if $opt_d;
 195         $VERBOSE = $opt_v;
 196         $PRETTY = $opt_p;
 197     }
 198
 199     if (open(POD_DIAG, $PODFILE)) {
 200         warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
 201         last CONFIG;
 202     }
 203
 204     if (caller) {
 205         INCPATH: {
 206             for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
 207                 warn "Checking $file\n" if $DEBUG;
 208                 if (open(POD_DIAG, $file)) {
 209                     while (<POD_DIAG>) {
 210                         next unless /^__END__\s*# wish diag dbase were more accessible/;
 211                         print STDERR "podfile is $file\n" if $DEBUG;
 212                         last INCPATH;
 213                     }
 214                 }
 215             }
 216         }
 217     } else {
 218         print STDERR "podfile is <DATA>\n" if $DEBUG;
 219         *POD_DIAG = *main::DATA;
 220     }
 221 }
 222 if (eof(POD_DIAG)) {
 223     die "couldn't find diagnostic data in $PODFILE @INC $0";
 224 }
 225
 226
 227 %HTML_2_Troff = (
 228     'amp'       =>      '&',    #   ampersand
 229     'lt'        =>      '<',    #   left chevron, less-than
 230     'gt'        =>      '>',    #   right chevron, greater-than
 231     'quot'      =>      '"',    #   double quote
 232
 233     "Aacute"    =>      "A\\*'",        #   capital A, acute accent
 234     # etc
 235
 236 );
 237
 238 %HTML_2_Latin_1 = (
 239     'amp'       =>      '&',    #   ampersand
 240     'lt'        =>      '<',    #   left chevron, less-than
 241     'gt'        =>      '>',    #   right chevron, greater-than
 242     'quot'      =>      '"',    #   double quote
 243
 244     "Aacute"    =>      "\xC1"  #   capital A, acute accent
 245
 246     # etc
 247 );
 248
 249 %HTML_2_ASCII_7 = (
 250     'amp'       =>      '&',    #   ampersand
 251     'lt'        =>      '<',    #   left chevron, less-than
 252     'gt'        =>      '>',    #   right chevron, greater-than
 253     'quot'      =>      '"',    #   double quote
 254
 255     "Aacute"    =>      "A"     #   capital A, acute accent
 256     # etc
 257 );
 258
 259 *HTML_Escapes = do {
 260     if ($standalone) {
 261         $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
 262     } else {
 263         \%HTML_2_Latin_1;
 264     }
 265 };
 266
 267 *THITHER = $standalone ? *STDOUT : *STDERR;
 268
 269 $transmo = <<EOFUNC;
 270 sub transmo {
 271     local \$^W = 0;  # recursive warnings we do NOT need!
 272     study;
 273 EOFUNC
 274
 275 ### sub finish_compilation {  # 5.001e panic: top_level for embedded version
 276     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
 277     ### local
 278     $RS = '';
 279     local $_;
 280     while (<POD_DIAG>) {
 281         #s/(.*)\n//;
 282         #$header = $1;
 283
 284         unescape();
 285         if ($PRETTY) {
 286             sub noop   { return $_[0] }  # spensive for a noop
 287             sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; }
 288             sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; }
 289             s/[BC]<(.*?)>/bold($1)/ges;
 290             s/[LIF]<(.*?)>/italic($1)/ges;
 291         } else {
 292             s/[BC]<(.*?)>/$1/gs;
 293             s/[LIF]<(.*?)>/$1/gs;
 294         }
 295         unless (/^=/) {
 296             if (defined $header) {
 297                 if ( $header eq 'DESCRIPTION' &&
 298                     (   /Optional warnings are enabled/
 299                      || /Some of these messages are generic./
 300                     ) )
 301                 {
 302                     next;
 303                 }
 304                 s/^/    /gm;
 305                 $msg{$header} .= $_;
 306             }
 307             next;
 308         }
 309         unless ( s/=item (.*)\s*\Z//) {
 310
 311             if ( s/=head1\sDESCRIPTION//) {
 312                 $msg{$header = 'DESCRIPTION'} = '';
 313             }
 314             next;
 315         }
 316         $header = $1;
 317
 318         if ($header =~ /%[sd]/) {
 319             $rhs = $lhs = $header;
 320             #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g)  {
 321             if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g)  {
 322                 $lhs =~ s/\\%s/.*?/g;
 323             } else {
 324                 # if i had lookbehind negations, i wouldn't have to do this \377 noise
 325                 $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
 326                 #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
 327                 $lhs =~ s/\377([^\377]*)$/\Q$1\E/;
 328                 $lhs =~ s/\377//g;
 329                 $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
 330             }
 331             $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}s\n\t&& return 1;\n";
 332         } else {
 333             $transmo .= "    m{^\Q$header\E} && return 1;\n";
 334         }
 335
 336         print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
 337             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 (defined ($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
 419     # See if we are coming from anywhere within an eval. If so we don't
 420     # want to explain the exception because it's going to get caught.
 421     my $in_eval = 0;
 422     my $i = 0;
 423     while (1) {
 424       my $caller = (caller($i++))[3] or last;
 425       if ($caller eq '(eval)') {
 426         $in_eval = 1;
 427         last;
 428       }
 429     }
 430
 431     splainthis($exception) unless $in_eval;
 432     if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
 433     &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
 434
 435     # We don't want to unset these if we're coming from an eval because
 436     # then we've turned off diagnostics. (Actually what does this next
 437     # line do?  -PSeibel)
 438     $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
 439     local($Carp::CarpLevel) = 1;
 440     confess "Uncaught exception from user code:\n\t$exception";
 441         # up we go; where we stop, nobody knows, but i think we die now
 442         # but i'm deeply afraid of the &$olddie guy reraising and us getting
 443         # into an indirect recursion loop
 444 };
 445
 446 sub splainthis {
 447     local $_ = shift;
 448     ### &finish_compilation unless %msg;
 449     s/\.?\n+$//;
 450     my $orig = $_;
 451     # return unless defined;
 452     if ($exact_duplicate{$_}++) {
 453         return 1;
 454     }
 455     s/, <.*?> (?:line|chunk).*$//;
 456     $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
 457     s/^\((.*)\)$/$1/;
 458     return 0 unless &transmo;
 459     $orig = shorten($orig);
 460     if ($old_diag{$_}) {
 461         autodescribe();
 462         print THITHER "$orig (#$old_diag{$_})\n";
 463         $wantspace = 1;
 464     } else {
 465         autodescribe();
 466         $old_diag{$_} = ++$count;
 467         print THITHER "\n" if $wantspace;
 468         $wantspace = 0;
 469         print THITHER "$orig (#$old_diag{$_})\n";
 470         if ($msg{$_}) {
 471             print THITHER $msg{$_};
 472         } else {
 473             if (0 and $standalone) {
 474                 print THITHER "    **** Error #$old_diag{$_} ",
 475                         ($real ? "is" : "appears to be"),
 476                         " an unknown diagnostic message.\n\n";
 477             }
 478             return 0;
 479         }
 480     }
 481     return 1;
 482 }
 483
 484 sub autodescribe {
 485     if ($VERBOSE and not $count) {
 486         print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
 487                 "\n$msg{DESCRIPTION}\n";
 488     }
 489 }
 490
 491 sub unescape {
 492     s {
 493             E<
 494             ( [A-Za-z]+ )
 495             >
 496     } {
 497          do {
 498              exists $HTML_Escapes{$1}
 499                 ? do { $HTML_Escapes{$1} }
 500                 : do {
 501                     warn "Unknown escape: $& in $_";
 502                     "E<$1>";
 503                 }
 504          }
 505     }egx;
 506 }
 507
 508 sub shorten {
 509     my $line = $_[0];
 510     if (length($line) > 79 and index($line, "\n") == -1) {
 511         my $space_place = rindex($line, ' ', 79);
 512         if ($space_place != -1) {
 513             substr($line, $space_place, 1) = "\n\t";
 514         }
 515     }
 516     return $line;
 517 }
 518
 519
 520 # have to do this: RS isn't set until run time, but we're executing at compile time
 521 $RS = "\n";
 522
 523 1 unless $standalone;  # or it'll complain about itself
 524 __END__ # wish diag dbase were more accessible