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 use 5.005_64;
 171 use Carp;
 172
 173 $VERSION = v1.0;
 174
 175 use Config;
 176 ($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
 177 if ($^O eq 'VMS') {
 178     require VMS::Filespec;
 179     $privlib = VMS::Filespec::unixify($privlib);
 180     $archlib = VMS::Filespec::unixify($archlib);
 181 }
 182 @trypod = (
 183            "$archlib/pod/perldiag.pod",
 184            "$privlib/pod/perldiag-$Config{version}.pod",
 185            "$privlib/pod/perldiag.pod",
 186            "$archlib/pods/perldiag.pod",
 187            "$privlib/pods/perldiag-$Config{version}.pod",
 188            "$privlib/pods/perldiag.pod",
 189           );
 190 # handy for development testing of new warnings etc
 191 unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
 192 ($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
 193
 194 $DEBUG ||= 0;
 195 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
 196
 197 $| = 1;
 198
 199 local $_;
 200
 201 CONFIG: {
 202     $opt_p = $opt_d = $opt_v = $opt_f = '';
 203     %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();
 204     %exact_duplicate = ();
 205
 206     unless (caller) {
 207         $standalone++;
 208         require Getopt::Std;
 209         Getopt::Std::getopts('pdvf:')
 210             or die "Usage: $0 [-v] [-p] [-f splainpod]";
 211         $PODFILE = $opt_f if $opt_f;
 212         $DEBUG = 2 if $opt_d;
 213         $VERBOSE = $opt_v;
 214         $PRETTY = $opt_p;
 215     }
 216
 217     if (open(POD_DIAG, $PODFILE)) {
 218         warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
 219         last CONFIG;
 220     }
 221
 222     if (caller) {
 223         INCPATH: {
 224             for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
 225                 warn "Checking $file\n" if $DEBUG;
 226                 if (open(POD_DIAG, $file)) {
 227                     while (<POD_DIAG>) {
 228                         next unless /^__END__\s*# wish diag dbase were more accessible/;
 229                         print STDERR "podfile is $file\n" if $DEBUG;
 230                         last INCPATH;
 231                     }
 232                 }
 233             }
 234         }
 235     } else {
 236         print STDERR "podfile is <DATA>\n" if $DEBUG;
 237         *POD_DIAG = *main::DATA;
 238     }
 239 }
 240 if (eof(POD_DIAG)) {
 241     die "couldn't find diagnostic data in $PODFILE @INC $0";
 242 }
 243
 244
 245 %HTML_2_Troff = (
 246     'amp'       =>      '&',    #   ampersand
 247     'lt'        =>      '<',    #   left chevron, less-than
 248     'gt'        =>      '>',    #   right chevron, greater-than
 249     'quot'      =>      '"',    #   double quote
 250
 251     "Aacute"    =>      "A\\*'",        #   capital A, acute accent
 252     # etc
 253
 254 );
 255
 256 %HTML_2_Latin_1 = (
 257     'amp'       =>      '&',    #   ampersand
 258     'lt'        =>      '<',    #   left chevron, less-than
 259     'gt'        =>      '>',    #   right chevron, greater-than
 260     'quot'      =>      '"',    #   double quote
 261
 262     "Aacute"    =>      "\xC1"  #   capital A, acute accent
 263
 264     # etc
 265 );
 266
 267 %HTML_2_ASCII_7 = (
 268     'amp'       =>      '&',    #   ampersand
 269     'lt'        =>      '<',    #   left chevron, less-than
 270     'gt'        =>      '>',    #   right chevron, greater-than
 271     'quot'      =>      '"',    #   double quote
 272
 273     "Aacute"    =>      "A"     #   capital A, acute accent
 274     # etc
 275 );
 276
 277 *HTML_Escapes = do {
 278     if ($standalone) {
 279         $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
 280     } else {
 281         \%HTML_2_Latin_1;
 282     }
 283 };
 284
 285 *THITHER = $standalone ? *STDOUT : *STDERR;
 286
 287 $transmo = <<EOFUNC;
 288 sub transmo {
 289     #local \$^W = 0;  # recursive warnings we do NOT need!
 290     study;
 291 EOFUNC
 292
 293 ### sub finish_compilation {  # 5.001e panic: top_level for embedded version
 294     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
 295     ### local
 296     $RS = '';
 297     local $_;
 298     while (<POD_DIAG>) {
 299         #s/(.*)\n//;
 300         #$header = $1;
 301
 302         unescape();
 303         if ($PRETTY) {
 304             sub noop   { return $_[0] }  # spensive for a noop
 305             sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; }
 306             sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; }
 307             s/[BC]<(.*?)>/bold($1)/ges;
 308             s/[LIF]<(.*?)>/italic($1)/ges;
 309         } else {
 310             s/[BC]<(.*?)>/$1/gs;
 311             s/[LIF]<(.*?)>/$1/gs;
 312         }
 313         unless (/^=/) {
 314             if (defined $header) {
 315                 if ( $header eq 'DESCRIPTION' &&
 316                     (   /Optional warnings are enabled/
 317                      || /Some of these messages are generic./
 318                     ) )
 319                 {
 320                     next;
 321                 }
 322                 s/^/    /gm;
 323                 $msg{$header} .= $_;
 324             }
 325             next;
 326         }
 327         unless ( s/=item (.*)\s*\Z//) {
 328
 329             if ( s/=head1\sDESCRIPTION//) {
 330                 $msg{$header = 'DESCRIPTION'} = '';
 331             }
 332             next;
 333         }
 334
 335         # strip formatting directives in =item line
 336         ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g;
 337
 338         if ($header =~ /%[csd]/) {
 339             $rhs = $lhs = $header;
 340             #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g)  {
 341             if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g)  {
 342                 $lhs =~ s/\\%s/.*?/g;
 343             } else {
 344                 # if i had lookbehind negations, i wouldn't have to do this \377 noise
 345                 $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
 346                 #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
 347                 $lhs =~ s/\377([^\377]*)$/\Q$1\E/;
 348                 $lhs =~ s/\377//g;
 349                 $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
 350             }
 351             $lhs =~ s/\\%c/./g;
 352             $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}s\n\t&& return 1;\n";
 353         } else {
 354             $transmo .= "    m{^\Q$header\E} && return 1;\n";
 355         }
 356
 357         print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
 358             if $msg{$header};
 359
 360         $msg{$header} = '';
 361     }
 362
 363
 364     close POD_DIAG unless *main::DATA eq *POD_DIAG;
 365
 366     die "No diagnostics?" unless %msg;
 367
 368     $transmo .= "    return 0;\n}\n";
 369     print STDERR $transmo if $DEBUG;
 370     eval $transmo;
 371     die $@ if $@;
 372     $RS = "\n";
 373 ### }
 374
 375 if ($standalone) {
 376     if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
 377     while (defined ($error = <>)) {
 378         splainthis($error) || print THITHER $error;
 379     }
 380     exit;
 381 } else {
 382     #$old_w = 0;
 383     $oldwarn = ''; $olddie = '';
 384 }
 385
 386 sub import {
 387     shift;
 388     #$old_w = $^W;
 389     $^W = 1; # yup, clobbered the global variable; tough, if you
 390              # want diags, you want diags.
 391     return if $SIG{__WARN__} eq \&warn_trap;
 392
 393     for (@_) {
 394
 395         /^-d(ebug)?$/           && do {
 396                                     $DEBUG++;
 397                                     next;
 398                                    };
 399
 400         /^-v(erbose)?$/         && do {
 401                                     $VERBOSE++;
 402                                     next;
 403                                    };
 404
 405         /^-p(retty)?$/          && do {
 406                                     print STDERR "$0: I'm afraid it's too late for prettiness.\n";
 407                                     $PRETTY++;
 408                                     next;
 409                                };
 410
 411         warn "Unknown flag: $_";
 412     }
 413
 414     $oldwarn = $SIG{__WARN__};
 415     $olddie = $SIG{__DIE__};
 416     $SIG{__WARN__} = \&warn_trap;
 417     $SIG{__DIE__} = \&death_trap;
 418 }
 419
 420 sub enable { &import }
 421
 422 sub disable {
 423     shift;
 424     #$^W = $old_w;
 425     return unless $SIG{__WARN__} eq \&warn_trap;
 426     $SIG{__WARN__} = $oldwarn;
 427     $SIG{__DIE__} = $olddie;
 428 }
 429
 430 sub warn_trap {
 431     my $warning = $_[0];
 432     if (caller eq $WHOAMI or !splainthis($warning)) {
 433         print STDERR $warning;
 434     }
 435     &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
 436 };
 437
 438 sub death_trap {
 439     my $exception = $_[0];
 440
 441     # See if we are coming from anywhere within an eval. If so we don't
 442     # want to explain the exception because it's going to get caught.
 443     my $in_eval = 0;
 444     my $i = 0;
 445     while (1) {
 446       my $caller = (caller($i++))[3] or last;
 447       if ($caller eq '(eval)') {
 448         $in_eval = 1;
 449         last;
 450       }
 451     }
 452
 453     splainthis($exception) unless $in_eval;
 454     if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
 455     &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
 456
 457     # We don't want to unset these if we're coming from an eval because
 458     # then we've turned off diagnostics. (Actually what does this next
 459     # line do?  -PSeibel)
 460     $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
 461     local($Carp::CarpLevel) = 1;
 462     confess "Uncaught exception from user code:\n\t$exception";
 463         # up we go; where we stop, nobody knows, but i think we die now
 464         # but i'm deeply afraid of the &$olddie guy reraising and us getting
 465         # into an indirect recursion loop
 466 };
 467
 468 sub splainthis {
 469     local $_ = shift;
 470     local $\;
 471     ### &finish_compilation unless %msg;
 472     s/\.?\n+$//;
 473     my $orig = $_;
 474     # return unless defined;
 475     s/, <.*?> (?:line|chunk).*$//;
 476     $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
 477     s/^\((.*)\)$/$1/;
 478     if ($exact_duplicate{$orig}++) {
 479         return &transmo;
 480     }
 481     else {
 482         return 0 unless &transmo;
 483     }
 484     $orig = shorten($orig);
 485     if ($old_diag{$_}) {
 486         autodescribe();
 487         print THITHER "$orig (#$old_diag{$_})\n";
 488         $wantspace = 1;
 489     } else {
 490         autodescribe();
 491         $old_diag{$_} = ++$count;
 492         print THITHER "\n" if $wantspace;
 493         $wantspace = 0;
 494         print THITHER "$orig (#$old_diag{$_})\n";
 495         if ($msg{$_}) {
 496             print THITHER $msg{$_};
 497         } else {
 498             if (0 and $standalone) {
 499                 print THITHER "    **** Error #$old_diag{$_} ",
 500                         ($real ? "is" : "appears to be"),
 501                         " an unknown diagnostic message.\n\n";
 502             }
 503             return 0;
 504         }
 505     }
 506     return 1;
 507 }
 508
 509 sub autodescribe {
 510     if ($VERBOSE and not $count) {
 511         print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
 512                 "\n$msg{DESCRIPTION}\n";
 513     }
 514 }
 515
 516 sub unescape {
 517     s {
 518             E<
 519             ( [A-Za-z]+ )
 520             >
 521     } {
 522          do {
 523              exists $HTML_Escapes{$1}
 524                 ? do { $HTML_Escapes{$1} }
 525                 : do {
 526                     warn "Unknown escape: E<$1> in $_";
 527                     "E<$1>";
 528                 }
 529          }
 530     }egx;
 531 }
 532
 533 sub shorten {
 534     my $line = $_[0];
 535     if (length($line) > 79 and index($line, "\n") == -1) {
 536         my $space_place = rindex($line, ' ', 79);
 537         if ($space_place != -1) {
 538             substr($line, $space_place, 1) = "\n\t";
 539         }
 540     }
 541     return $line;
 542 }
 543
 544
 545 # have to do this: RS isn't set until run time, but we're executing at compiletime
 546 $RS = "\n";
 547
 548 1 unless $standalone;  # or it'll complain about itself
 549 __END__ # wish diag dbase were more accessible