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