This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use $^S instead of caller in splain
[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 61This module also adds a stack trace to the error message when perl dies.
f8c3fed4
FC
62This is useful for pinpointing what
63caused the death. The B<-traceonly> (or
3c4b39be 64just B<-t>) flag turns off the explanations of warning messages leaving just
f8c3fed4 65the stack traces. So if your script is dieing, run it again with
58618f23
FD
66
67 perl -Mdiagnostics=-traceonly my_bad_script
68
f8c3fed4 69to see the call stack at the time of death. By supplying the B<-warntrace>
58618f23
FD
70(or just B<-w>) flag, any warnings emitted will also come with a stack
71trace.
72
4633a7c4
LW
73=head2 The I<splain> Program
74
75While apparently a whole nuther program, I<splain> is actually nothing
76more than a link to the (executable) F<diagnostics.pm> module, as well as
77a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
78the C<use diagnostics -verbose> directive.
79The B<-p> flag is like the
80$diagnostics::PRETTY variable. Since you're post-processing with
81I<splain>, there's no sense in being able to enable() or disable() processing.
82
83Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
84
85=head1 EXAMPLES
86
87The following file is certain to trigger a few errors at both
ae2c041d 88runtime and compiletime:
4633a7c4
LW
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
99If you prefer to run your program first and look at its problem
100afterwards, do this:
101
102 perl -w test.pl 2>test.out
103 ./splain < test.out
104
105Note that this is not in general possible in shells of more dubious heritage,
1fef88e7 106as the theoretical
4633a7c4
LW
107
108 (perl -w test.pl >/dev/tty) >& test.out
109 ./splain < test.out
110
111Because you just moved the existing B<stdout> to somewhere else.
112
113If you don't want to modify your source code, but still have on-the-fly
114warnings, do this:
115
116 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
117
118Nifty, eh?
119
120If you want to control warnings on the fly, do something like this.
121Make sure you do the C<use> first, or you won't be able to get
122at 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
146Diagnostic messages derive from the F<perldiag.pod> file when available at
147runtime. Otherwise, they may be embedded in the file itself when the
148splain package is built. See the F<Makefile> for details.
149
150If an extant $SIG{__WARN__} handler is discovered, it will continue
1fef88e7 151to be honored, but only after the diagnostics::splainthis() function
4633a7c4
LW
152(the module's $SIG{__WARN__} interceptor) has had its way with your
153warnings.
154
155There is a $diagnostics::DEBUG variable you may set if you're desperately
156curious what sorts of things are being intercepted.
157
158 BEGIN { $diagnostics::DEBUG = 1 }
159
160
161=head1 BUGS
162
163Not being able to say "no diagnostics" is annoying, but may not be
164insurmountable.
165
166The C<-pretty> directive is called too late to affect matters.
864e1151 167You have to do this instead, and I<before> you load the module.
4633a7c4
LW
168
169 BEGIN { $diagnostics::PRETTY = 1 }
170
171I could start up faster by delaying compilation until it should be
a6006777
PP
172needed, but this gets a "panic: top_level" when using the pragma form
173in Perl 5.001e.
4633a7c4
LW
174
175While it's true that this documentation is somewhat subserious, if you use
176a program named I<splain>, you should expect a bit of whimsy.
177
178=head1 AUTHOR
179
352854fa 180Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
4633a7c4
LW
181
182=cut
183
7a4340ed 184use strict;
d923656e 185use 5.009001;
5f05dabc 186use Carp;
58618f23 187$Carp::Internal{__PACKAGE__.""}++;
5f05dabc 188
c369a25d 189our $VERSION = '1.31';
7a4340ed
GS
190our $DEBUG;
191our $VERBOSE;
192our $PRETTY;
58618f23
FD
193our $TRACEONLY = 0;
194our $WARNTRACE = 0;
1e4e2d84 195
5f05dabc 196use Config;
ce2c4022 197my $privlib = $Config{privlibexp};
5f05dabc 198if ($^O eq 'VMS') {
91a06757
CS
199 require VMS::Filespec;
200 $privlib = VMS::Filespec::unixify($privlib);
5f05dabc 201}
7a4340ed 202my @trypod = (
5459498c 203 "$privlib/pod/perldiag.pod",
5459498c 204 "$privlib/pods/perldiag.pod",
7ec2cea4 205 );
fb73857a
PP
206# handy for development testing of new warnings etc
207unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
7a4340ed 208(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
5f05dabc 209
4633a7c4
LW
210$DEBUG ||= 0;
211my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
212
7a4340ed 213local $| = 1;
0a437bc9 214local $_;
412147f6 215local $.;
4633a7c4 216
7a4340ed
GS
217my $standalone;
218my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
219
4633a7c4 220CONFIG: {
7a4340ed 221 our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
4633a7c4 222
7a4340ed 223 unless (caller) {
4633a7c4
LW
224 $standalone++;
225 require Getopt::Std;
91a06757
CS
226 Getopt::Std::getopts('pdvf:')
227 or die "Usage: $0 [-v] [-p] [-f splainpod]";
4633a7c4
LW
228 $PODFILE = $opt_f if $opt_f;
229 $DEBUG = 2 if $opt_d;
230 $VERBOSE = $opt_v;
231 $PRETTY = $opt_p;
7a4340ed 232 }
4633a7c4
LW
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: {
7a4340ed 241 for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
4633a7c4
LW
242 warn "Checking $file\n" if $DEBUG;
243 if (open(POD_DIAG, $file)) {
244 while (<POD_DIAG>) {
7a4340ed
GS
245 next unless
246 /^__END__\s*# wish diag dbase were more accessible/;
4633a7c4
LW
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}
258if (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
7a4340ed 295our %HTML_Escapes;
4633a7c4
LW
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
49704364 306my %transfmt = ();
7a4340ed 307my $transmo = <<EOFUNC;
4633a7c4 308sub transmo {
599cee73 309 #local \$^W = 0; # recursive warnings we do NOT need!
4633a7c4
LW
310EOFUNC
311
7a4340ed
GS
312my %msg;
313{
4633a7c4 314 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
7a4340ed 315 local $/ = '';
0a437bc9 316 local $_;
7a4340ed 317 my $header;
f4739a71 318 my @headers;
7a4340ed 319 my $for_item;
f4739a71 320 my $seen_body;
4633a7c4 321 while (<POD_DIAG>) {
4633a7c4 322
4b056c06
FC
323 sub _split_pod_link {
324 $_[0] =~ '(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?';
325 ($1,$2,$4);
326 }
327
4633a7c4
LW
328 unescape();
329 if ($PRETTY) {
330 sub noop { return $_[0] } # spensive for a noop
331 sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
332 sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
67612b68 333 s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
4b056c06
FC
334 s/[IF]<(.*?)>/italic($1)/ges;
335 s/L<(.*?)>/
336 my($text,$page,$sect) = _split_pod_link($1);
337 defined $text
338 ? $text
339 : defined $sect
340 ? italic($sect) . ' in ' . italic($page)
341 : italic($page)
342 /ges;
524e9188
MH
343 s/S<(.*?)>/
344 $1
345 /ges;
4633a7c4 346 } else {
67612b68 347 s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
4b056c06
FC
348 s/[IF]<(.*?)>/$1/gs;
349 s/L<(.*?)>/
350 my($text,$page,$sect) = _split_pod_link($1);
351 defined $text
352 ? $text
353 : defined $sect
354 ? qq '"$sect" in $page'
355 : $page
356 /ges;
524e9188
MH
357 s/S<(.*?)>/
358 $1
359 /ges;
4633a7c4
LW
360 }
361 unless (/^=/) {
362 if (defined $header) {
363 if ( $header eq 'DESCRIPTION' &&
364 ( /Optional warnings are enabled/
365 || /Some of these messages are generic./
366 ) )
367 {
368 next;
49704364 369 }
4633a7c4
LW
370 s/^/ /gm;
371 $msg{$header} .= $_;
f4739a71
FC
372 for my $h(@headers) { $msg{$h} .= $_ }
373 ++$seen_body;
7a4340ed 374 undef $for_item;
4633a7c4
LW
375 }
376 next;
377 }
f4739a71
FC
378
379 # If we have not come across the body of the description yet, then
380 # the previous header needs to share the same description.
381 if ($seen_body) {
382 @headers = ();
383 }
384 else {
385 push @headers, $header if defined $header;
386 }
387
7a4340ed 388 unless ( s/=item (.*?)\s*\z//) {
4633a7c4
LW
389
390 if ( s/=head1\sDESCRIPTION//) {
391 $msg{$header = 'DESCRIPTION'} = '';
7a4340ed 392 undef $for_item;
4633a7c4 393 }
7a4340ed
GS
394 elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
395 $for_item = $1;
396 }
4633a7c4
LW
397 next;
398 }
4fdae800 399
5cd5c422
RB
400 if( $for_item ) { $header = $for_item; undef $for_item }
401 else {
402 $header = $1;
403 while( $header =~ /[;,]\z/ ) {
404 <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
405 $header .= ' '.$1;
406 }
407 }
408
49704364 409 # strip formatting directives from =item line
7a4340ed 410 $header =~ s/[A-Z]<(.*?)>/$1/g;
4633a7c4 411
c0d3a21f
MH
412 # Since we strip "\.\n" when we search a warning, strip it here as well
413 $header =~ s/\.?$//;
414
01bfea8b 415 my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header );
49704364
LW
416 if (@toks > 1) {
417 my $conlen = 0;
418 for my $i (0..$#toks){
419 if( $i % 2 ){
420 if( $toks[$i] eq '%c' ){
421 $toks[$i] = '.';
e958e573 422 } elsif( $toks[$i] =~ /^%(?:d|u)$/ ){
49704364 423 $toks[$i] = '\d+';
8b56d6ff 424 } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
49704364
LW
425 $toks[$i] = $i == $#toks ? '.*' : '.*?';
426 } elsif( $toks[$i] =~ '%.(\d+)s' ){
427 $toks[$i] = ".{$1}";
01bfea8b
FC
428 } elsif( $toks[$i] =~ '^%l*([pxX])$' ){
429 $toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+';
e958e573 430 }
49704364 431 } elsif( length( $toks[$i] ) ){
8ec7363a 432 $toks[$i] = quotemeta $toks[$i];
49704364
LW
433 $conlen += length( $toks[$i] );
434 }
435 }
436 my $lhs = join( '', @toks );
437 $transfmt{$header}{pat} =
2a53d331 438 " s\a^$lhs\a\Q$header\E\as\n\t&& return 1;\n";
49704364 439 $transfmt{$header}{len} = $conlen;
4633a7c4 440 } else {
49704364 441 $transfmt{$header}{pat} =
2a53d331 442 " m\a^\Q$header\E\a && return 1;\n";
49704364 443 $transfmt{$header}{len} = length( $header );
4633a7c4
LW
444 }
445
eff9c6e2
CS
446 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
447 if $msg{$header};
4633a7c4
LW
448
449 $msg{$header} = '';
f4739a71 450 $seen_body = 0;
4633a7c4
LW
451 }
452
453
454 close POD_DIAG unless *main::DATA eq *POD_DIAG;
455
456 die "No diagnostics?" unless %msg;
457
49704364
LW
458 # Apply patterns in order of decreasing sum of lengths of fixed parts
459 # Seems the best way of hitting the right one.
460 for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
461 keys %transfmt ){
462 $transmo .= $transfmt{$hdr}{pat};
463 }
4633a7c4
LW
464 $transmo .= " return 0;\n}\n";
465 print STDERR $transmo if $DEBUG;
466 eval $transmo;
467 die $@ if $@;
7a4340ed 468}
4633a7c4
LW
469
470if ($standalone) {
471 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
7a4340ed 472 while (defined (my $error = <>)) {
4633a7c4
LW
473 splainthis($error) || print THITHER $error;
474 }
475 exit;
7a4340ed
GS
476}
477
478my $olddie;
479my $oldwarn;
4633a7c4
LW
480
481sub import {
482 shift;
7a4340ed
GS
483 $^W = 1; # yup, clobbered the global variable;
484 # tough, if you want diags, you want diags.
0dc02ca5 485 return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
4633a7c4
LW
486
487 for (@_) {
488
489 /^-d(ebug)?$/ && do {
490 $DEBUG++;
491 next;
492 };
493
494 /^-v(erbose)?$/ && do {
495 $VERBOSE++;
496 next;
497 };
498
499 /^-p(retty)?$/ && do {
500 print STDERR "$0: I'm afraid it's too late for prettiness.\n";
501 $PRETTY++;
502 next;
503 };
b4e8c6dd
FD
504 # matches trace and traceonly for legacy doc mixup reasons
505 /^-t(race(only)?)?$/ && do {
58618f23
FD
506 $TRACEONLY++;
507 next;
508 };
b4e8c6dd 509 /^-w(arntrace)?$/ && do {
58618f23
FD
510 $WARNTRACE++;
511 next;
512 };
513
4633a7c4
LW
514 warn "Unknown flag: $_";
515 }
516
517 $oldwarn = $SIG{__WARN__};
518 $olddie = $SIG{__DIE__};
519 $SIG{__WARN__} = \&warn_trap;
520 $SIG{__DIE__} = \&death_trap;
521}
522
523sub enable { &import }
524
525sub disable {
526 shift;
4633a7c4 527 return unless $SIG{__WARN__} eq \&warn_trap;
3d0ae7ba
GS
528 $SIG{__WARN__} = $oldwarn || '';
529 $SIG{__DIE__} = $olddie || '';
4633a7c4
LW
530}
531
532sub warn_trap {
533 my $warning = $_[0];
534 if (caller eq $WHOAMI or !splainthis($warning)) {
58618f23
FD
535 if ($WARNTRACE) {
536 print STDERR Carp::longmess($warning);
537 } else {
538 print STDERR $warning;
539 }
4633a7c4 540 }
58618f23 541 goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
4633a7c4
LW
542};
543
544sub death_trap {
545 my $exception = $_[0];
55497cff
PP
546
547 # See if we are coming from anywhere within an eval. If so we don't
548 # want to explain the exception because it's going to get caught.
019070c3 549 my $in_eval = $^S || !defined $^S;
55497cff
PP
550
551 splainthis($exception) unless $in_eval;
4633a7c4 552 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
37120919 553 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
55497cff 554
d23f0205
MS
555 return if $in_eval;
556
55497cff 557 # We don't want to unset these if we're coming from an eval because
d23f0205
MS
558 # then we've turned off diagnostics.
559
560 # Switch off our die/warn handlers so we don't wind up in our own
561 # traps.
562 $SIG{__DIE__} = $SIG{__WARN__} = '';
563
245e6c67
FC
564 $exception =~ s/\n(?=.)/\n\t/gas;
565
2dde0467
FC
566 die Carp::longmess("__diagnostics__")
567 =~ s/^__diagnostics__.*?line \d+\.?\n/
568 "Uncaught exception from user code:\n\t$exception"
569 /re;
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 {
0a437bc9
FC
580 return 0 if $TRACEONLY;
581 for (my $tmp = 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
LW
588
589 # get rid of the where-are-we-in-input part
4633a7c4 590 s/, <.*?> (?:line|chunk).*$//;
49704364
LW
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
LW
594 my $real = 0;
595 my @secs = split( / at / );
18d238e4 596 return unless @secs;
49704364
LW
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
0a437bc9 616 my $short = shorten($orig);
4633a7c4
LW
617 if ($old_diag{$_}) {
618 autodescribe();
0a437bc9 619 print THITHER "$short (#$old_diag{$_})\n";
4633a7c4 620 $wantspace = 1;
0a437bc9
FC
621 } elsif (!$msg{$_} && $orig =~ /\n./s) {
622 # A multiline message, like "Attempt to reload /
623 # Compilation failed"
624 my $found;
625 for (split /^/, $orig) {
626 splainthis($_) and $found = 1;
627 }
628 return $found;
4633a7c4
LW
629 } else {
630 autodescribe();
631 $old_diag{$_} = ++$count;
632 print THITHER "\n" if $wantspace;
633 $wantspace = 0;
0a437bc9 634 print THITHER "$short (#$old_diag{$_})\n";
4633a7c4
LW
635 if ($msg{$_}) {
636 print THITHER $msg{$_};
637 } else {
638 if (0 and $standalone) {
639 print THITHER " **** Error #$old_diag{$_} ",
640 ($real ? "is" : "appears to be"),
641 " an unknown diagnostic message.\n\n";
642 }
643 return 0;
644 }
645 }
646 return 1;
0a437bc9 647 }
4633a7c4
LW
648}
649
650sub autodescribe {
651 if ($VERBOSE and not $count) {
652 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
653 "\n$msg{DESCRIPTION}\n";
654 }
655}
656
657sub unescape {
658 s {
659 E<
660 ( [A-Za-z]+ )
661 >
662 } {
663 do {
664 exists $HTML_Escapes{$1}
665 ? do { $HTML_Escapes{$1} }
666 : do {
f02a87df 667 warn "Unknown escape: E<$1> in $_";
4633a7c4
LW
668 "E<$1>";
669 }
670 }
671 }egx;
672}
673
674sub shorten {
675 my $line = $_[0];
774d564b 676 if (length($line) > 79 and index($line, "\n") == -1) {
4633a7c4
LW
677 my $space_place = rindex($line, ' ', 79);
678 if ($space_place != -1) {
679 substr($line, $space_place, 1) = "\n\t";
680 }
681 }
682 return $line;
683}
684
685
4633a7c4
LW
6861 unless $standalone; # or it'll complain about itself
687__END__ # wish diag dbase were more accessible