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
24 =head2 The C<diagnostics> Pragma
26 This module extends the terse diagnostics normally emitted by both the
27 perl compiler and the perl interpreter, augmenting them with the more
28 explicative and endearing descriptions found in L<perldiag>. Like the
29 other pragmata, it affects the compilation phase of your program rather
30 than merely the execution phase.
32 To use in your program as a pragma, merely invoke
36 at the start (or near the start) of your program. (Note
37 that this I<does> enable perl's B<-w> flag.) Your whole
38 compilation will then be subject(ed :-) to the enhanced diagnostics.
39 These still go out B<STDERR>.
41 Due to the interaction between runtime and compiletime issues,
42 and because it's probably not a very good idea anyway,
43 you may not use C<no diagnostics> to turn them off at compiletime.
44 However, you may control their behaviour at runtime using the
45 disable() and enable() methods to turn them off and on respectively.
47 The B<-verbose> flag first prints out the L<perldiag> introduction before
48 any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
49 escape sequences for pagers.
51 Warnings dispatched from perl itself (or more accurately, those that match
52 descriptions found in L<perldiag>) are only displayed once (no duplicate
53 descriptions). User code generated warnings a la warn() are unaffected,
54 allowing duplicate user messages to be displayed.
56 =head2 The I<splain> Program
58 While apparently a whole nuther program, I<splain> is actually nothing
59 more than a link to the (executable) F<diagnostics.pm> module, as well as
60 a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
61 the C<use diagnostics -verbose> directive.
62 The B<-p> flag is like the
63 $diagnostics::PRETTY variable. Since you're post-processing with
64 I<splain>, there's no sense in being able to enable() or disable() processing.
66 Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
70 The following file is certain to trigger a few errors at both
71 runtime and compiletime:
74 print NOWHERE "nothing\n";
75 print STDERR "\n\tThis message should be unadorned.\n";
76 warn "\tThis is a user warning";
77 print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
78 my $a, $b = scalar <STDIN>;
82 If you prefer to run your program first and look at its problem
85 perl -w test.pl 2>test.out
88 Note that this is not in general possible in shells of more dubious heritage,
91 (perl -w test.pl >/dev/tty) >& test.out
94 Because you just moved the existing B<stdout> to somewhere else.
96 If you don't want to modify your source code, but still have on-the-fly
99 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
103 If you want to control warnings on the fly, do something like this.
104 Make sure you do the C<use> first, or you won't be able to get
105 at the enable() or disable() methods.
107 use diagnostics; # checks entire compilation phase
108 print "\ntime for 1st bogus diags: SQUAWKINGS\n";
110 print "done with 1st bogus\n";
112 disable diagnostics; # only turns off runtime warnings
113 print "\ntime for 2nd bogus: (squelched)\n";
115 print "done with 2nd bogus\n";
117 enable diagnostics; # turns back on runtime warnings
118 print "\ntime for 3rd bogus: SQUAWKINGS\n";
120 print "done with 3rd bogus\n";
123 print "\ntime for 4th bogus: (squelched)\n";
125 print "done with 4th bogus\n";
129 Diagnostic messages derive from the F<perldiag.pod> file when available at
130 runtime. Otherwise, they may be embedded in the file itself when the
131 splain package is built. See the F<Makefile> for details.
133 If an extant $SIG{__WARN__} handler is discovered, it will continue
134 to be honored, but only after the diagnostics::splainthis() function
135 (the module's $SIG{__WARN__} interceptor) has had its way with your
138 There is a $diagnostics::DEBUG variable you may set if you're desperately
139 curious what sorts of things are being intercepted.
141 BEGIN { $diagnostics::DEBUG = 1 }
146 Not being able to say "no diagnostics" is annoying, but may not be
149 The C<-pretty> directive is called too late to affect matters.
150 You have to do this instead, and I<before> you load the module.
152 BEGIN { $diagnostics::PRETTY = 1 }
154 I could start up faster by delaying compilation until it should be
155 needed, but this gets a "panic: top_level" when using the pragma form
158 While it's true that this documentation is somewhat subserious, if you use
159 a program named I<splain>, you should expect a bit of whimsy.
163 Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
177 my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
179 require VMS::Filespec;
180 $privlib = VMS::Filespec::unixify($privlib);
181 $archlib = VMS::Filespec::unixify($archlib);
184 "$archlib/pod/perldiag.pod",
185 "$privlib/pod/perldiag-$Config{version}.pod",
186 "$privlib/pod/perldiag.pod",
187 "$archlib/pods/perldiag.pod",
188 "$privlib/pods/perldiag-$Config{version}.pod",
189 "$privlib/pods/perldiag.pod",
191 # handy for development testing of new warnings etc
192 unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
193 (my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
195 if ($^O eq 'MacOS') {
196 # just updir one from each lib dir, we'll find it ...
197 ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
202 my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
208 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
211 our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
216 Getopt::Std::getopts('pdvf:')
217 or die "Usage: $0 [-v] [-p] [-f splainpod]";
218 $PODFILE = $opt_f if $opt_f;
219 $DEBUG = 2 if $opt_d;
224 if (open(POD_DIAG, $PODFILE)) {
225 warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
231 for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
232 warn "Checking $file\n" if $DEBUG;
233 if (open(POD_DIAG, $file)) {
236 /^__END__\s*# wish diag dbase were more accessible/;
237 print STDERR "podfile is $file\n" if $DEBUG;
244 print STDERR "podfile is <DATA>\n" if $DEBUG;
245 *POD_DIAG = *main::DATA;
249 die "couldn't find diagnostic data in $PODFILE @INC $0";
254 'amp' => '&', # ampersand
255 'lt' => '<', # left chevron, less-than
256 'gt' => '>', # right chevron, greater-than
257 'quot' => '"', # double quote
259 "Aacute" => "A\\*'", # capital A, acute accent
265 'amp' => '&', # ampersand
266 'lt' => '<', # left chevron, less-than
267 'gt' => '>', # right chevron, greater-than
268 'quot' => '"', # double quote
270 "Aacute" => "\xC1" # capital A, acute accent
276 'amp' => '&', # ampersand
277 'lt' => '<', # left chevron, less-than
278 'gt' => '>', # right chevron, greater-than
279 'quot' => '"', # double quote
281 "Aacute" => "A" # capital A, acute accent
288 $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
294 *THITHER = $standalone ? *STDOUT : *STDERR;
297 my $transmo = <<EOFUNC;
299 #local \$^W = 0; # recursive warnings we do NOT need!
305 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
314 sub noop { return $_[0] } # spensive for a noop
315 sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
316 sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
317 s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
318 s/[LIF]<(.*?)>/italic($1)/ges;
320 s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
321 s/[LIF]<(.*?)>/$1/gs;
324 if (defined $header) {
325 if ( $header eq 'DESCRIPTION' &&
326 ( /Optional warnings are enabled/
327 || /Some of these messages are generic./
338 unless ( s/=item (.*?)\s*\z//) {
340 if ( s/=head1\sDESCRIPTION//) {
341 $msg{$header = 'DESCRIPTION'} = '';
344 elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
350 if( $for_item ) { $header = $for_item; undef $for_item }
353 while( $header =~ /[;,]\z/ ) {
354 <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
359 # strip formatting directives from =item line
360 $header =~ s/[A-Z]<(.*?)>/$1/g;
362 my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header );
365 for my $i (0..$#toks){
367 if( $toks[$i] eq '%c' ){
369 } elsif( $toks[$i] eq '%d' ){
371 } elsif( $toks[$i] eq '%s' ){
372 $toks[$i] = $i == $#toks ? '.*' : '.*?';
373 } elsif( $toks[$i] =~ '%.(\d+)s' ){
375 } elsif( $toks[$i] =~ '^%l*x$' ){
376 $toks[$i] = '[\da-f]+';
378 } elsif( length( $toks[$i] ) ){
379 $toks[$i] =~ s/^.*$/\Q$&\E/;
380 $conlen += length( $toks[$i] );
383 my $lhs = join( '', @toks );
384 $transfmt{$header}{pat} =
385 " s{^$lhs}\n {\Q$header\E}s\n\t&& return 1;\n";
386 $transfmt{$header}{len} = $conlen;
388 $transfmt{$header}{pat} =
389 " m{^\Q$header\E} && return 1;\n";
390 $transfmt{$header}{len} = length( $header );
393 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
400 close POD_DIAG unless *main::DATA eq *POD_DIAG;
402 die "No diagnostics?" unless %msg;
404 # Apply patterns in order of decreasing sum of lengths of fixed parts
405 # Seems the best way of hitting the right one.
406 for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
408 $transmo .= $transfmt{$hdr}{pat};
410 $transmo .= " return 0;\n}\n";
411 print STDERR $transmo if $DEBUG;
417 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
418 while (defined (my $error = <>)) {
419 splainthis($error) || print THITHER $error;
429 $^W = 1; # yup, clobbered the global variable;
430 # tough, if you want diags, you want diags.
431 return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
435 /^-d(ebug)?$/ && do {
440 /^-v(erbose)?$/ && do {
445 /^-p(retty)?$/ && do {
446 print STDERR "$0: I'm afraid it's too late for prettiness.\n";
451 warn "Unknown flag: $_";
454 $oldwarn = $SIG{__WARN__};
455 $olddie = $SIG{__DIE__};
456 $SIG{__WARN__} = \&warn_trap;
457 $SIG{__DIE__} = \&death_trap;
460 sub enable { &import }
464 return unless $SIG{__WARN__} eq \&warn_trap;
465 $SIG{__WARN__} = $oldwarn || '';
466 $SIG{__DIE__} = $olddie || '';
471 if (caller eq $WHOAMI or !splainthis($warning)) {
472 print STDERR $warning;
474 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
478 my $exception = $_[0];
480 # See if we are coming from anywhere within an eval. If so we don't
481 # want to explain the exception because it's going to get caught.
485 my $caller = (caller($i++))[3] or last;
486 if ($caller eq '(eval)') {
492 splainthis($exception) unless $in_eval;
493 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
494 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
498 # We don't want to unset these if we're coming from an eval because
499 # then we've turned off diagnostics.
501 # Switch off our die/warn handlers so we don't wind up in our own
503 $SIG{__DIE__} = $SIG{__WARN__} = '';
505 # Have carp skip over death_trap() when showing the stack trace.
506 local($Carp::CarpLevel) = 1;
508 confess "Uncaught exception from user code:\n\t$exception";
509 # up we go; where we stop, nobody knows, but i think we die now
510 # but i'm deeply afraid of the &$olddie guy reraising and us getting
511 # into an indirect recursion loop
521 ### &finish_compilation unless %msg;
524 # return unless defined;
526 # get rid of the where-are-we-in-input part
527 s/, <.*?> (?:line|chunk).*$//;
529 # Discard 1st " at <file> line <no>" and all text beyond
530 # but be aware of messsages containing " at this-or-that"
532 my @secs = split( / at / );
534 for my $i ( 1..$#secs ){
535 if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
539 $_ .= ' at ' . $secs[$i];
543 # remove parenthesis occurring at the end of some messages
546 if ($exact_duplicate{$orig}++) {
549 return 0 unless &transmo;
552 $orig = shorten($orig);
555 print THITHER "$orig (#$old_diag{$_})\n";
559 $old_diag{$_} = ++$count;
560 print THITHER "\n" if $wantspace;
562 print THITHER "$orig (#$old_diag{$_})\n";
564 print THITHER $msg{$_};
566 if (0 and $standalone) {
567 print THITHER " **** Error #$old_diag{$_} ",
568 ($real ? "is" : "appears to be"),
569 " an unknown diagnostic message.\n\n";
578 if ($VERBOSE and not $count) {
579 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
580 "\n$msg{DESCRIPTION}\n";
591 exists $HTML_Escapes{$1}
592 ? do { $HTML_Escapes{$1} }
594 warn "Unknown escape: E<$1> in $_";
603 if (length($line) > 79 and index($line, "\n") == -1) {
604 my $space_place = rindex($line, ' ', 79);
605 if ($space_place != -1) {
606 substr($line, $space_place, 1) = "\n\t";
613 1 unless $standalone; # or it'll complain about itself
614 __END__ # wish diag dbase were more accessible