lib/diagnostics.pm

   1 package diagnostics;
   2
   3 =head1 NAME
   4
   5 diagnostics, splain - produce verbose warning diagnostics
   6
   7 =head1 SYNOPSIS
   8
   9 Using the C<diagnostics> pragma:
  10
  11     use diagnostics;
  12     use diagnostics -verbose;
  13
  14     enable  diagnostics;
  15     disable diagnostics;
  16
  17 Using the C<splain> standalone filter program:
  18
  19     perl program 2>diag.out
  20     splain [-v] [-p] diag.out
  21
  22 Using diagnostics to get stack traces from a misbehaving script:
  23
  24     perl -Mdiagnostics=-traceonly my_script.pl
  25
  26 =head1 DESCRIPTION
  27
  28 =head2 The C<diagnostics> Pragma
  29
  30 This module extends the terse diagnostics normally emitted by both the
  31 perl compiler and the perl interpreter (from running perl with a -w
  32 switch or C<use warnings>), augmenting them with the more
  33 explicative and endearing descriptions found in L<perldiag>.  Like the
  34 other pragmata, it affects the compilation phase of your program rather
  35 than merely the execution phase.
  36
  37 To use in your program as a pragma, merely invoke
  38
  39     use diagnostics;
  40
  41 at the start (or near the start) of your program.  (Note
  42 that this I<does> enable perl's B<-w> flag.)  Your whole
  43 compilation will then be subject(ed :-) to the enhanced diagnostics.
  44 These still go out B<STDERR>.
  45
  46 Due to the interaction between runtime and compiletime issues,
  47 and because it's probably not a very good idea anyway,
  48 you may not use C<no diagnostics> to turn them off at compiletime.
  49 However, you may control their behaviour at runtime using the
  50 disable() and enable() methods to turn them off and on respectively.
  51
  52 The B<-verbose> flag first prints out the L<perldiag> introduction before
  53 any other diagnostics.  The $diagnostics::PRETTY variable can generate nicer
  54 escape sequences for pagers.
  55
  56 Warnings dispatched from perl itself (or more accurately, those that match
  57 descriptions found in L<perldiag>) are only displayed once (no duplicate
  58 descriptions).  User code generated warnings a la warn() are unaffected,
  59 allowing duplicate user messages to be displayed.
  60
  61 This module also adds a stack trace to the error message when perl dies.
  62 This is useful for pinpointing what
  63 caused the death.  The B<-traceonly> (or
  64 just B<-t>) flag turns off the explanations of warning messages leaving just
  65 the stack traces.  So if your script is dieing, run it again with
  66
  67   perl -Mdiagnostics=-traceonly my_bad_script
  68
  69 to see the call stack at the time of death.  By supplying the B<-warntrace>
  70 (or just B<-w>) flag, any warnings emitted will also come with a stack
  71 trace.
  72
  73 =head2 The I<splain> Program
  74
  75 While apparently a whole nuther program, I<splain> is actually nothing
  76 more than a link to the (executable) F<diagnostics.pm> module, as well as
  77 a link to the F<diagnostics.pod> documentation.  The B<-v> flag is like
  78 the C<use diagnostics -verbose> directive.
  79 The B<-p> flag is like the
  80 $diagnostics::PRETTY variable.  Since you're post-processing with
  81 I<splain>, there's no sense in being able to enable() or disable() processing.
  82
  83 Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
  84
  85 =head1 EXAMPLES
  86
  87 The following file is certain to trigger a few errors at both
  88 runtime and compiletime:
  89
  90     use diagnostics;
  91     print NOWHERE "nothing\n";
  92     print STDERR "\n\tThis message should be unadorned.\n";
  93     warn "\tThis is a user warning";
  94     print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
  95     my $a, $b = scalar <STDIN>;
  96     print "\n";
  97     print $x/$y;
  98
  99 If you prefer to run your program first and look at its problem
 100 afterwards, do this:
 101
 102     perl -w test.pl 2>test.out
 103     ./splain < test.out
 104
 105 Note that this is not in general possible in shells of more dubious heritage,
 106 as the theoretical
 107
 108     (perl -w test.pl >/dev/tty) >& test.out
 109     ./splain < test.out
 110
 111 Because you just moved the existing B<stdout> to somewhere else.
 112
 113 If you don't want to modify your source code, but still have on-the-fly
 114 warnings, do this:
 115
 116     exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
 117
 118 Nifty, eh?
 119
 120 If you want to control warnings on the fly, do something like this.
 121 Make sure you do the C<use> first, or you won't be able to get
 122 at the enable() or disable() methods.
 123
 124     use diagnostics; # checks entire compilation phase
 125         print "\ntime for 1st bogus diags: SQUAWKINGS\n";
 126         print BOGUS1 'nada';
 127         print "done with 1st bogus\n";
 128
 129     disable diagnostics; # only turns off runtime warnings
 130         print "\ntime for 2nd bogus: (squelched)\n";
 131         print BOGUS2 'nada';
 132         print "done with 2nd bogus\n";
 133
 134     enable diagnostics; # turns back on runtime warnings
 135         print "\ntime for 3rd bogus: SQUAWKINGS\n";
 136         print BOGUS3 'nada';
 137         print "done with 3rd bogus\n";
 138
 139     disable diagnostics;
 140         print "\ntime for 4th bogus: (squelched)\n";
 141         print BOGUS4 'nada';
 142         print "done with 4th bogus\n";
 143
 144 =head1 INTERNALS
 145
 146 Diagnostic messages derive from the F<perldiag.pod> file when available at
 147 runtime.  Otherwise, they may be embedded in the file itself when the
 148 splain package is built.   See the F<Makefile> for details.
 149
 150 If an extant $SIG{__WARN__} handler is discovered, it will continue
 151 to be honored, but only after the diagnostics::splainthis() function
 152 (the module's $SIG{__WARN__} interceptor) has had its way with your
 153 warnings.
 154
 155 There is a $diagnostics::DEBUG variable you may set if you're desperately
 156 curious what sorts of things are being intercepted.
 157
 158     BEGIN { $diagnostics::DEBUG = 1 }
 159
 160
 161 =head1 BUGS
 162
 163 Not being able to say "no diagnostics" is annoying, but may not be
 164 insurmountable.
 165
 166 The C<-pretty> directive is called too late to affect matters.
 167 You have to do this instead, and I<before> you load the module.
 168
 169     BEGIN { $diagnostics::PRETTY = 1 }
 170
 171 I could start up faster by delaying compilation until it should be
 172 needed, but this gets a "panic: top_level" when using the pragma form
 173 in Perl 5.001e.
 174
 175 While it's true that this documentation is somewhat subserious, if you use
 176 a program named I<splain>, you should expect a bit of whimsy.
 177
 178 =head1 AUTHOR
 179
 180 Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
 181
 182 =cut
 183
 184 use strict;
 185 use 5.009001;
 186 use Carp;
 187 $Carp::Internal{__PACKAGE__.""}++;
 188
 189 our $VERSION = '1.37';
 190 our $DEBUG;
 191 our $VERBOSE;
 192 our $PRETTY;
 193 our $TRACEONLY = 0;
 194 our $WARNTRACE = 0;
 195
 196 use Config;
 197 use Text::Tabs 'expand';
 198 my $privlib = $Config{privlibexp};
 199 if ($^O eq 'VMS') {
 200     require VMS::Filespec;
 201     $privlib = VMS::Filespec::unixify($privlib);
 202 }
 203 my @trypod = (
 204            "$privlib/pod/perldiag.pod",
 205            "$privlib/pods/perldiag.pod",
 206           );
 207 # handy for development testing of new warnings etc
 208 unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
 209 (my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
 210
 211 $DEBUG ||= 0;
 212
 213 local $| = 1;
 214 local $_;
 215 local $.;
 216
 217 my $standalone;
 218 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
 219
 220 CONFIG: {
 221     our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
 222
 223     unless (caller) {
 224         $standalone++;
 225         require Getopt::Std;
 226         Getopt::Std::getopts('pdvf:')
 227             or die "Usage: $0 [-v] [-p] [-f splainpod]";
 228         $PODFILE = $opt_f if $opt_f;
 229         $DEBUG = 2 if $opt_d;
 230         $VERBOSE = $opt_v;
 231         $PRETTY = $opt_p;
 232     }
 233
 234     if (open(POD_DIAG, '<', $PODFILE)) {
 235         warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
 236         last CONFIG;
 237     }
 238
 239     if (caller) {
 240         INCPATH: {
 241             for my $file ( (map { "$_/".__PACKAGE__.".pm" } @INC), $0) {
 242                 warn "Checking $file\n" if $DEBUG;
 243                 if (open(POD_DIAG, '<', $file)) {
 244                     while (<POD_DIAG>) {
 245                         next unless
 246                             /^__END__\s*# wish diag dbase were more accessible/;
 247                         print STDERR "podfile is $file\n" if $DEBUG;
 248                         last INCPATH;
 249                     }
 250                 }
 251             }
 252         }
 253     } else {
 254         print STDERR "podfile is <DATA>\n" if $DEBUG;
 255         *POD_DIAG = *main::DATA;
 256     }
 257 }
 258 if (eof(POD_DIAG)) {
 259     die "couldn't find diagnostic data in $PODFILE @INC $0";
 260 }
 261
 262
 263 %HTML_2_Troff = (
 264     'amp'       =>      '&',    #   ampersand
 265     'lt'        =>      '<',    #   left chevron, less-than
 266     'gt'        =>      '>',    #   right chevron, greater-than
 267     'quot'      =>      '"',    #   double quote
 268     'sol'       =>      '/',    #   forward slash / solidus
 269     'verbar'    =>      '|',    #   vertical bar
 270
 271     "Aacute"    =>      "A\\*'",        #   capital A, acute accent
 272     # etc
 273
 274 );
 275
 276 %HTML_2_Latin_1 = (
 277     'amp'       =>      '&',    #   ampersand
 278     'lt'        =>      '<',    #   left chevron, less-than
 279     'gt'        =>      '>',    #   right chevron, greater-than
 280     'quot'      =>      '"',    #   double quote
 281     'sol'       =>      '/',    #   Forward slash / solidus
 282     'verbar'    =>      '|',    #   vertical bar
 283
 284     "Aacute"    =>      "\xC1"  #   capital A, acute accent
 285
 286     # etc
 287 );
 288
 289 %HTML_2_ASCII_7 = (
 290     'amp'       =>      '&',    #   ampersand
 291     'lt'        =>      '<',    #   left chevron, less-than
 292     'gt'        =>      '>',    #   right chevron, greater-than
 293     'quot'      =>      '"',    #   double quote
 294     'sol'       =>      '/',    #   Forward slash / solidus
 295     'verbar'    =>      '|',    #   vertical bar
 296
 297     "Aacute"    =>      "A"     #   capital A, acute accent
 298     # etc
 299 );
 300
 301 our %HTML_Escapes;
 302 *HTML_Escapes = do {
 303     if ($standalone) {
 304         $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
 305     } else {
 306         \%HTML_2_Latin_1;
 307     }
 308 };
 309
 310 *THITHER = $standalone ? *STDOUT : *STDERR;
 311
 312 my %transfmt = ();
 313 my $transmo = <<EOFUNC;
 314 sub transmo {
 315     #local \$^W = 0;  # recursive warnings we do NOT need!
 316 EOFUNC
 317
 318 my %msg;
 319 my $over_level = 0;     # We look only at =item lines at the first =over level
 320 {
 321     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
 322     local $/ = '';
 323     local $_;
 324     my $header;
 325     my @headers;
 326     my $for_item;
 327     my $seen_body;
 328     while (<POD_DIAG>) {
 329
 330         sub _split_pod_link {
 331             $_[0] =~ m'(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?'s;
 332             ($1,$2,$4);
 333         }
 334
 335         unescape();
 336         if ($PRETTY) {
 337             sub noop   { return $_[0] }  # spensive for a noop
 338             sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; }
 339             sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; }
 340             s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
 341             s/[IF]<(.*?)>/italic($1)/ges;
 342             s/L<(.*?)>/
 343                my($text,$page,$sect) = _split_pod_link($1);
 344                defined $text
 345                 ? $text
 346                 : defined $sect
 347                    ? italic($sect) . ' in ' . italic($page)
 348                    : italic($page)
 349              /ges;
 350              s/S<(.*?)>/
 351                $1
 352              /ges;
 353         } else {
 354             s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
 355             s/[IF]<(.*?)>/$1/gs;
 356             s/L<(.*?)>/
 357                my($text,$page,$sect) = _split_pod_link($1);
 358                defined $text
 359                 ? $text
 360                 : defined $sect
 361                    ? qq '"$sect" in $page'
 362                    : $page
 363              /ges;
 364             s/S<(.*?)>/
 365                $1
 366              /ges;
 367         }
 368         unless (/^=/) {
 369             if (defined $header) {
 370                 if ( $header eq 'DESCRIPTION' &&
 371                     (   /Optional warnings are enabled/
 372                      || /Some of these messages are generic./
 373                     ) )
 374                 {
 375                     next;
 376                 }
 377                 $_ = expand $_;
 378                 s/^/    /gm;
 379                 $msg{$header} .= $_;
 380                 for my $h(@headers) { $msg{$h} .= $_ }
 381                 ++$seen_body;
 382                 undef $for_item;
 383             }
 384             next;
 385         }
 386
 387         # If we have not come across the body of the description yet, then
 388         # the previous header needs to share the same description.
 389         if ($seen_body) {
 390             @headers = ();
 391         }
 392         else {
 393             push @headers, $header if defined $header;
 394         }
 395
 396         if ( ! s/=item (.*?)\s*\z//s || $over_level != 1) {
 397
 398             if ( s/=head1\sDESCRIPTION//) {
 399                 $msg{$header = 'DESCRIPTION'} = '';
 400                 undef $for_item;
 401             }
 402             elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
 403                 $for_item = $1;
 404             }
 405             elsif( /^=over\b/ ) {
 406                 $over_level++;
 407             }
 408             elsif( /^=back\b/ ) { # Stop processing body here
 409                 $over_level--;
 410                 if ($over_level == 0) {
 411                     undef $header;
 412                     undef $for_item;
 413                     $seen_body = 0;
 414                     next;
 415                 }
 416             }
 417             next;
 418         }
 419
 420         if( $for_item ) { $header = $for_item; undef $for_item }
 421         else {
 422             $header = $1;
 423
 424             $header =~ s/\n/ /gs; # Allow multi-line headers
 425         }
 426
 427         # strip formatting directives from =item line
 428         $header =~ s/[A-Z]<(.*?)>/$1/g;
 429
 430         # Since we strip "(\.\s*)\n" when we search a warning, strip it here as well
 431         $header =~ s/(\.\s*)?$//;
 432
 433         my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header );
 434         if (@toks > 1) {
 435             my $conlen = 0;
 436             for my $i (0..$#toks){
 437                 if( $i % 2 ){
 438                     if(      $toks[$i] eq '%c' ){
 439                         $toks[$i] = '.';
 440                     } elsif( $toks[$i] =~ /^%(?:d|u)$/ ){
 441                         $toks[$i] = '\d+';
 442                     } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
 443                         $toks[$i] = $i == $#toks ? '.*' : '.*?';
 444                     } elsif( $toks[$i] =~ '%.(\d+)s' ){
 445                         $toks[$i] = ".{$1}";
 446                     } elsif( $toks[$i] =~ '^%l*([pxX])$' ){
 447                         $toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+';
 448                     }
 449                 } elsif( length( $toks[$i] ) ){
 450                     $toks[$i] = quotemeta $toks[$i];
 451                     $conlen += length( $toks[$i] );
 452                 }
 453             }
 454             my $lhs = join( '', @toks );
 455             $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
 456             $transfmt{$header}{pat} =
 457               "    s\a^\\s*$lhs\\s*\a\Q$header\E\as\n\t&& return 1;\n";
 458             $transfmt{$header}{len} = $conlen;
 459         } else {
 460             my $lhs = "\Q$header\E";
 461             $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
 462             $transfmt{$header}{pat} =
 463               "    s\a^\\s*$lhs\\s*\a\Q$header\E\a\n\t && return 1;\n";
 464             $transfmt{$header}{len} = length( $header );
 465         }
 466
 467         print STDERR __PACKAGE__.": Duplicate entry: \"$header\"\n"
 468             if $msg{$header};
 469
 470         $msg{$header} = '';
 471         $seen_body = 0;
 472     }
 473
 474
 475     close POD_DIAG unless *main::DATA eq *POD_DIAG;
 476
 477     die "No diagnostics?" unless %msg;
 478
 479     # Apply patterns in order of decreasing sum of lengths of fixed parts
 480     # Seems the best way of hitting the right one.
 481     for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
 482                   keys %transfmt ){
 483         $transmo .= $transfmt{$hdr}{pat};
 484     }
 485     $transmo .= "    return 0;\n}\n";
 486     print STDERR $transmo if $DEBUG;
 487     eval $transmo;
 488     die $@ if $@;
 489 }
 490
 491 if ($standalone) {
 492     if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
 493     while (defined (my $error = <>)) {
 494         splainthis($error) || print THITHER $error;
 495     }
 496     exit;
 497 }
 498
 499 my $olddie;
 500 my $oldwarn;
 501
 502 sub import {
 503     shift;
 504     $^W = 1; # yup, clobbered the global variable;
 505              # tough, if you want diags, you want diags.
 506     return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
 507
 508     for (@_) {
 509
 510         /^-d(ebug)?$/           && do {
 511                                     $DEBUG++;
 512                                     next;
 513                                    };
 514
 515         /^-v(erbose)?$/         && do {
 516                                     $VERBOSE++;
 517                                     next;
 518                                    };
 519
 520         /^-p(retty)?$/          && do {
 521                                     print STDERR "$0: I'm afraid it's too late for prettiness.\n";
 522                                     $PRETTY++;
 523                                     next;
 524                                };
 525         # matches trace and traceonly for legacy doc mixup reasons
 526         /^-t(race(only)?)?$/    && do {
 527                                     $TRACEONLY++;
 528                                     next;
 529                                };
 530         /^-w(arntrace)?$/       && do {
 531                                     $WARNTRACE++;
 532                                     next;
 533                                };
 534
 535         warn "Unknown flag: $_";
 536     }
 537
 538     $oldwarn = $SIG{__WARN__};
 539     $olddie = $SIG{__DIE__};
 540     $SIG{__WARN__} = \&warn_trap;
 541     $SIG{__DIE__} = \&death_trap;
 542 }
 543
 544 sub enable { &import }
 545
 546 sub disable {
 547     shift;
 548     return unless $SIG{__WARN__} eq \&warn_trap;
 549     $SIG{__WARN__} = $oldwarn || '';
 550     $SIG{__DIE__} = $olddie || '';
 551 }
 552
 553 sub warn_trap {
 554     my $warning = $_[0];
 555     if (caller eq __PACKAGE__ or !splainthis($warning)) {
 556         if ($WARNTRACE) {
 557             print STDERR Carp::longmess($warning);
 558         } else {
 559             print STDERR $warning;
 560         }
 561     }
 562     goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
 563 };
 564
 565 sub death_trap {
 566     my $exception = $_[0];
 567
 568     # See if we are coming from anywhere within an eval. If so we don't
 569     # want to explain the exception because it's going to get caught.
 570     my $in_eval = 0;
 571     my $i = 0;
 572     while (my $caller = (caller($i++))[3]) {
 573       if ($caller eq '(eval)') {
 574         $in_eval = 1;
 575         last;
 576       }
 577     }
 578
 579     splainthis($exception) unless $in_eval;
 580     if (caller eq __PACKAGE__) {
 581         print STDERR "INTERNAL EXCEPTION: $exception";
 582     }
 583     &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
 584
 585     return if $in_eval;
 586
 587     # We don't want to unset these if we're coming from an eval because
 588     # then we've turned off diagnostics.
 589
 590     # Switch off our die/warn handlers so we don't wind up in our own
 591     # traps.
 592     $SIG{__DIE__} = $SIG{__WARN__} = '';
 593
 594     $exception =~ s/\n(?=.)/\n\t/gas;
 595
 596     die Carp::longmess("__diagnostics__")
 597           =~ s/^__diagnostics__.*?line \d+\.?\n/
 598                   "Uncaught exception from user code:\n\t$exception"
 599               /re;
 600         # up we go; where we stop, nobody knows, but i think we die now
 601         # but i'm deeply afraid of the &$olddie guy reraising and us getting
 602         # into an indirect recursion loop
 603 };
 604
 605 my %exact_duplicate;
 606 my %old_diag;
 607 my $count;
 608 my $wantspace;
 609 sub splainthis {
 610   return 0 if $TRACEONLY;
 611   for (my $tmp = shift) {
 612     local $\;
 613     local $!;
 614     ### &finish_compilation unless %msg;
 615     s/(\.\s*)?\n+$//;
 616     my $orig = $_;
 617     # return unless defined;
 618
 619     # get rid of the where-are-we-in-input part
 620     s/, <.*?> (?:line|chunk).*$//;
 621
 622     # Discard 1st " at <file> line <no>" and all text beyond
 623     # but be aware of messages containing " at this-or-that"
 624     my $real = 0;
 625     my @secs = split( / at / );
 626     return unless @secs;
 627     $_ = $secs[0];
 628     for my $i ( 1..$#secs ){
 629         if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
 630             $real = 1;
 631             last;
 632         } else {
 633             $_ .= ' at ' . $secs[$i];
 634         }
 635     }
 636
 637     # remove parenthesis occurring at the end of some messages
 638     s/^\((.*)\)$/$1/;
 639
 640     if ($exact_duplicate{$orig}++) {
 641         return &transmo;
 642     } else {
 643         return 0 unless &transmo;
 644     }
 645
 646     my $short = shorten($orig);
 647     if ($old_diag{$_}) {
 648         autodescribe();
 649         print THITHER "$short (#$old_diag{$_})\n";
 650         $wantspace = 1;
 651     } elsif (!$msg{$_} && $orig =~ /\n./s) {
 652         # A multiline message, like "Attempt to reload /
 653         # Compilation failed"
 654         my $found;
 655         for (split /^/, $orig) {
 656             splainthis($_) and $found = 1;
 657         }
 658         return $found;
 659     } else {
 660         autodescribe();
 661         $old_diag{$_} = ++$count;
 662         print THITHER "\n" if $wantspace;
 663         $wantspace = 0;
 664         print THITHER "$short (#$old_diag{$_})\n";
 665         if ($msg{$_}) {
 666             print THITHER $msg{$_};
 667         } else {
 668             if (0 and $standalone) {
 669                 print THITHER "    **** Error #$old_diag{$_} ",
 670                         ($real ? "is" : "appears to be"),
 671                         " an unknown diagnostic message.\n\n";
 672             }
 673             return 0;
 674         }
 675     }
 676     return 1;
 677   }
 678 }
 679
 680 sub autodescribe {
 681     if ($VERBOSE and not $count) {
 682         print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
 683                 "\n$msg{DESCRIPTION}\n";
 684     }
 685 }
 686
 687 sub unescape {
 688     s {
 689             E<
 690             ( [A-Za-z]+ )
 691             >
 692     } {
 693          do {
 694              exists $HTML_Escapes{$1}
 695                 ? do { $HTML_Escapes{$1} }
 696                 : do {
 697                     warn "Unknown escape: E<$1> in $_";
 698                     "E<$1>";
 699                 }
 700          }
 701     }egx;
 702 }
 703
 704 sub shorten {
 705     my $line = $_[0];
 706     if (length($line) > 79 and index($line, "\n") == -1) {
 707         my $space_place = rindex($line, ' ', 79);
 708         if ($space_place != -1) {
 709             substr($line, $space_place, 1) = "\n\t";
 710         }
 711     }
 712     return $line;
 713 }
 714
 715
 716 1 unless $standalone;  # or it'll complain about itself
 717 __END__ # wish diag dbase were more accessible