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             }
 330             $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}\n\t&& return 1;\n";
 331         } else {
 332             $transmo .= "    m{^\Q$header\E} && return 1;\n";
 333         }
 334
 335         print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
 336             if $msg{$header};
 337
 338         $msg{$header} = '';
 339     }
 340
 341
 342     close POD_DIAG unless *main::DATA eq *POD_DIAG;
 343
 344     die "No diagnostics?" unless %msg;
 345
 346     $transmo .= "    return 0;\n}\n";
 347     print STDERR $transmo if $DEBUG;
 348     eval $transmo;
 349     die $@ if $@;
 350     $RS = "\n";
 351 ### }
 352
 353 if ($standalone) {
 354     if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
 355     while ($error = <>) {
 356         splainthis($error) || print THITHER $error;
 357     }
 358     exit;
 359 } else {
 360     $old_w = 0; $oldwarn = ''; $olddie = '';
 361 }
 362
 363 sub import {
 364     shift;
 365     $old_w = $^W;
 366     $^W = 1; # yup, clobbered the global variable; tough, if you
 367              # want diags, you want diags.
 368     return if $SIG{__WARN__} eq \&warn_trap;
 369
 370     for (@_) {
 371
 372         /^-d(ebug)?$/           && do {
 373                                     $DEBUG++;
 374                                     next;
 375                                    };
 376
 377         /^-v(erbose)?$/         && do {
 378                                     $VERBOSE++;
 379                                     next;
 380                                    };
 381
 382         /^-p(retty)?$/          && do {
 383                                     print STDERR "$0: I'm afraid it's too late for prettiness.\n";
 384                                     $PRETTY++;
 385                                     next;
 386                                };
 387
 388         warn "Unknown flag: $_";
 389     }
 390
 391     $oldwarn = $SIG{__WARN__};
 392     $olddie = $SIG{__DIE__};
 393     $SIG{__WARN__} = \&warn_trap;
 394     $SIG{__DIE__} = \&death_trap;
 395 }
 396
 397 sub enable { &import }
 398
 399 sub disable {
 400     shift;
 401     $^W = $old_w;
 402     return unless $SIG{__WARN__} eq \&warn_trap;
 403     $SIG{__WARN__} = $oldwarn;
 404     $SIG{__DIE__} = $olddie;
 405 }
 406
 407 sub warn_trap {
 408     my $warning = $_[0];
 409     if (caller eq $WHOAMI or !splainthis($warning)) {
 410         print STDERR $warning;
 411     }
 412     &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
 413 };
 414
 415 sub death_trap {
 416     my $exception = $_[0];
 417
 418     # See if we are coming from anywhere within an eval. If so we don't
 419     # want to explain the exception because it's going to get caught.
 420     my $in_eval = 0;
 421     my $i = 0;
 422     while (1) {
 423       my $caller = (caller($i++))[3] or last;
 424       if ($caller eq '(eval)') {
 425         $in_eval = 1;
 426         last;
 427       }
 428     }
 429
 430     splainthis($exception) unless $in_eval;
 431     if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
 432     &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
 433
 434     # We don't want to unset these if we're coming from an eval because
 435     # then we've turned off diagnostics. (Actually what does this next
 436     # line do?  -PSeibel)
 437     $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
 438     local($Carp::CarpLevel) = 1;
 439     confess "Uncaught exception from user code:\n\t$exception";
 440         # up we go; where we stop, nobody knows, but i think we die now
 441         # but i'm deeply afraid of the &$olddie guy reraising and us getting
 442         # into an indirect recursion loop
 443 };
 444
 445 sub splainthis {
 446     local $_ = shift;
 447     ### &finish_compilation unless %msg;
 448     s/\.?\n+$//;
 449     my $orig = $_;
 450     # return unless defined;
 451     if ($exact_duplicate{$_}++) {
 452         return 1;
 453     }
 454     s/, <.*?> (?:line|chunk).*$//;
 455     $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
 456     s/^\((.*)\)$/$1/;
 457     return 0 unless &transmo;
 458     $orig = shorten($orig);
 459     if ($old_diag{$_}) {
 460         autodescribe();
 461         print THITHER "$orig (#$old_diag{$_})\n";
 462         $wantspace = 1;
 463     } else {
 464         autodescribe();
 465         $old_diag{$_} = ++$count;
 466         print THITHER "\n" if $wantspace;
 467         $wantspace = 0;
 468         print THITHER "$orig (#$old_diag{$_})\n";
 469         if ($msg{$_}) {
 470             print THITHER $msg{$_};
 471         } else {
 472             if (0 and $standalone) {
 473                 print THITHER "    **** Error #$old_diag{$_} ",
 474                         ($real ? "is" : "appears to be"),
 475                         " an unknown diagnostic message.\n\n";
 476             }
 477             return 0;
 478         }
 479     }
 480     return 1;
 481 }
 482
 483 sub autodescribe {
 484     if ($VERBOSE and not $count) {
 485         print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
 486                 "\n$msg{DESCRIPTION}\n";
 487     }
 488 }
 489
 490 sub unescape {
 491     s {
 492             E<
 493             ( [A-Za-z]+ )
 494             >
 495     } {
 496          do {
 497              exists $HTML_Escapes{$1}
 498                 ? do { $HTML_Escapes{$1} }
 499                 : do {
 500                     warn "Unknown escape: $& in $_";
 501                     "E<$1>";
 502                 }
 503          }
 504     }egx;
 505 }
 506
 507 sub shorten {
 508     my $line = $_[0];
 509     if (length $line > 79) {
 510         my $space_place = rindex($line, ' ', 79);
 511         if ($space_place != -1) {
 512             substr($line, $space_place, 1) = "\n\t";
 513         }
 514     }
 515     return $line;
 516 }
 517
 518
 519 # have to do this: RS isn't set until run time, but we're executing at compile time
 520 $RS = "\n";
 521
 522 1 unless $standalone;  # or it'll complain about itself
 523 __END__ # wish diag dbase were more accessible