5 diagnostics - Perl compiler pragma to force verbose warning diagnostics
7 splain - standalone program to do the same thing
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 interpeter, 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 there 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 =head2 The I<splain> Program
56 While apparently a whole nuther program, I<splain> is actually nothing
57 more than a link to the (executable) F<diagnostics.pm> module, as well as
58 a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
59 the C<use diagnostics -verbose> directive.
60 The B<-p> flag is like the
61 $diagnostics::PRETTY variable. Since you're post-processing with
62 I<splain>, there's no sense in being able to enable() or disable() processing.
64 Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
68 The following file is certain to trigger a few errors at both
69 runtime and compiletime:
72 print NOWHERE "nothing\n";
73 print STDERR "\n\tThis message should be unadorned.\n";
74 warn "\tThis is a user warning";
75 print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
76 my $a, $b = scalar <STDIN>;
80 If you prefer to run your program first and look at its problem
83 perl -w test.pl 2>test.out
86 Note that this is not in general possible in shells of more dubious heritage,
89 (perl -w test.pl >/dev/tty) >& test.out
92 Because you just moved the existing B<stdout> to somewhere else.
94 If you don't want to modify your source code, but still have on-the-fly
97 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
101 If you want to control warnings on the fly, do something like this.
102 Make sure you do the C<use> first, or you won't be able to get
103 at the enable() or disable() methods.
105 use diagnostics; # checks entire compilation phase
106 print "\ntime for 1st bogus diags: SQUAWKINGS\n";
108 print "done with 1st bogus\n";
110 disable diagnostics; # only turns off runtime warnings
111 print "\ntime for 2nd bogus: (squelched)\n";
113 print "done with 2nd bogus\n";
115 enable diagnostics; # turns back on runtime warnings
116 print "\ntime for 3rd bogus: SQUAWKINGS\n";
118 print "done with 3rd bogus\n";
121 print "\ntime for 4th bogus: (squelched)\n";
123 print "done with 4th bogus\n";
127 Diagnostic messages derive from the F<perldiag.pod> file when available at
128 runtime. Otherwise, they may be embedded in the file itself when the
129 splain package is built. See the F<Makefile> for details.
131 If an extant $SIG{__WARN__} handler is discovered, it will continue
132 to be honored, but only after the diagnostics::splainthis() function
133 (the module's $SIG{__WARN__} interceptor) has had its way with your
136 There is a $diagnostics::DEBUG variable you may set if you're desperately
137 curious what sorts of things are being intercepted.
139 BEGIN { $diagnostics::DEBUG = 1 }
144 Not being able to say "no diagnostics" is annoying, but may not be
147 The C<-pretty> directive is called too late to affect matters.
148 You have to do this instead, and I<before> you load the module.
150 BEGIN { $diagnostics::PRETTY = 1 }
152 I could start up faster by delaying compilation until it should be
153 needed, but this gets a "panic: top_level" when using the pragma form
156 While it's true that this documentation is somewhat subserious, if you use
157 a program named I<splain>, you should expect a bit of whimsy.
161 Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
169 ($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
171 require VMS::Filespec;
172 $privlib = VMS::Filespec::unixify($privlib);
173 $archlib = VMS::Filespec::unixify($archlib);
175 @trypod = ("$archlib/pod/perldiag.pod",
176 "$privlib/pod/perldiag-$].pod",
177 "$privlib/pod/perldiag.pod");
178 # handy for development testing of new warnings etc
179 unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
180 ($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
183 my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
190 $opt_p = $opt_d = $opt_v = $opt_f = '';
191 %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();
192 %exact_duplicate = ();
197 Getopt::Std::getopts('pdvf:')
198 or die "Usage: $0 [-v] [-p] [-f splainpod]";
199 $PODFILE = $opt_f if $opt_f;
200 $DEBUG = 2 if $opt_d;
205 if (open(POD_DIAG, $PODFILE)) {
206 warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
212 for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
213 warn "Checking $file\n" if $DEBUG;
214 if (open(POD_DIAG, $file)) {
216 next unless /^__END__\s*# wish diag dbase were more accessible/;
217 print STDERR "podfile is $file\n" if $DEBUG;
224 print STDERR "podfile is <DATA>\n" if $DEBUG;
225 *POD_DIAG = *main::DATA;
229 die "couldn't find diagnostic data in $PODFILE @INC $0";
234 'amp' => '&', # ampersand
235 'lt' => '<', # left chevron, less-than
236 'gt' => '>', # right chevron, greater-than
237 'quot' => '"', # double quote
239 "Aacute" => "A\\*'", # capital A, acute accent
245 'amp' => '&', # ampersand
246 'lt' => '<', # left chevron, less-than
247 'gt' => '>', # right chevron, greater-than
248 'quot' => '"', # double quote
250 "Aacute" => "\xC1" # capital A, acute accent
256 'amp' => '&', # ampersand
257 'lt' => '<', # left chevron, less-than
258 'gt' => '>', # right chevron, greater-than
259 'quot' => '"', # double quote
261 "Aacute" => "A" # capital A, acute accent
267 $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
273 *THITHER = $standalone ? *STDOUT : *STDERR;
277 #local \$^W = 0; # recursive warnings we do NOT need!
281 ### sub finish_compilation { # 5.001e panic: top_level for embedded version
282 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
292 sub noop { return $_[0] } # spensive for a noop
293 sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
294 sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
295 s/[BC]<(.*?)>/bold($1)/ges;
296 s/[LIF]<(.*?)>/italic($1)/ges;
299 s/[LIF]<(.*?)>/$1/gs;
302 if (defined $header) {
303 if ( $header eq 'DESCRIPTION' &&
304 ( /Optional warnings are enabled/
305 || /Some of these messages are generic./
315 unless ( s/=item (.*)\s*\Z//) {
317 if ( s/=head1\sDESCRIPTION//) {
318 $msg{$header = 'DESCRIPTION'} = '';
323 # strip formatting directives in =item line
324 ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g;
326 if ($header =~ /%[sd]/) {
327 $rhs = $lhs = $header;
328 #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) {
329 if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) {
330 $lhs =~ s/\\%s/.*?/g;
332 # if i had lookbehind negations, i wouldn't have to do this \377 noise
333 $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
334 #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
335 $lhs =~ s/\377([^\377]*)$/\Q$1\E/;
337 $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
339 $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n";
341 $transmo .= " m{^\Q$header\E} && return 1;\n";
344 print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
351 close POD_DIAG unless *main::DATA eq *POD_DIAG;
353 die "No diagnostics?" unless %msg;
355 $transmo .= " return 0;\n}\n";
356 print STDERR $transmo if $DEBUG;
363 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
364 while (defined ($error = <>)) {
365 splainthis($error) || print THITHER $error;
369 $old_w = 0; $oldwarn = ''; $olddie = '';
375 $^W = 1; # yup, clobbered the global variable; tough, if you
376 # want diags, you want diags.
377 return if $SIG{__WARN__} eq \&warn_trap;
381 /^-d(ebug)?$/ && do {
386 /^-v(erbose)?$/ && do {
391 /^-p(retty)?$/ && do {
392 print STDERR "$0: I'm afraid it's too late for prettiness.\n";
397 warn "Unknown flag: $_";
400 $oldwarn = $SIG{__WARN__};
401 $olddie = $SIG{__DIE__};
402 $SIG{__WARN__} = \&warn_trap;
403 $SIG{__DIE__} = \&death_trap;
406 sub enable { &import }
411 return unless $SIG{__WARN__} eq \&warn_trap;
412 $SIG{__WARN__} = $oldwarn;
413 $SIG{__DIE__} = $olddie;
418 if (caller eq $WHOAMI or !splainthis($warning)) {
419 print STDERR $warning;
421 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
425 my $exception = $_[0];
427 # See if we are coming from anywhere within an eval. If so we don't
428 # want to explain the exception because it's going to get caught.
432 my $caller = (caller($i++))[3] or last;
433 if ($caller eq '(eval)') {
439 splainthis($exception) unless $in_eval;
440 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
441 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
443 # We don't want to unset these if we're coming from an eval because
444 # then we've turned off diagnostics. (Actually what does this next
446 $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
447 local($Carp::CarpLevel) = 1;
448 confess "Uncaught exception from user code:\n\t$exception";
449 # up we go; where we stop, nobody knows, but i think we die now
450 # but i'm deeply afraid of the &$olddie guy reraising and us getting
451 # into an indirect recursion loop
457 ### &finish_compilation unless %msg;
460 # return unless defined;
461 if ($exact_duplicate{$_}++) {
464 s/, <.*?> (?:line|chunk).*$//;
465 $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
467 return 0 unless &transmo;
468 $orig = shorten($orig);
471 print THITHER "$orig (#$old_diag{$_})\n";
475 $old_diag{$_} = ++$count;
476 print THITHER "\n" if $wantspace;
478 print THITHER "$orig (#$old_diag{$_})\n";
480 print THITHER $msg{$_};
482 if (0 and $standalone) {
483 print THITHER " **** Error #$old_diag{$_} ",
484 ($real ? "is" : "appears to be"),
485 " an unknown diagnostic message.\n\n";
494 if ($VERBOSE and not $count) {
495 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
496 "\n$msg{DESCRIPTION}\n";
507 exists $HTML_Escapes{$1}
508 ? do { $HTML_Escapes{$1} }
510 warn "Unknown escape: E<$1> in $_";
519 if (length($line) > 79 and index($line, "\n") == -1) {
520 my $space_place = rindex($line, ' ', 79);
521 if ($space_place != -1) {
522 substr($line, $space_place, 1) = "\n\t";
529 # have to do this: RS isn't set until run time, but we're executing at compile time
532 1 unless $standalone; # or it'll complain about itself
533 __END__ # wish diag dbase were more accessible