"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/diagnostics.pm" (8 Mar 2018, 19038 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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.36';
  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 
  269     "Aacute"    =>  "A\\*'",    #   capital A, acute accent
  270     # etc
  271 
  272 );
  273 
  274 %HTML_2_Latin_1 = (
  275     'amp'   =>  '&',    #   ampersand
  276     'lt'    =>  '<',    #   left chevron, less-than
  277     'gt'    =>  '>',    #   right chevron, greater-than
  278     'quot'  =>  '"',    #   double quote
  279 
  280     "Aacute"    =>  "\xC1"  #   capital A, acute accent
  281 
  282     # etc
  283 );
  284 
  285 %HTML_2_ASCII_7 = (
  286     'amp'   =>  '&',    #   ampersand
  287     'lt'    =>  '<',    #   left chevron, less-than
  288     'gt'    =>  '>',    #   right chevron, greater-than
  289     'quot'  =>  '"',    #   double quote
  290 
  291     "Aacute"    =>  "A" #   capital A, acute accent
  292     # etc
  293 );
  294 
  295 our %HTML_Escapes;
  296 *HTML_Escapes = do {
  297     if ($standalone) {
  298     $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; 
  299     } else {
  300     \%HTML_2_Latin_1; 
  301     }
  302 }; 
  303 
  304 *THITHER = $standalone ? *STDOUT : *STDERR;
  305 
  306 my %transfmt = (); 
  307 my $transmo = <<EOFUNC;
  308 sub transmo {
  309     #local \$^W = 0;  # recursive warnings we do NOT need!
  310 EOFUNC
  311 
  312 my %msg;
  313 my $over_level = 0;     # We look only at =item lines at the first =over level
  314 {
  315     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
  316     local $/ = '';
  317     local $_;
  318     my $header;
  319     my @headers;
  320     my $for_item;
  321     my $seen_body;
  322     while (<POD_DIAG>) {
  323 
  324     sub _split_pod_link {
  325         $_[0] =~ m'(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?'s;
  326         ($1,$2,$4);
  327     }
  328 
  329     unescape();
  330     if ($PRETTY) {
  331         sub noop   { return $_[0] }  # spensive for a noop
  332         sub bold   { my $str =$_[0];  $str =~ s/(.)/$1\b$1/g; return $str; } 
  333         sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g;  return $str; } 
  334         s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
  335         s/[IF]<(.*?)>/italic($1)/ges;
  336         s/L<(.*?)>/
  337            my($text,$page,$sect) = _split_pod_link($1);
  338            defined $text
  339             ? $text
  340             : defined $sect
  341                ? italic($sect) . ' in ' . italic($page)
  342                : italic($page)
  343          /ges;
  344          s/S<(.*?)>/
  345                $1
  346              /ges;
  347     } else {
  348         s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
  349         s/[IF]<(.*?)>/$1/gs;
  350         s/L<(.*?)>/
  351            my($text,$page,$sect) = _split_pod_link($1);
  352            defined $text
  353             ? $text
  354             : defined $sect
  355                ? qq '"$sect" in $page'
  356                : $page
  357          /ges;
  358         s/S<(.*?)>/
  359                $1
  360              /ges;
  361     } 
  362     unless (/^=/) {
  363         if (defined $header) { 
  364         if ( $header eq 'DESCRIPTION' && 
  365             (   /Optional warnings are enabled/ 
  366              || /Some of these messages are generic./
  367             ) )
  368         {
  369             next;
  370         }
  371         $_ = expand $_;
  372         s/^/    /gm;
  373         $msg{$header} .= $_;
  374         for my $h(@headers) { $msg{$h} .= $_ }
  375         ++$seen_body;
  376         undef $for_item;    
  377         }
  378         next;
  379     } 
  380 
  381     # If we have not come across the body of the description yet, then
  382     # the previous header needs to share the same description.
  383     if ($seen_body) {
  384         @headers = ();
  385     }
  386     else {
  387         push @headers, $header if defined $header;
  388     }
  389 
  390     if ( ! s/=item (.*?)\s*\z//s || $over_level != 1) {
  391 
  392         if ( s/=head1\sDESCRIPTION//) {
  393         $msg{$header = 'DESCRIPTION'} = '';
  394         undef $for_item;
  395         }
  396         elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
  397         $for_item = $1;
  398         }
  399         elsif( /^=over\b/ ) {
  400                 $over_level++;
  401             }
  402         elsif( /^=back\b/ ) { # Stop processing body here
  403                 $over_level--;
  404                 if ($over_level == 0) {
  405                     undef $header;
  406                     undef $for_item;
  407                     $seen_body = 0;
  408                     next;
  409                 }
  410         }
  411         next;
  412     }
  413 
  414     if( $for_item ) { $header = $for_item; undef $for_item } 
  415     else {
  416         $header = $1;
  417 
  418         $header =~ s/\n/ /gs; # Allow multi-line headers
  419     }
  420 
  421     # strip formatting directives from =item line
  422     $header =~ s/[A-Z]<(.*?)>/$1/g;
  423 
  424     # Since we strip "(\.\s*)\n" when we search a warning, strip it here as well
  425     $header =~ s/(\.\s*)?$//;
  426 
  427         my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header );
  428     if (@toks > 1) {
  429             my $conlen = 0;
  430             for my $i (0..$#toks){
  431                 if( $i % 2 ){
  432                     if(      $toks[$i] eq '%c' ){
  433                         $toks[$i] = '.';
  434                     } elsif( $toks[$i] =~ /^%(?:d|u)$/ ){
  435                         $toks[$i] = '\d+';
  436                     } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
  437                         $toks[$i] = $i == $#toks ? '.*' : '.*?';
  438                     } elsif( $toks[$i] =~ '%.(\d+)s' ){
  439                         $toks[$i] = ".{$1}";
  440                     } elsif( $toks[$i] =~ '^%l*([pxX])$' ){
  441                         $toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+';
  442                     }
  443                 } elsif( length( $toks[$i] ) ){
  444                     $toks[$i] = quotemeta $toks[$i];
  445                     $conlen += length( $toks[$i] );
  446                 }
  447             }  
  448             my $lhs = join( '', @toks );
  449             $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
  450         $transfmt{$header}{pat} =
  451               "    s^\\s*$lhs\\s*\Q$header\Es\n\t&& return 1;\n";
  452             $transfmt{$header}{len} = $conlen;
  453     } else {
  454             my $lhs = "\Q$header\E";
  455             $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
  456             $transfmt{$header}{pat} =
  457           "    s^\\s*$lhs\\s*\Q$header\E\n\t && return 1;\n";
  458             $transfmt{$header}{len} = length( $header );
  459     } 
  460 
  461     print STDERR __PACKAGE__.": Duplicate entry: \"$header\"\n"
  462         if $msg{$header};
  463 
  464     $msg{$header} = '';
  465     $seen_body = 0;
  466     } 
  467 
  468 
  469     close POD_DIAG unless *main::DATA eq *POD_DIAG;
  470 
  471     die "No diagnostics?" unless %msg;
  472 
  473     # Apply patterns in order of decreasing sum of lengths of fixed parts
  474     # Seems the best way of hitting the right one.
  475     for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
  476                   keys %transfmt ){
  477         $transmo .= $transfmt{$hdr}{pat};
  478     }
  479     $transmo .= "    return 0;\n}\n";
  480     print STDERR $transmo if $DEBUG;
  481     eval $transmo;
  482     die $@ if $@;
  483 }
  484 
  485 if ($standalone) {
  486     if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } 
  487     while (defined (my $error = <>)) {
  488     splainthis($error) || print THITHER $error;
  489     } 
  490     exit;
  491 } 
  492 
  493 my $olddie;
  494 my $oldwarn;
  495 
  496 sub import {
  497     shift;
  498     $^W = 1; # yup, clobbered the global variable; 
  499          # tough, if you want diags, you want diags.
  500     return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
  501 
  502     for (@_) {
  503 
  504     /^-d(ebug)?$/       && do {
  505                     $DEBUG++;
  506                     next;
  507                    };
  508 
  509     /^-v(erbose)?$/     && do {
  510                     $VERBOSE++;
  511                     next;
  512                    };
  513 
  514     /^-p(retty)?$/      && do {
  515                     print STDERR "$0: I'm afraid it's too late for prettiness.\n";
  516                     $PRETTY++;
  517                     next;
  518                    };
  519     # matches trace and traceonly for legacy doc mixup reasons
  520     /^-t(race(only)?)?$/    && do {
  521                     $TRACEONLY++;
  522                     next;
  523                    };
  524     /^-w(arntrace)?$/   && do {
  525                     $WARNTRACE++;
  526                     next;
  527                    };
  528 
  529     warn "Unknown flag: $_";
  530     } 
  531 
  532     $oldwarn = $SIG{__WARN__};
  533     $olddie = $SIG{__DIE__};
  534     $SIG{__WARN__} = \&warn_trap;
  535     $SIG{__DIE__} = \&death_trap;
  536 } 
  537 
  538 sub enable { &import }
  539 
  540 sub disable {
  541     shift;
  542     return unless $SIG{__WARN__} eq \&warn_trap;
  543     $SIG{__WARN__} = $oldwarn || '';
  544     $SIG{__DIE__} = $olddie || '';
  545 } 
  546 
  547 sub warn_trap {
  548     my $warning = $_[0];
  549     if (caller eq __PACKAGE__ or !splainthis($warning)) {
  550     if ($WARNTRACE) {
  551         print STDERR Carp::longmess($warning);
  552     } else {
  553         print STDERR $warning;
  554     }
  555     } 
  556     goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
  557 };
  558 
  559 sub death_trap {
  560     my $exception = $_[0];
  561 
  562     # See if we are coming from anywhere within an eval. If so we don't
  563     # want to explain the exception because it's going to get caught.
  564     my $in_eval = 0;
  565     my $i = 0;
  566     while (my $caller = (caller($i++))[3]) {
  567       if ($caller eq '(eval)') {
  568     $in_eval = 1;
  569     last;
  570       }
  571     }
  572 
  573     splainthis($exception) unless $in_eval;
  574     if (caller eq __PACKAGE__) {
  575     print STDERR "INTERNAL EXCEPTION: $exception";
  576     } 
  577     &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
  578 
  579     return if $in_eval;
  580 
  581     # We don't want to unset these if we're coming from an eval because
  582     # then we've turned off diagnostics.
  583 
  584     # Switch off our die/warn handlers so we don't wind up in our own
  585     # traps.
  586     $SIG{__DIE__} = $SIG{__WARN__} = '';
  587 
  588     $exception =~ s/\n(?=.)/\n\t/gas;
  589 
  590     die Carp::longmess("__diagnostics__")
  591       =~ s/^__diagnostics__.*?line \d+\.?\n/
  592           "Uncaught exception from user code:\n\t$exception"
  593           /re;
  594     # up we go; where we stop, nobody knows, but i think we die now
  595     # but i'm deeply afraid of the &$olddie guy reraising and us getting
  596     # into an indirect recursion loop
  597 };
  598 
  599 my %exact_duplicate;
  600 my %old_diag;
  601 my $count;
  602 my $wantspace;
  603 sub splainthis {
  604   return 0 if $TRACEONLY;
  605   for (my $tmp = shift) {
  606     local $\;
  607     local $!;
  608     ### &finish_compilation unless %msg;
  609     s/(\.\s*)?\n+$//;
  610     my $orig = $_;
  611     # return unless defined;
  612 
  613     # get rid of the where-are-we-in-input part
  614     s/, <.*?> (?:line|chunk).*$//;
  615 
  616     # Discard 1st " at <file> line <no>" and all text beyond
  617     # but be aware of messages containing " at this-or-that"
  618     my $real = 0;
  619     my @secs = split( / at / );
  620     return unless @secs;
  621     $_ = $secs[0];
  622     for my $i ( 1..$#secs ){
  623         if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
  624             $real = 1;
  625             last;
  626         } else {
  627             $_ .= ' at ' . $secs[$i];
  628     }
  629     }
  630 
  631     # remove parenthesis occurring at the end of some messages 
  632     s/^\((.*)\)$/$1/;
  633 
  634     if ($exact_duplicate{$orig}++) {
  635     return &transmo;
  636     } else {
  637     return 0 unless &transmo;
  638     }
  639 
  640     my $short = shorten($orig);
  641     if ($old_diag{$_}) {
  642     autodescribe();
  643     print THITHER "$short (#$old_diag{$_})\n";
  644     $wantspace = 1;
  645     } elsif (!$msg{$_} && $orig =~ /\n./s) {
  646     # A multiline message, like "Attempt to reload /
  647     # Compilation failed"
  648     my $found;
  649     for (split /^/, $orig) {
  650         splainthis($_) and $found = 1;
  651     }
  652     return $found;
  653     } else {
  654     autodescribe();
  655     $old_diag{$_} = ++$count;
  656     print THITHER "\n" if $wantspace;
  657     $wantspace = 0;
  658     print THITHER "$short (#$old_diag{$_})\n";
  659     if ($msg{$_}) {
  660         print THITHER $msg{$_};
  661     } else {
  662         if (0 and $standalone) { 
  663         print THITHER "    **** Error #$old_diag{$_} ",
  664             ($real ? "is" : "appears to be"),
  665             " an unknown diagnostic message.\n\n";
  666         }
  667         return 0;
  668     } 
  669     }
  670     return 1;
  671   }
  672 } 
  673 
  674 sub autodescribe {
  675     if ($VERBOSE and not $count) {
  676     print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
  677         "\n$msg{DESCRIPTION}\n";
  678     } 
  679 } 
  680 
  681 sub unescape { 
  682     s {
  683             E<  
  684             ( [A-Za-z]+ )       
  685             >   
  686     } { 
  687          do {   
  688              exists $HTML_Escapes{$1}
  689                 ? do { $HTML_Escapes{$1} }
  690                 : do {
  691                     warn "Unknown escape: E<$1> in $_";
  692                     "E<$1>";
  693                 } 
  694          } 
  695     }egx;
  696 }
  697 
  698 sub shorten {
  699     my $line = $_[0];
  700     if (length($line) > 79 and index($line, "\n") == -1) {
  701     my $space_place = rindex($line, ' ', 79);
  702     if ($space_place != -1) {
  703         substr($line, $space_place, 1) = "\n\t";
  704     } 
  705     } 
  706     return $line;
  707 } 
  708 
  709 
  710 1 unless $standalone;  # or it'll complain about itself
  711 __END__ # wish diag dbase were more accessible