2 eval 'exec perl -S $0 ${1+"$@"}'
7 $diagnostics::PODFILE = VMS::Filespec::unixify($Config{'privlibexp'}) .
10 else { $diagnostics::PODFILE= $Config{privlibexp} . "/pod/perldiag.pod"; }
19 diagnostics - Perl compiler pragma to force verbose warning diagnostics
21 splain - standalone program to do the same thing
28 use diagnostics -verbose;
35 perl program 2>diag.out
36 splain [-v] [-p] diag.out
41 =head2 The C<diagnostics> Pragma
43 This module extends the terse diagnostics normally emitted by both the
44 perl compiler and the perl interpeter, augmenting them wtih the more
45 explicative and endearing descriptions found in L<perldiag>. Like the
46 other pragmata, it affects to compilation phase of your program rather
47 than merely the execution phase.
49 To use in your program as a pragma, merely invoke
53 at the start (or near the start) of your program. (Note
54 that this I<does> enable perl's B<-w> flag.) Your whole
55 compilation will then be subject(ed :-) to the enhanced diagnostics.
56 These still go out B<STDERR>.
58 Due to the interaction between runtime and compiletime issues,
59 and because it's probably not a very good idea anyway,
60 you may not use C<no diagnostics> to turn them off at compiletime.
61 However, you may control there behaviour at runtime using the
62 disable() and enable() methods to turn them off and on respectively.
64 The B<-verbose> flag first prints out the L<perldiag> introduction before
65 any other diagnostics. The $diagnostics::PRETTY can generate nicer escape
68 =head2 The I<splain> Program
70 While apparently a whole nuther program, I<splain> is actually nothing
71 more than a link to the (executable) F<diagnostics.pm> module, as well as
72 a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
73 the C<use diagnostics -verbose> directive.
74 The B<-p> flag is like the
75 $diagnostics::PRETTY variable. Since you're post-processing with
76 I<splain>, there's no sense in being able to enable() or disable() processing.
78 Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
82 The following file is certain to trigger a few errors at both
83 runtime and compiletime:
86 print NOWHERE "nothing\n";
87 print STDERR "\n\tThis message should be unadorned.\n";
88 warn "\tThis is a user warning";
89 print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
90 my $a, $b = scalar <STDIN>;
94 If you prefer to run your program first and look at its problem
97 perl -w test.pl 2>test.out
100 Note that this is not in general possible in shells of more dubious heritage,
103 (perl -w test.pl >/dev/tty) >& test.out
106 Because you just moved the existing B<stdout> to somewhere else.
108 If you don't want to modify your source code, but still have on-the-fly
111 exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
115 If you want to control warnings on the fly, do something like this.
116 Make sure you do the C<use> first, or you won't be able to get
117 at the enable() or disable() methods.
119 use diagnostics; # checks entire compilation phase
120 print "\ntime for 1st bogus diags: SQUAWKINGS\n";
122 print "done with 1st bogus\n";
124 disable diagnostics; # only turns off runtime warnings
125 print "\ntime for 2nd bogus: (squelched)\n";
127 print "done with 2nd bogus\n";
129 enable diagnostics; # turns back on runtime warnings
130 print "\ntime for 3rd bogus: SQUAWKINGS\n";
132 print "done with 3rd bogus\n";
135 print "\ntime for 4th bogus: (squelched)\n";
137 print "done with 4th bogus\n";
141 Diagnostic messages derive from the F<perldiag.pod> file when available at
142 runtime. Otherwise, they may be embedded in the file itself when the
143 splain package is built. See the F<Makefile> for details.
145 If an extant $SIG{__WARN__} handler is discovered, it will continue
146 to be honored, but only after the diagnostic::splainthis() function
147 (the module's $SIG{__WARN__} interceptor) has had its way with your
150 There is a $diagnostics::DEBUG variable you may set if you're desperately
151 curious what sorts of things are being intercepted.
153 BEGIN { $diagnostics::DEBUG = 1 }
158 Not being able to say "no diagnostics" is annoying, but may not be
161 The C<-pretty> directive is called too late to affect matters.
162 You have to to this instead, and I<before> you load the module.
164 BEGIN { $diagnostics::PRETTY = 1 }
166 I could start up faster by delaying compilation until it should be
167 needed, but this gets a "panic: top_level"
168 when using the pragma form in 5.001e.
170 While it's true that this documentation is somewhat subserious, if you use
171 a program named I<splain>, you should expect a bit of whimsy.
175 Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995.
180 my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
182 $OUTPUT_AUTOFLUSH = 1;
187 $opt_p = $opt_d = $opt_v = $opt_f = '';
188 %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();
189 %exact_duplicate = ();
194 Getopt::Std::getopts('pdvf:') || die "Usage: $0 [-v] [-p] [-f splainpod]";
195 $PODFILE = $opt_f if $opt_f;
196 $DEBUG = 2 if $opt_d;
201 if (open(POD_DIAG, $PODFILE)) {
202 warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
208 for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
209 warn "Checking $file\n" if $DEBUG;
210 if (open(POD_DIAG, $file)) {
212 next unless /^__END__\s*# wish diag dbase were more accessible/;
213 print STDERR "podfile is $file\n" if $DEBUG;
220 print STDERR "podfile is <DATA>\n" if $DEBUG;
221 *POD_DIAG = *main::DATA;
225 die "couldn't find diagnostic data in $PODFILE @INC $0";
230 'amp' => '&', # ampersand
231 'lt' => '<', # left chevron, less-than
232 'gt' => '>', # right chevron, greater-than
233 'quot' => '"', # double quote
235 "Aacute" => "A\\*'", # capital A, acute accent
241 'amp' => '&', # ampersand
242 'lt' => '<', # left chevron, less-than
243 'gt' => '>', # right chevron, greater-than
244 'quot' => '"', # double quote
246 "Aacute" => "\xC1" # capital A, acute accent
252 'amp' => '&', # ampersand
253 'lt' => '<', # left chevron, less-than
254 'gt' => '>', # right chevron, greater-than
255 'quot' => '"', # double quote
257 "Aacute" => "A" # capital A, acute accent
263 $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
269 *THITHER = $standalone ? *STDOUT : *STDERR;
273 local \$^W = 0; # recursive warnings we do NOT need!
277 ### sub finish_compilation { # 5.001e panic: top_level for embedded version
278 print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
288 sub noop { return $_[0] } # spensive for a noop
289 sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
290 sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
291 s/[BC]<(.*?)>/bold($1)/ges;
292 s/[LIF]<(.*?)>/italic($1)/ges;
295 s/[LIF]<(.*?)>/$1/gs;
298 if (defined $header) {
299 if ( $header eq 'DESCRIPTION' &&
300 ( /Optional warnings are enabled/
301 || /Some of these messages are generic./
311 unless ( s/=item (.*)\s*\Z//) {
313 if ( s/=head1\sDESCRIPTION//) {
314 $msg{$header = 'DESCRIPTION'} = '';
320 if ($header =~ /%[sd]/) {
321 $rhs = $lhs = $header;
322 #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) {
323 if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) {
324 $lhs =~ s/\\%s/.*?/g;
326 # if i had lookbehind negations, i wouldn't have to do this \377 noise
327 $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
328 #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
329 $lhs =~ s/\377([^\377]*)$/\Q$1\E/;
332 $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n";
334 $transmo .= " m{^\Q$header\E} && return 1;\n";
337 print STDERR "Already saw $header" if $msg{$header};
343 close POD_DIAG unless *main::DATA eq *POD_DIAG;
345 die "No diagnostics?" unless %msg;
347 $transmo .= " return 0;\n}\n";
348 print STDERR $transmo if $DEBUG;
355 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
356 while ($error = <>) {
357 splainthis($error) || print THITHER $error;
361 $old_w = 0; $oldwarn = ''; $olddie = '';
367 $^W = 1; # yup, clobbered the global variable; tough, if you
368 # want diags, you want diags.
369 return if $SIG{__WARN__} eq \&warn_trap;
373 /^-d(ebug)?$/ && do {
378 /^-v(erbose)?$/ && do {
383 /^-p(retty)?$/ && do {
384 print STDERR "$0: I'm afraid it's too late for prettiness.\n";
389 warn "Unknown flag: $_";
392 $oldwarn = $SIG{__WARN__};
393 $olddie = $SIG{__DIE__};
394 $SIG{__WARN__} = \&warn_trap;
395 $SIG{__DIE__} = \&death_trap;
398 sub enable { &import }
403 return unless $SIG{__WARN__} eq \&warn_trap;
404 $SIG{__WARN__} = $oldwarn;
405 $SIG{__DIE__} = $olddie;
410 if (caller eq $WHOAMI or !splainthis($warning)) {
411 print STDERR $warning;
413 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
417 my $exception = $_[0];
418 splainthis($exception);
419 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
420 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
421 $SIG{__DIE__} = $SIG{__WARN__} = '';
422 local($Carp::CarpLevel) = 1;
423 confess "Uncaught exception from user code:\n\t$exception";
424 # up we go; where we stop, nobody knows, but i think we die now
425 # but i'm deeply afraid of the &$olddie guy reraising and us getting
426 # into an indirect recursion loop
431 ### &finish_compilation unless %msg;
434 # return unless defined;
435 if ($exact_duplicate{$_}++) {
438 s/, <.*?> (?:line|chunk).*$//;
439 $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
441 return 0 unless &transmo;
442 $orig = shorten($orig);
445 print THITHER "$orig (#$old_diag{$_})\n";
449 $old_diag{$_} = ++$count;
450 print THITHER "\n" if $wantspace;
452 print THITHER "$orig (#$old_diag{$_})\n";
454 print THITHER $msg{$_};
456 if (0 and $standalone) {
457 print THITHER " **** Error #$old_diag{$_} ",
458 ($real ? "is" : "appears to be"),
459 " an unknown diagnostic message.\n\n";
468 if ($VERBOSE and not $count) {
469 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
470 "\n$msg{DESCRIPTION}\n";
481 exists $HTML_Escapes{$1}
482 ? do { $HTML_Escapes{$1} }
484 warn "Unknown escape: $& in $_";
493 if (length $line > 79) {
494 my $space_place = rindex($line, ' ', 79);
495 if ($space_place != -1) {
496 substr($line, $space_place, 1) = "\n\t";
503 # have to do this: RS isn't set until run time, but we're executing at compile time
506 1 unless $standalone; # or it'll complain about itself
507 __END__ # wish diag dbase were more accessible