5 diagnostics, splain - produce verbose warning diagnostics
9 Using the C<diagnostics> pragma:
12 use diagnostics -verbose;
17 Using the C<splain> standalone filter program:
19 perl program 2>diag.out
20 splain [-v] [-p] diag.out
22 Using diagnostics to get stack traces from a misbehaving script:
24 perl -Mdiagnostics=-traceonly my_script.pl
28 =head2 The C<diagnostics> Pragma
30 This module extends the terse diagnostics normally emitted by both the
31 perl compiler and the perl interpreter, augmenting them with the more
32 explicative and endearing descriptions found in L<perldiag>. Like the
33 other pragmata, it affects the compilation phase of your program rather
34 than merely the execution phase.
36 To use in your program as a pragma, merely invoke
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>.
45 Due to the interaction between runtime and compiletime issues,
46 and because it's probably not a very good idea anyway,
47 you may not use C<no diagnostics> to turn them off at compiletime.
48 However, you may control their behaviour at runtime using the
49 disable() and enable() methods to turn them off and on respectively.
51 The B<-verbose> flag first prints out the L<perldiag> introduction before
52 any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
53 escape sequences for pagers.
55 Warnings dispatched from perl itself (or more accurately, those that match
56 descriptions found in L<perldiag>) are only displayed once (no duplicate
57 descriptions). User code generated warnings a la warn() are unaffected,
58 allowing duplicate user messages to be displayed.
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
65 perl -Mdiagnostics=-traceonly my_bad_script
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
71 =head2 The I<splain> Program
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.
81 Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
85 The following file is certain to trigger a few errors at both
86 runtime and compiletime:
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>;
97 If you prefer to run your program first and look at its problem
100 perl -w test.pl 2>test.out
103 Note that this is not in general possible in shells of more dubious heritage,
106 (perl -w test.pl >/dev/tty) >& test.out
109 Because you just moved the existing B<stdout> to somewhere else.
111 If you don't want to modify your source code, but still have on-the-fly
114 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
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.
122 use diagnostics; # checks entire compilation phase
123 print "\ntime for 1st bogus diags: SQUAWKINGS\n";
125 print "done with 1st bogus\n";
127 disable diagnostics; # only turns off runtime warnings
128 print "\ntime for 2nd bogus: (squelched)\n";
130 print "done with 2nd bogus\n";
132 enable diagnostics; # turns back on runtime warnings
133 print "\ntime for 3rd bogus: SQUAWKINGS\n";
135 print "done with 3rd bogus\n";
138 print "\ntime for 4th bogus: (squelched)\n";
140 print "done with 4th bogus\n";
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.
148 If an extant $SIG{__WARN__} handler is discovered, it will continue
149 to be honored, but only after the diagnostics::splainthis() function
150 (the module's $SIG{__WARN__} interceptor) has had its way with your
153 There is a $diagnostics::DEBUG variable you may set if you're desperately
154 curious what sorts of things are being intercepted.
156 BEGIN { $diagnostics::DEBUG = 1 }
161 Not being able to say "no diagnostics" is annoying, but may not be
164 The C<-pretty> directive is called too late to affect matters.
165 You have to do this instead, and I<before> you load the module.
167 BEGIN { $diagnostics::PRETTY = 1 }
169 I could start up faster by delaying compilation until it should be
170 needed, but this gets a "panic: top_level" when using the pragma form
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.
178 Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
185 $Carp::Internal{__PACKAGE__.""}++;
195 my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
197 require VMS::Filespec;
198 $privlib = VMS::Filespec::unixify($privlib);
199 $archlib = VMS::Filespec::unixify($archlib);
202 "$archlib/pod/perldiag.pod",
203 "$privlib/pod/perldiag-$Config{version}.pod",
204 "$privlib/pod/perldiag.pod",
205 "$archlib/pods/perldiag.pod",
206 "$privlib/pods/perldiag-$Config{version}.pod",
207 "$privlib/pods/perldiag.pod",
209 # handy for development testing of new warnings etc
210 unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
211 (my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
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;
220 my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
226 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
229 our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
234 Getopt::Std::getopts('pdvf:')
235 or die "Usage: $0 [-v] [-p] [-f splainpod]";
236 $PODFILE = $opt_f if $opt_f;
237 $DEBUG = 2 if $opt_d;
242 if (open(POD_DIAG, $PODFILE)) {
243 warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
249 for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
250 warn "Checking $file\n" if $DEBUG;
251 if (open(POD_DIAG, $file)) {
254 /^__END__\s*# wish diag dbase were more accessible/;
255 print STDERR "podfile is $file\n" if $DEBUG;
262 print STDERR "podfile is <DATA>\n" if $DEBUG;
263 *POD_DIAG = *main::DATA;
267 die "couldn't find diagnostic data in $PODFILE @INC $0";
272 'amp' => '&', # ampersand
273 'lt' => '<', # left chevron, less-than
274 'gt' => '>', # right chevron, greater-than
275 'quot' => '"', # double quote
277 "Aacute" => "A\\*'", # capital A, acute accent
283 'amp' => '&', # ampersand
284 'lt' => '<', # left chevron, less-than
285 'gt' => '>', # right chevron, greater-than
286 'quot' => '"', # double quote
288 "Aacute" => "\xC1" # capital A, acute accent
294 'amp' => '&', # ampersand
295 'lt' => '<', # left chevron, less-than
296 'gt' => '>', # right chevron, greater-than
297 'quot' => '"', # double quote
299 "Aacute" => "A" # capital A, acute accent
306 $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
312 *THITHER = $standalone ? *STDOUT : *STDERR;
315 my $transmo = <<EOFUNC;
317 #local \$^W = 0; # recursive warnings we do NOT need!
323 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
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; }
335 s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
336 s/[LIF]<(.*?)>/italic($1)/ges;
338 s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
339 s/[LIF]<(.*?)>/$1/gs;
342 if (defined $header) {
343 if ( $header eq 'DESCRIPTION' &&
344 ( /Optional warnings are enabled/
345 || /Some of these messages are generic./
356 unless ( s/=item (.*?)\s*\z//) {
358 if ( s/=head1\sDESCRIPTION//) {
359 $msg{$header = 'DESCRIPTION'} = '';
362 elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
368 if( $for_item ) { $header = $for_item; undef $for_item }
371 while( $header =~ /[;,]\z/ ) {
372 <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
377 # strip formatting directives from =item line
378 $header =~ s/[A-Z]<(.*?)>/$1/g;
380 my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header );
383 for my $i (0..$#toks){
385 if( $toks[$i] eq '%c' ){
387 } elsif( $toks[$i] eq '%d' ){
389 } elsif( $toks[$i] eq '%s' ){
390 $toks[$i] = $i == $#toks ? '.*' : '.*?';
391 } elsif( $toks[$i] =~ '%.(\d+)s' ){
393 } elsif( $toks[$i] =~ '^%l*x$' ){
394 $toks[$i] = '[\da-f]+';
396 } elsif( length( $toks[$i] ) ){
397 $toks[$i] =~ s/^.*$/\Q$&\E/;
398 $conlen += length( $toks[$i] );
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;
406 $transfmt{$header}{pat} =
407 " m{^\Q$header\E} && return 1;\n";
408 $transfmt{$header}{len} = length( $header );
411 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
418 close POD_DIAG unless *main::DATA eq *POD_DIAG;
420 die "No diagnostics?" unless %msg;
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} }
426 $transmo .= $transfmt{$hdr}{pat};
428 $transmo .= " return 0;\n}\n";
429 print STDERR $transmo if $DEBUG;
435 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
436 while (defined (my $error = <>)) {
437 splainthis($error) || print THITHER $error;
447 $^W = 1; # yup, clobbered the global variable;
448 # tough, if you want diags, you want diags.
449 return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
453 /^-d(ebug)?$/ && do {
458 /^-v(erbose)?$/ && do {
463 /^-p(retty)?$/ && do {
464 print STDERR "$0: I'm afraid it's too late for prettiness.\n";
469 /^-t(race)?$/ && do {
473 /^-w(arntrace)?$/ && do {
478 warn "Unknown flag: $_";
481 $oldwarn = $SIG{__WARN__};
482 $olddie = $SIG{__DIE__};
483 $SIG{__WARN__} = \&warn_trap;
484 $SIG{__DIE__} = \&death_trap;
487 sub enable { &import }
491 return unless $SIG{__WARN__} eq \&warn_trap;
492 $SIG{__WARN__} = $oldwarn || '';
493 $SIG{__DIE__} = $olddie || '';
498 if (caller eq $WHOAMI or !splainthis($warning)) {
500 print STDERR Carp::longmess($warning);
502 print STDERR $warning;
505 goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
509 my $exception = $_[0];
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.
515 while (my $caller = (caller($i++))[3]) {
516 if ($caller eq '(eval)') {
522 splainthis($exception) unless $in_eval;
523 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
524 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
528 # We don't want to unset these if we're coming from an eval because
529 # then we've turned off diagnostics.
531 # Switch off our die/warn handlers so we don't wind up in our own
533 $SIG{__DIE__} = $SIG{__WARN__} = '';
535 # Have carp skip over death_trap() when showing the stack trace.
536 local($Carp::CarpLevel) = 1;
538 confess "Uncaught exception from user code:\n\t$exception";
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
549 return 0 if $TRACEONLY;
552 ### &finish_compilation unless %msg;
555 # return unless defined;
557 # get rid of the where-are-we-in-input part
558 s/, <.*?> (?:line|chunk).*$//;
560 # Discard 1st " at <file> line <no>" and all text beyond
561 # but be aware of messsages containing " at this-or-that"
563 my @secs = split( / at / );
565 for my $i ( 1..$#secs ){
566 if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
570 $_ .= ' at ' . $secs[$i];
574 # remove parenthesis occurring at the end of some messages
577 if ($exact_duplicate{$orig}++) {
580 return 0 unless &transmo;
583 $orig = shorten($orig);
586 print THITHER "$orig (#$old_diag{$_})\n";
590 $old_diag{$_} = ++$count;
591 print THITHER "\n" if $wantspace;
593 print THITHER "$orig (#$old_diag{$_})\n";
595 print THITHER $msg{$_};
597 if (0 and $standalone) {
598 print THITHER " **** Error #$old_diag{$_} ",
599 ($real ? "is" : "appears to be"),
600 " an unknown diagnostic message.\n\n";
609 if ($VERBOSE and not $count) {
610 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
611 "\n$msg{DESCRIPTION}\n";
622 exists $HTML_Escapes{$1}
623 ? do { $HTML_Escapes{$1} }
625 warn "Unknown escape: E<$1> in $_";
634 if (length($line) > 79 and index($line, "\n") == -1) {
635 my $space_place = rindex($line, ' ', 79);
636 if ($space_place != -1) {
637 substr($line, $space_place, 1) = "\n\t";
644 1 unless $standalone; # or it'll complain about itself
645 __END__ # wish diag dbase were more accessible