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