5 diagnostics - Perl compiler pragma to force verbose warning diagnostics
7 splain - filter to produce verbose descriptions of perl warning diagnostics
14 use diagnostics -verbose;
21 perl program 2>diag.out
22 splain [-v] [-p] diag.out
27 =head2 The C<diagnostics> Pragma
29 This module extends the terse diagnostics normally emitted by both the
30 perl compiler and the perl interpreter, augmenting them with the more
31 explicative and endearing descriptions found in L<perldiag>. Like the
32 other pragmata, it affects the compilation phase of your program rather
33 than merely the execution phase.
35 To use in your program as a pragma, merely invoke
39 at the start (or near the start) of your program. (Note
40 that this I<does> enable perl's B<-w> flag.) Your whole
41 compilation will then be subject(ed :-) to the enhanced diagnostics.
42 These still go out B<STDERR>.
44 Due to the interaction between runtime and compiletime issues,
45 and because it's probably not a very good idea anyway,
46 you may not use C<no diagnostics> to turn them off at compiletime.
47 However, you may control their behaviour at runtime using the
48 disable() and enable() methods to turn them off and on respectively.
50 The B<-verbose> flag first prints out the L<perldiag> introduction before
51 any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
52 escape sequences for pagers.
54 Warnings dispatched from perl itself (or more accurately, those that match
55 descriptions found in L<perldiag>) are only displayed once (no duplicate
56 descriptions). User code generated warnings a la warn() are unaffected,
57 allowing duplicate user messages to be displayed.
59 =head2 The I<splain> Program
61 While apparently a whole nuther program, I<splain> is actually nothing
62 more than a link to the (executable) F<diagnostics.pm> module, as well as
63 a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
64 the C<use diagnostics -verbose> directive.
65 The B<-p> flag is like the
66 $diagnostics::PRETTY variable. Since you're post-processing with
67 I<splain>, there's no sense in being able to enable() or disable() processing.
69 Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
73 The following file is certain to trigger a few errors at both
74 runtime and compiletime:
77 print NOWHERE "nothing\n";
78 print STDERR "\n\tThis message should be unadorned.\n";
79 warn "\tThis is a user warning";
80 print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
81 my $a, $b = scalar <STDIN>;
85 If you prefer to run your program first and look at its problem
88 perl -w test.pl 2>test.out
91 Note that this is not in general possible in shells of more dubious heritage,
94 (perl -w test.pl >/dev/tty) >& test.out
97 Because you just moved the existing B<stdout> to somewhere else.
99 If you don't want to modify your source code, but still have on-the-fly
102 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
106 If you want to control warnings on the fly, do something like this.
107 Make sure you do the C<use> first, or you won't be able to get
108 at the enable() or disable() methods.
110 use diagnostics; # checks entire compilation phase
111 print "\ntime for 1st bogus diags: SQUAWKINGS\n";
113 print "done with 1st bogus\n";
115 disable diagnostics; # only turns off runtime warnings
116 print "\ntime for 2nd bogus: (squelched)\n";
118 print "done with 2nd bogus\n";
120 enable diagnostics; # turns back on runtime warnings
121 print "\ntime for 3rd bogus: SQUAWKINGS\n";
123 print "done with 3rd bogus\n";
126 print "\ntime for 4th bogus: (squelched)\n";
128 print "done with 4th bogus\n";
132 Diagnostic messages derive from the F<perldiag.pod> file when available at
133 runtime. Otherwise, they may be embedded in the file itself when the
134 splain package is built. See the F<Makefile> for details.
136 If an extant $SIG{__WARN__} handler is discovered, it will continue
137 to be honored, but only after the diagnostics::splainthis() function
138 (the module's $SIG{__WARN__} interceptor) has had its way with your
141 There is a $diagnostics::DEBUG variable you may set if you're desperately
142 curious what sorts of things are being intercepted.
144 BEGIN { $diagnostics::DEBUG = 1 }
149 Not being able to say "no diagnostics" is annoying, but may not be
152 The C<-pretty> directive is called too late to affect matters.
153 You have to do this instead, and I<before> you load the module.
155 BEGIN { $diagnostics::PRETTY = 1 }
157 I could start up faster by delaying compilation until it should be
158 needed, but this gets a "panic: top_level" when using the pragma form
161 While it's true that this documentation is somewhat subserious, if you use
162 a program named I<splain>, you should expect a bit of whimsy.
166 Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
180 my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
182 require VMS::Filespec;
183 $privlib = VMS::Filespec::unixify($privlib);
184 $archlib = VMS::Filespec::unixify($archlib);
187 "$archlib/pod/perldiag.pod",
188 "$privlib/pod/perldiag-$Config{version}.pod",
189 "$privlib/pod/perldiag.pod",
190 "$archlib/pods/perldiag.pod",
191 "$privlib/pods/perldiag-$Config{version}.pod",
192 "$privlib/pods/perldiag.pod",
194 # handy for development testing of new warnings etc
195 unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
196 (my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
198 if ($^O eq 'MacOS') {
199 # just updir one from each lib dir, we'll find it ...
200 ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
205 my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
211 my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
214 our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
219 Getopt::Std::getopts('pdvf:')
220 or die "Usage: $0 [-v] [-p] [-f splainpod]";
221 $PODFILE = $opt_f if $opt_f;
222 $DEBUG = 2 if $opt_d;
227 if (open(POD_DIAG, $PODFILE)) {
228 warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
234 for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
235 warn "Checking $file\n" if $DEBUG;
236 if (open(POD_DIAG, $file)) {
239 /^__END__\s*# wish diag dbase were more accessible/;
240 print STDERR "podfile is $file\n" if $DEBUG;
247 print STDERR "podfile is <DATA>\n" if $DEBUG;
248 *POD_DIAG = *main::DATA;
252 die "couldn't find diagnostic data in $PODFILE @INC $0";
257 'amp' => '&', # ampersand
258 'lt' => '<', # left chevron, less-than
259 'gt' => '>', # right chevron, greater-than
260 'quot' => '"', # double quote
262 "Aacute" => "A\\*'", # capital A, acute accent
268 'amp' => '&', # ampersand
269 'lt' => '<', # left chevron, less-than
270 'gt' => '>', # right chevron, greater-than
271 'quot' => '"', # double quote
273 "Aacute" => "\xC1" # capital A, acute accent
279 'amp' => '&', # ampersand
280 'lt' => '<', # left chevron, less-than
281 'gt' => '>', # right chevron, greater-than
282 'quot' => '"', # double quote
284 "Aacute" => "A" # capital A, acute accent
291 $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
297 *THITHER = $standalone ? *STDOUT : *STDERR;
300 my $transmo = <<EOFUNC;
302 #local \$^W = 0; # recursive warnings we do NOT need!
308 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
317 sub noop { return $_[0] } # spensive for a noop
318 sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
319 sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
320 s/[BC]<(.*?)>/bold($1)/ges;
321 s/[LIF]<(.*?)>/italic($1)/ges;
324 s/[LIF]<(.*?)>/$1/gs;
327 if (defined $header) {
328 if ( $header eq 'DESCRIPTION' &&
329 ( /Optional warnings are enabled/
330 || /Some of these messages are generic./
341 unless ( s/=item (.*?)\s*\z//) {
343 if ( s/=head1\sDESCRIPTION//) {
344 $msg{$header = 'DESCRIPTION'} = '';
347 elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
353 if( $for_item ) { $header = $for_item; undef $for_item }
356 while( $header =~ /[;,]\z/ ) {
357 <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
362 # strip formatting directives from =item line
363 $header =~ s/[A-Z]<(.*?)>/$1/g;
365 my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header );
368 for my $i (0..$#toks){
370 if( $toks[$i] eq '%c' ){
372 } elsif( $toks[$i] eq '%d' ){
374 } elsif( $toks[$i] eq '%s' ){
375 $toks[$i] = $i == $#toks ? '.*' : '.*?';
376 } elsif( $toks[$i] =~ '%.(\d+)s' ){
378 } elsif( $toks[$i] =~ '^%l*x$' ){
379 $toks[$i] = '[\da-f]+';
381 } elsif( length( $toks[$i] ) ){
382 $toks[$i] =~ s/^.*$/\Q$&\E/;
383 $conlen += length( $toks[$i] );
386 my $lhs = join( '', @toks );
387 $transfmt{$header}{pat} =
388 " s{^$lhs}\n {\Q$header\E}s\n\t&& return 1;\n";
389 $transfmt{$header}{len} = $conlen;
391 $transfmt{$header}{pat} =
392 " m{^\Q$header\E} && return 1;\n";
393 $transfmt{$header}{len} = length( $header );
396 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
403 close POD_DIAG unless *main::DATA eq *POD_DIAG;
405 die "No diagnostics?" unless %msg;
407 # Apply patterns in order of decreasing sum of lengths of fixed parts
408 # Seems the best way of hitting the right one.
409 for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
411 $transmo .= $transfmt{$hdr}{pat};
413 $transmo .= " return 0;\n}\n";
414 print STDERR $transmo if $DEBUG;
420 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
421 while (defined (my $error = <>)) {
422 splainthis($error) || print THITHER $error;
432 $^W = 1; # yup, clobbered the global variable;
433 # tough, if you want diags, you want diags.
434 return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
438 /^-d(ebug)?$/ && do {
443 /^-v(erbose)?$/ && do {
448 /^-p(retty)?$/ && do {
449 print STDERR "$0: I'm afraid it's too late for prettiness.\n";
454 warn "Unknown flag: $_";
457 $oldwarn = $SIG{__WARN__};
458 $olddie = $SIG{__DIE__};
459 $SIG{__WARN__} = \&warn_trap;
460 $SIG{__DIE__} = \&death_trap;
463 sub enable { &import }
467 return unless $SIG{__WARN__} eq \&warn_trap;
468 $SIG{__WARN__} = $oldwarn || '';
469 $SIG{__DIE__} = $olddie || '';
474 if (caller eq $WHOAMI or !splainthis($warning)) {
475 print STDERR $warning;
477 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
481 my $exception = $_[0];
483 # See if we are coming from anywhere within an eval. If so we don't
484 # want to explain the exception because it's going to get caught.
488 my $caller = (caller($i++))[3] or last;
489 if ($caller eq '(eval)') {
495 splainthis($exception) unless $in_eval;
496 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
497 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
501 # We don't want to unset these if we're coming from an eval because
502 # then we've turned off diagnostics.
504 # Switch off our die/warn handlers so we don't wind up in our own
506 $SIG{__DIE__} = $SIG{__WARN__} = '';
508 # Have carp skip over death_trap() when showing the stack trace.
509 local($Carp::CarpLevel) = 1;
511 confess "Uncaught exception from user code:\n\t$exception";
512 # up we go; where we stop, nobody knows, but i think we die now
513 # but i'm deeply afraid of the &$olddie guy reraising and us getting
514 # into an indirect recursion loop
524 ### &finish_compilation unless %msg;
527 # return unless defined;
529 # get rid of the where-are-we-in-input part
530 s/, <.*?> (?:line|chunk).*$//;
532 # Discard 1st " at <file> line <no>" and all text beyond
533 # but be aware of messsages containing " at this-or-that"
535 my @secs = split( / at / );
537 for my $i ( 1..$#secs ){
538 if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
542 $_ .= ' at ' . $secs[$i];
546 # remove parenthesis occurring at the end of some messages
549 if ($exact_duplicate{$orig}++) {
552 return 0 unless &transmo;
555 $orig = shorten($orig);
558 print THITHER "$orig (#$old_diag{$_})\n";
562 $old_diag{$_} = ++$count;
563 print THITHER "\n" if $wantspace;
565 print THITHER "$orig (#$old_diag{$_})\n";
567 print THITHER $msg{$_};
569 if (0 and $standalone) {
570 print THITHER " **** Error #$old_diag{$_} ",
571 ($real ? "is" : "appears to be"),
572 " an unknown diagnostic message.\n\n";
581 if ($VERBOSE and not $count) {
582 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
583 "\n$msg{DESCRIPTION}\n";
594 exists $HTML_Escapes{$1}
595 ? do { $HTML_Escapes{$1} }
597 warn "Unknown escape: E<$1> in $_";
606 if (length($line) > 79 and index($line, "\n") == -1) {
607 my $space_place = rindex($line, ' ', 79);
608 if ($space_place != -1) {
609 substr($line, $space_place, 1) = "\n\t";
616 1 unless $standalone; # or it'll complain about itself
617 __END__ # wish diag dbase were more accessible