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