Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | #!/import/bw/tools/local/perl-5.8.0/bin/perl |
2 | eval 'exec /import/bw/tools/local/perl-5.8.0/bin/perl -S $0 ${1+"$@"}' | |
3 | if $running_under_some_shell; | |
4 | ||
5 | =head1 NAME | |
6 | ||
7 | diagnostics - Perl compiler pragma to force verbose warning diagnostics | |
8 | ||
9 | splain - standalone program to do the same thing | |
10 | ||
11 | =head1 SYNOPSIS | |
12 | ||
13 | As a pragma: | |
14 | ||
15 | use diagnostics; | |
16 | use diagnostics -verbose; | |
17 | ||
18 | enable diagnostics; | |
19 | disable diagnostics; | |
20 | ||
21 | Aa a program: | |
22 | ||
23 | perl program 2>diag.out | |
24 | splain [-v] [-p] diag.out | |
25 | ||
26 | ||
27 | =head1 DESCRIPTION | |
28 | ||
29 | =head2 The C<diagnostics> Pragma | |
30 | ||
31 | This module extends the terse diagnostics normally emitted by both the | |
32 | perl compiler and the perl interpreter, 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 ala warn() are unaffected, | |
59 | allowing duplicate user messages to be displayed. | |
60 | ||
61 | =head2 The I<splain> Program | |
62 | ||
63 | While apparently a whole nuther program, I<splain> is actually nothing | |
64 | more than a link to the (executable) F<diagnostics.pm> module, as well as | |
65 | a link to the F<diagnostics.pod> documentation. The B<-v> flag is like | |
66 | the C<use diagnostics -verbose> directive. | |
67 | The B<-p> flag is like the | |
68 | $diagnostics::PRETTY variable. Since you're post-processing with | |
69 | I<splain>, there's no sense in being able to enable() or disable() processing. | |
70 | ||
71 | Output from I<splain> is directed to B<STDOUT>, unlike the pragma. | |
72 | ||
73 | =head1 EXAMPLES | |
74 | ||
75 | The following file is certain to trigger a few errors at both | |
76 | runtime and compiletime: | |
77 | ||
78 | use diagnostics; | |
79 | print NOWHERE "nothing\n"; | |
80 | print STDERR "\n\tThis message should be unadorned.\n"; | |
81 | warn "\tThis is a user warning"; | |
82 | print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: "; | |
83 | my $a, $b = scalar <STDIN>; | |
84 | print "\n"; | |
85 | print $x/$y; | |
86 | ||
87 | If you prefer to run your program first and look at its problem | |
88 | afterwards, do this: | |
89 | ||
90 | perl -w test.pl 2>test.out | |
91 | ./splain < test.out | |
92 | ||
93 | Note that this is not in general possible in shells of more dubious heritage, | |
94 | as the theoretical | |
95 | ||
96 | (perl -w test.pl >/dev/tty) >& test.out | |
97 | ./splain < test.out | |
98 | ||
99 | Because you just moved the existing B<stdout> to somewhere else. | |
100 | ||
101 | If you don't want to modify your source code, but still have on-the-fly | |
102 | warnings, do this: | |
103 | ||
104 | exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&- | |
105 | ||
106 | Nifty, eh? | |
107 | ||
108 | If you want to control warnings on the fly, do something like this. | |
109 | Make sure you do the C<use> first, or you won't be able to get | |
110 | at the enable() or disable() methods. | |
111 | ||
112 | use diagnostics; # checks entire compilation phase | |
113 | print "\ntime for 1st bogus diags: SQUAWKINGS\n"; | |
114 | print BOGUS1 'nada'; | |
115 | print "done with 1st bogus\n"; | |
116 | ||
117 | disable diagnostics; # only turns off runtime warnings | |
118 | print "\ntime for 2nd bogus: (squelched)\n"; | |
119 | print BOGUS2 'nada'; | |
120 | print "done with 2nd bogus\n"; | |
121 | ||
122 | enable diagnostics; # turns back on runtime warnings | |
123 | print "\ntime for 3rd bogus: SQUAWKINGS\n"; | |
124 | print BOGUS3 'nada'; | |
125 | print "done with 3rd bogus\n"; | |
126 | ||
127 | disable diagnostics; | |
128 | print "\ntime for 4th bogus: (squelched)\n"; | |
129 | print BOGUS4 'nada'; | |
130 | print "done with 4th bogus\n"; | |
131 | ||
132 | =head1 INTERNALS | |
133 | ||
134 | Diagnostic messages derive from the F<perldiag.pod> file when available at | |
135 | runtime. Otherwise, they may be embedded in the file itself when the | |
136 | splain package is built. See the F<Makefile> for details. | |
137 | ||
138 | If an extant $SIG{__WARN__} handler is discovered, it will continue | |
139 | to be honored, but only after the diagnostics::splainthis() function | |
140 | (the module's $SIG{__WARN__} interceptor) has had its way with your | |
141 | warnings. | |
142 | ||
143 | There is a $diagnostics::DEBUG variable you may set if you're desperately | |
144 | curious what sorts of things are being intercepted. | |
145 | ||
146 | BEGIN { $diagnostics::DEBUG = 1 } | |
147 | ||
148 | ||
149 | =head1 BUGS | |
150 | ||
151 | Not being able to say "no diagnostics" is annoying, but may not be | |
152 | insurmountable. | |
153 | ||
154 | The C<-pretty> directive is called too late to affect matters. | |
155 | You have to do this instead, and I<before> you load the module. | |
156 | ||
157 | BEGIN { $diagnostics::PRETTY = 1 } | |
158 | ||
159 | I could start up faster by delaying compilation until it should be | |
160 | needed, but this gets a "panic: top_level" when using the pragma form | |
161 | in Perl 5.001e. | |
162 | ||
163 | While it's true that this documentation is somewhat subserious, if you use | |
164 | a program named I<splain>, you should expect a bit of whimsy. | |
165 | ||
166 | =head1 AUTHOR | |
167 | ||
168 | Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995. | |
169 | ||
170 | =cut | |
171 | ||
172 | use strict; | |
173 | use 5.006; | |
174 | use Carp; | |
175 | ||
176 | our $VERSION = 1.1; | |
177 | our $DEBUG; | |
178 | our $VERBOSE; | |
179 | our $PRETTY; | |
180 | ||
181 | use Config; | |
182 | my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)}; | |
183 | if ($^O eq 'VMS') { | |
184 | require VMS::Filespec; | |
185 | $privlib = VMS::Filespec::unixify($privlib); | |
186 | $archlib = VMS::Filespec::unixify($archlib); | |
187 | } | |
188 | my @trypod = ( | |
189 | "$archlib/pod/perldiag.pod", | |
190 | "$privlib/pod/perldiag-$Config{version}.pod", | |
191 | "$privlib/pod/perldiag.pod", | |
192 | "$archlib/pods/perldiag.pod", | |
193 | "$privlib/pods/perldiag-$Config{version}.pod", | |
194 | "$privlib/pods/perldiag.pod", | |
195 | ); | |
196 | # handy for development testing of new warnings etc | |
197 | unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; | |
198 | (my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; | |
199 | ||
200 | if ($^O eq 'MacOS') { | |
201 | # just updir one from each lib dir, we'll find it ... | |
202 | ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC; | |
203 | } | |
204 | ||
205 | ||
206 | $DEBUG ||= 0; | |
207 | my $WHOAMI = ref bless []; # nobody's business, prolly not even mine | |
208 | ||
209 | local $| = 1; | |
210 | local $_; | |
211 | ||
212 | my $standalone; | |
213 | my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7); | |
214 | ||
215 | CONFIG: { | |
216 | our $opt_p = our $opt_d = our $opt_v = our $opt_f = ''; | |
217 | ||
218 | unless (caller) { | |
219 | $standalone++; | |
220 | require Getopt::Std; | |
221 | Getopt::Std::getopts('pdvf:') | |
222 | or die "Usage: $0 [-v] [-p] [-f splainpod]"; | |
223 | $PODFILE = $opt_f if $opt_f; | |
224 | $DEBUG = 2 if $opt_d; | |
225 | $VERBOSE = $opt_v; | |
226 | $PRETTY = $opt_p; | |
227 | } | |
228 | ||
229 | if (open(POD_DIAG, $PODFILE)) { | |
230 | warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; | |
231 | last CONFIG; | |
232 | } | |
233 | ||
234 | if (caller) { | |
235 | INCPATH: { | |
236 | for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) { | |
237 | warn "Checking $file\n" if $DEBUG; | |
238 | if (open(POD_DIAG, $file)) { | |
239 | while (<POD_DIAG>) { | |
240 | next unless | |
241 | /^__END__\s*# wish diag dbase were more accessible/; | |
242 | print STDERR "podfile is $file\n" if $DEBUG; | |
243 | last INCPATH; | |
244 | } | |
245 | } | |
246 | } | |
247 | } | |
248 | } else { | |
249 | print STDERR "podfile is <DATA>\n" if $DEBUG; | |
250 | *POD_DIAG = *main::DATA; | |
251 | } | |
252 | } | |
253 | if (eof(POD_DIAG)) { | |
254 | die "couldn't find diagnostic data in $PODFILE @INC $0"; | |
255 | } | |
256 | ||
257 | ||
258 | %HTML_2_Troff = ( | |
259 | 'amp' => '&', # ampersand | |
260 | 'lt' => '<', # left chevron, less-than | |
261 | 'gt' => '>', # right chevron, greater-than | |
262 | 'quot' => '"', # double quote | |
263 | ||
264 | "Aacute" => "A\\*'", # capital A, acute accent | |
265 | # etc | |
266 | ||
267 | ); | |
268 | ||
269 | %HTML_2_Latin_1 = ( | |
270 | 'amp' => '&', # ampersand | |
271 | 'lt' => '<', # left chevron, less-than | |
272 | 'gt' => '>', # right chevron, greater-than | |
273 | 'quot' => '"', # double quote | |
274 | ||
275 | "Aacute" => "\xC1" # capital A, acute accent | |
276 | ||
277 | # etc | |
278 | ); | |
279 | ||
280 | %HTML_2_ASCII_7 = ( | |
281 | 'amp' => '&', # ampersand | |
282 | 'lt' => '<', # left chevron, less-than | |
283 | 'gt' => '>', # right chevron, greater-than | |
284 | 'quot' => '"', # double quote | |
285 | ||
286 | "Aacute" => "A" # capital A, acute accent | |
287 | # etc | |
288 | ); | |
289 | ||
290 | our %HTML_Escapes; | |
291 | *HTML_Escapes = do { | |
292 | if ($standalone) { | |
293 | $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; | |
294 | } else { | |
295 | \%HTML_2_Latin_1; | |
296 | } | |
297 | }; | |
298 | ||
299 | *THITHER = $standalone ? *STDOUT : *STDERR; | |
300 | ||
301 | my $transmo = <<EOFUNC; | |
302 | sub transmo { | |
303 | #local \$^W = 0; # recursive warnings we do NOT need! | |
304 | study; | |
305 | EOFUNC | |
306 | ||
307 | my %msg; | |
308 | { | |
309 | print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG; | |
310 | local $/ = ''; | |
311 | local $_; | |
312 | my $header; | |
313 | my $for_item; | |
314 | while (<POD_DIAG>) { | |
315 | ||
316 | unescape(); | |
317 | if ($PRETTY) { | |
318 | sub noop { return $_[0] } # spensive for a noop | |
319 | sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; } | |
320 | sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; } | |
321 | s/[BC]<(.*?)>/bold($1)/ges; | |
322 | s/[LIF]<(.*?)>/italic($1)/ges; | |
323 | } else { | |
324 | s/[BC]<(.*?)>/$1/gs; | |
325 | s/[LIF]<(.*?)>/$1/gs; | |
326 | } | |
327 | unless (/^=/) { | |
328 | if (defined $header) { | |
329 | if ( $header eq 'DESCRIPTION' && | |
330 | ( /Optional warnings are enabled/ | |
331 | || /Some of these messages are generic./ | |
332 | ) ) | |
333 | { | |
334 | next; | |
335 | } | |
336 | s/^/ /gm; | |
337 | $msg{$header} .= $_; | |
338 | undef $for_item; | |
339 | } | |
340 | next; | |
341 | } | |
342 | unless ( s/=item (.*?)\s*\z//) { | |
343 | ||
344 | if ( s/=head1\sDESCRIPTION//) { | |
345 | $msg{$header = 'DESCRIPTION'} = ''; | |
346 | undef $for_item; | |
347 | } | |
348 | elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) { | |
349 | $for_item = $1; | |
350 | } | |
351 | next; | |
352 | } | |
353 | ||
354 | if( $for_item ) { $header = $for_item; undef $for_item } | |
355 | else { | |
356 | $header = $1; | |
357 | while( $header =~ /[;,]\z/ ) { | |
358 | <POD_DIAG> =~ /^\s*(.*?)\s*\z/; | |
359 | $header .= ' '.$1; | |
360 | } | |
361 | } | |
362 | ||
363 | # strip formatting directives in =item line | |
364 | $header =~ s/[A-Z]<(.*?)>/$1/g; | |
365 | ||
366 | if ($header =~ /%[csd]/) { | |
367 | my $rhs = my $lhs = $header; | |
368 | if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g) { | |
369 | $lhs =~ s/\\%s/.*?/g; | |
370 | } else { | |
371 | # if i had lookbehind negations, | |
372 | # i wouldn't have to do this \377 noise | |
373 | $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g; | |
374 | $lhs =~ s/\377([^\377]*)$/\Q$1\E/; | |
375 | $lhs =~ s/\377//g; | |
376 | $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all | |
377 | } | |
378 | $lhs =~ s/\\%c/./g; | |
379 | $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n"; | |
380 | } else { | |
381 | $transmo .= " m{^\Q$header\E} && return 1;\n"; | |
382 | } | |
383 | ||
384 | print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n" | |
385 | if $msg{$header}; | |
386 | ||
387 | $msg{$header} = ''; | |
388 | } | |
389 | ||
390 | ||
391 | close POD_DIAG unless *main::DATA eq *POD_DIAG; | |
392 | ||
393 | die "No diagnostics?" unless %msg; | |
394 | ||
395 | $transmo .= " return 0;\n}\n"; | |
396 | print STDERR $transmo if $DEBUG; | |
397 | eval $transmo; | |
398 | die $@ if $@; | |
399 | } | |
400 | ||
401 | if ($standalone) { | |
402 | if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } | |
403 | while (defined (my $error = <>)) { | |
404 | splainthis($error) || print THITHER $error; | |
405 | } | |
406 | exit; | |
407 | } | |
408 | ||
409 | my $olddie; | |
410 | my $oldwarn; | |
411 | ||
412 | sub import { | |
413 | shift; | |
414 | $^W = 1; # yup, clobbered the global variable; | |
415 | # tough, if you want diags, you want diags. | |
416 | return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap); | |
417 | ||
418 | for (@_) { | |
419 | ||
420 | /^-d(ebug)?$/ && do { | |
421 | $DEBUG++; | |
422 | next; | |
423 | }; | |
424 | ||
425 | /^-v(erbose)?$/ && do { | |
426 | $VERBOSE++; | |
427 | next; | |
428 | }; | |
429 | ||
430 | /^-p(retty)?$/ && do { | |
431 | print STDERR "$0: I'm afraid it's too late for prettiness.\n"; | |
432 | $PRETTY++; | |
433 | next; | |
434 | }; | |
435 | ||
436 | warn "Unknown flag: $_"; | |
437 | } | |
438 | ||
439 | $oldwarn = $SIG{__WARN__}; | |
440 | $olddie = $SIG{__DIE__}; | |
441 | $SIG{__WARN__} = \&warn_trap; | |
442 | $SIG{__DIE__} = \&death_trap; | |
443 | } | |
444 | ||
445 | sub enable { &import } | |
446 | ||
447 | sub disable { | |
448 | shift; | |
449 | return unless $SIG{__WARN__} eq \&warn_trap; | |
450 | $SIG{__WARN__} = $oldwarn || ''; | |
451 | $SIG{__DIE__} = $olddie || ''; | |
452 | } | |
453 | ||
454 | sub warn_trap { | |
455 | my $warning = $_[0]; | |
456 | if (caller eq $WHOAMI or !splainthis($warning)) { | |
457 | print STDERR $warning; | |
458 | } | |
459 | &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap; | |
460 | }; | |
461 | ||
462 | sub death_trap { | |
463 | my $exception = $_[0]; | |
464 | ||
465 | # See if we are coming from anywhere within an eval. If so we don't | |
466 | # want to explain the exception because it's going to get caught. | |
467 | my $in_eval = 0; | |
468 | my $i = 0; | |
469 | while (1) { | |
470 | my $caller = (caller($i++))[3] or last; | |
471 | if ($caller eq '(eval)') { | |
472 | $in_eval = 1; | |
473 | last; | |
474 | } | |
475 | } | |
476 | ||
477 | splainthis($exception) unless $in_eval; | |
478 | if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; } | |
479 | &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; | |
480 | ||
481 | return if $in_eval; | |
482 | ||
483 | # We don't want to unset these if we're coming from an eval because | |
484 | # then we've turned off diagnostics. | |
485 | ||
486 | # Switch off our die/warn handlers so we don't wind up in our own | |
487 | # traps. | |
488 | $SIG{__DIE__} = $SIG{__WARN__} = ''; | |
489 | ||
490 | # Have carp skip over death_trap() when showing the stack trace. | |
491 | local($Carp::CarpLevel) = 1; | |
492 | ||
493 | confess "Uncaught exception from user code:\n\t$exception"; | |
494 | # up we go; where we stop, nobody knows, but i think we die now | |
495 | # but i'm deeply afraid of the &$olddie guy reraising and us getting | |
496 | # into an indirect recursion loop | |
497 | }; | |
498 | ||
499 | my %exact_duplicate; | |
500 | my %old_diag; | |
501 | my $count; | |
502 | my $wantspace; | |
503 | sub splainthis { | |
504 | local $_ = shift; | |
505 | local $\; | |
506 | ### &finish_compilation unless %msg; | |
507 | s/\.?\n+$//; | |
508 | my $orig = $_; | |
509 | # return unless defined; | |
510 | s/, <.*?> (?:line|chunk).*$//; | |
511 | my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/; | |
512 | s/^\((.*)\)$/$1/; | |
513 | if ($exact_duplicate{$orig}++) { | |
514 | return &transmo; | |
515 | } | |
516 | else { | |
517 | return 0 unless &transmo; | |
518 | } | |
519 | $orig = shorten($orig); | |
520 | if ($old_diag{$_}) { | |
521 | autodescribe(); | |
522 | print THITHER "$orig (#$old_diag{$_})\n"; | |
523 | $wantspace = 1; | |
524 | } else { | |
525 | autodescribe(); | |
526 | $old_diag{$_} = ++$count; | |
527 | print THITHER "\n" if $wantspace; | |
528 | $wantspace = 0; | |
529 | print THITHER "$orig (#$old_diag{$_})\n"; | |
530 | if ($msg{$_}) { | |
531 | print THITHER $msg{$_}; | |
532 | } else { | |
533 | if (0 and $standalone) { | |
534 | print THITHER " **** Error #$old_diag{$_} ", | |
535 | ($real ? "is" : "appears to be"), | |
536 | " an unknown diagnostic message.\n\n"; | |
537 | } | |
538 | return 0; | |
539 | } | |
540 | } | |
541 | return 1; | |
542 | } | |
543 | ||
544 | sub autodescribe { | |
545 | if ($VERBOSE and not $count) { | |
546 | print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"), | |
547 | "\n$msg{DESCRIPTION}\n"; | |
548 | } | |
549 | } | |
550 | ||
551 | sub unescape { | |
552 | s { | |
553 | E< | |
554 | ( [A-Za-z]+ ) | |
555 | > | |
556 | } { | |
557 | do { | |
558 | exists $HTML_Escapes{$1} | |
559 | ? do { $HTML_Escapes{$1} } | |
560 | : do { | |
561 | warn "Unknown escape: E<$1> in $_"; | |
562 | "E<$1>"; | |
563 | } | |
564 | } | |
565 | }egx; | |
566 | } | |
567 | ||
568 | sub shorten { | |
569 | my $line = $_[0]; | |
570 | if (length($line) > 79 and index($line, "\n") == -1) { | |
571 | my $space_place = rindex($line, ' ', 79); | |
572 | if ($space_place != -1) { | |
573 | substr($line, $space_place, 1) = "\n\t"; | |
574 | } | |
575 | } | |
576 | return $line; | |
577 | } | |
578 | ||
579 | ||
580 | 1 unless $standalone; # or it'll complain about itself | |
581 | __END__ # wish diag dbase were more accessible |