2 eval 'exec perl -S $0 ${1+"$@"}'
6 $diagnostics::PODFILE= $Config{privlib} . "/pod/perldiag.pod";
15 diagnostics - Perl compiler pragma to force verbose warning diagnostics
17 splain - standalone program to do the same thing
24 use diagnostics -verbose;
31 perl program 2>diag.out
32 splain [-v] [-p] diag.out
37 =head2 The C<diagnostics> Pragma
39 This module extends the terse diagnostics normally emitted by both the
40 perl compiler and the perl interpeter, augmenting them wtih the more
41 explicative and endearing descriptions found in L<perldiag>. Like the
42 other pragmata, it affects to compilation phase of your program rather
43 than merely the execution phase.
45 To use in your program as a pragma, merely invoke
49 at the start (or near the start) of your program. (Note
50 that this I<does> enable perl's B<-w> flag.) Your whole
51 compilation will then be subject(ed :-) to the enhanced diagnostics.
52 These still go out B<STDERR>.
54 Due to the interaction between runtime and compiletime issues,
55 and because it's probably not a very good idea anyway,
56 you may not use C<no diagnostics> to turn them off at compiletime.
57 However, you may control there behaviour at runtime using the
58 disable() and enable() methods to turn them off and on respectively.
60 The B<-verbose> flag first prints out the L<perldiag> introduction before
61 any other diagnostics. The $diagnostics::PRETTY can generate nicer escape
64 =head2 The I<splain> Program
66 While apparently a whole nuther program, I<splain> is actually nothing
67 more than a link to the (executable) F<diagnostics.pm> module, as well as
68 a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
69 the C<use diagnostics -verbose> directive.
70 The B<-p> flag is like the
71 $diagnostics::PRETTY variable. Since you're post-processing with
72 I<splain>, there's no sense in being able to enable() or disable() processing.
74 Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
78 The following file is certain to trigger a few errors at both
79 runtime and compiletime:
82 print NOWHERE "nothing\n";
83 print STDERR "\n\tThis message should be unadorned.\n";
84 warn "\tThis is a user warning";
85 print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
86 my $a, $b = scalar <STDIN>;
90 If you prefer to run your program first and look at its problem
93 perl -w test.pl 2>test.out
96 Note that this is not in general possible in shells of more dubious heritage,
99 (perl -w test.pl >/dev/tty) >& test.out
102 Because you just moved the existing B<stdout> to somewhere else.
104 If you don't want to modify your source code, but still have on-the-fly
107 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
111 If you want to control warnings on the fly, do something like this.
112 Make sure you do the C<use> first, or you won't be able to get
113 at the enable() or disable() methods.
115 use diagnostics; # checks entire compilation phase
116 print "\ntime for 1st bogus diags: SQUAWKINGS\n";
118 print "done with 1st bogus\n";
120 disable diagnostics; # only turns off runtime warnings
121 print "\ntime for 2nd bogus: (squelched)\n";
123 print "done with 2nd bogus\n";
125 enable diagnostics; # turns back on runtime warnings
126 print "\ntime for 3rd bogus: SQUAWKINGS\n";
128 print "done with 3rd bogus\n";
131 print "\ntime for 4th bogus: (squelched)\n";
133 print "done with 4th bogus\n";
137 Diagnostic messages derive from the F<perldiag.pod> file when available at
138 runtime. Otherwise, they may be embedded in the file itself when the
139 splain package is built. See the F<Makefile> for details.
141 If an extant $SIG{__WARN__} handler is discovered, it will continue
142 to be honored, but only after the diagnostic::splainthis() function
143 (the module's $SIG{__WARN__} interceptor) has had its way with your
146 There is a $diagnostics::DEBUG variable you may set if you're desperately
147 curious what sorts of things are being intercepted.
149 BEGIN { $diagnostics::DEBUG = 1 }
154 Not being able to say "no diagnostics" is annoying, but may not be
157 The C<-pretty> directive is called too late to affect matters.
158 You have to to this instead, and I<before> you load the module.
160 BEGIN { $diagnostics::PRETTY = 1 }
162 I could start up faster by delaying compilation until it should be
163 needed, but this gets a "panic: top_level"
164 when using the pragma form in 5.001e.
166 While it's true that this documentation is somewhat subserious, if you use
167 a program named I<splain>, you should expect a bit of whimsy.
171 Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995.
176 my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
178 $OUTPUT_AUTOFLUSH = 1;
183 $opt_p = $opt_d = $opt_v = $opt_f = '';
184 %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();
185 %exact_duplicate = ();
190 Getopt::Std::getopts('pdvf:') || die "Usage: $0 [-v] [-p] [-f splainpod]";
191 $PODFILE = $opt_f if $opt_f;
192 $DEBUG = 2 if $opt_d;
197 if (open(POD_DIAG, $PODFILE)) {
198 warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
204 for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
205 warn "Checking $file\n" if $DEBUG;
206 if (open(POD_DIAG, $file)) {
208 next unless /^__END__\s*# wish diag dbase were more accessible/;
209 print STDERR "podfile is $file\n" if $DEBUG;
216 print STDERR "podfile is <DATA>\n" if $DEBUG;
217 *POD_DIAG = *main::DATA;
221 die "couldn't find diagnostic data in $PODFILE @INC $0";
226 'amp' => '&', # ampersand
227 'lt' => '<', # left chevron, less-than
228 'gt' => '>', # right chevron, greater-than
229 'quot' => '"', # double quote
231 "Aacute" => "A\\*'", # capital A, acute accent
237 'amp' => '&', # ampersand
238 'lt' => '<', # left chevron, less-than
239 'gt' => '>', # right chevron, greater-than
240 'quot' => '"', # double quote
242 "Aacute" => "\xC1" # capital A, acute accent
248 'amp' => '&', # ampersand
249 'lt' => '<', # left chevron, less-than
250 'gt' => '>', # right chevron, greater-than
251 'quot' => '"', # double quote
253 "Aacute" => "A" # capital A, acute accent
259 $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
265 *THITHER = $standalone ? *STDOUT : *STDERR;
269 local \$^W = 0; # recursive warnings we do NOT need!
273 ### sub finish_compilation { # 5.001e panic: top_level for embedded version
274 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
284 sub noop { return $_[0] } # spensive for a noop
285 sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
286 sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
287 s/[BC]<(.*?)>/bold($1)/ges;
288 s/[LIF]<(.*?)>/italic($1)/ges;
291 s/[LIF]<(.*?)>/$1/gs;
294 if (defined $header) {
295 if ( $header eq 'DESCRIPTION' &&
296 ( /Optional warnings are enabled/
297 || /Some of these messages are generic./
307 unless ( s/=item (.*)\s*\Z//) {
309 if ( s/=head1\sDESCRIPTION//) {
310 $msg{$header = 'DESCRIPTION'} = '';
316 if ($header =~ /%[sd]/) {
317 $rhs = $lhs = $header;
318 #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) {
319 if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) {
320 $lhs =~ s/\\%s/.*?/g;
322 # if i had lookbehind negations, i wouldn't have to do this \377 noise
323 $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
324 #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
325 $lhs =~ s/\377([^\377]*)$/\Q$1\E/;
328 $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n";
330 $transmo .= " m{^\Q$header\E} && return 1;\n";
333 print STDERR "Already saw $header" if $msg{$header};
339 close POD_DIAG unless *main::DATA eq *POD_DIAG;
341 die "No diagnostics?" unless %msg;
343 $transmo .= " return 0;\n}\n";
344 print STDERR $transmo if $DEBUG;
351 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
352 while ($error = <>) {
353 splainthis($error) || print THITHER $error;
357 $old_w = 0; $oldwarn = ''; $olddie = '';
363 $^W = 1; # yup, clobbered the global variable; tough, if you
364 # want diags, you want diags.
365 return if $SIG{__WARN__} eq \&warn_trap;
369 /^-d(ebug)?$/ && do {
374 /^-v(erbose)?$/ && do {
379 /^-p(retty)?$/ && do {
380 print STDERR "$0: I'm afraid it's too late for prettiness.\n";
385 warn "Unknown flag: $_";
388 $oldwarn = $SIG{__WARN__};
389 $olddie = $SIG{__DIE__};
390 $SIG{__WARN__} = \&warn_trap;
391 $SIG{__DIE__} = \&death_trap;
394 sub enable { &import }
399 return unless $SIG{__WARN__} eq \&warn_trap;
400 $SIG{__WARN__} = $oldwarn;
401 $SIG{__DIE__} = $olddie;
406 if (caller eq $WHOAMI or !splainthis($warning)) {
407 print STDERR $warning;
409 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
413 my $exception = $_[0];
414 splainthis($exception);
415 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
416 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
417 $SIG{__DIE__} = $SIG{__WARN__} = '';
418 local($Carp::CarpLevel) = 1;
419 confess "Uncaught exception from user code:\n\t$exception";
420 # up we go; where we stop, nobody knows, but i think we die now
421 # but i'm deeply afraid of the &$olddie guy reraising and us getting
422 # into an indirect recursion loop
427 ### &finish_compilation unless %msg;
430 # return unless defined;
431 if ($exact_duplicate{$_}++) {
434 s/, <.*?> (?:line|chunk).*$//;
435 $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
437 return 0 unless &transmo;
438 $orig = shorten($orig);
441 print THITHER "$orig (#$old_diag{$_})\n";
445 $old_diag{$_} = ++$count;
446 print THITHER "\n" if $wantspace;
448 print THITHER "$orig (#$old_diag{$_})\n";
450 print THITHER $msg{$_};
452 if (0 and $standalone) {
453 print THITHER " **** Error #$old_diag{$_} ",
454 ($real ? "is" : "appears to be"),
455 " an unknown diagnostic message.\n\n";
464 if ($VERBOSE and not $count) {
465 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
466 "\n$msg{DESCRIPTION}\n";
477 exists $HTML_Escapes{$1}
478 ? do { $HTML_Escapes{$1} }
480 warn "Unknown escape: $& in $_";
489 if (length $line > 79) {
490 my $space_place = rindex($line, ' ', 79);
491 if ($space_place != -1) {
492 substr($line, $space_place, 1) = "\n\t";
499 # have to do this: RS isn't set until run time, but we're executing at compile time
502 1 unless $standalone; # or it'll complain about itself
503 __END__ # wish diag dbase were more accessible