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 with the more
45 explicative and endearing descriptions found in L<perldiag>. Like the
46 other pragmata, it affects the 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 variable can generate nicer
66 escape sequences for pagers.
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 diagnostics::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 "$WHOAMI: Duplicate entry: \"$header\"\n"
344 close POD_DIAG unless *main::DATA eq *POD_DIAG;
346 die "No diagnostics?" unless %msg;
348 $transmo .= " return 0;\n}\n";
349 print STDERR $transmo if $DEBUG;
356 if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
357 while ($error = <>) {
358 splainthis($error) || print THITHER $error;
362 $old_w = 0; $oldwarn = ''; $olddie = '';
368 $^W = 1; # yup, clobbered the global variable; tough, if you
369 # want diags, you want diags.
370 return if $SIG{__WARN__} eq \&warn_trap;
374 /^-d(ebug)?$/ && do {
379 /^-v(erbose)?$/ && do {
384 /^-p(retty)?$/ && do {
385 print STDERR "$0: I'm afraid it's too late for prettiness.\n";
390 warn "Unknown flag: $_";
393 $oldwarn = $SIG{__WARN__};
394 $olddie = $SIG{__DIE__};
395 $SIG{__WARN__} = \&warn_trap;
396 $SIG{__DIE__} = \&death_trap;
399 sub enable { &import }
404 return unless $SIG{__WARN__} eq \&warn_trap;
405 $SIG{__WARN__} = $oldwarn;
406 $SIG{__DIE__} = $olddie;
411 if (caller eq $WHOAMI or !splainthis($warning)) {
412 print STDERR $warning;
414 &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
418 my $exception = $_[0];
420 # See if we are coming from anywhere within an eval. If so we don't
421 # want to explain the exception because it's going to get caught.
425 my $caller = (caller($i++))[3] or last;
426 if ($caller eq '(eval)') {
432 splainthis($exception) unless $in_eval;
433 if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
434 &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
436 # We don't want to unset these if we're coming from an eval because
437 # then we've turned off diagnostics. (Actually what does this next
439 $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
440 local($Carp::CarpLevel) = 1;
441 confess "Uncaught exception from user code:\n\t$exception";
442 # up we go; where we stop, nobody knows, but i think we die now
443 # but i'm deeply afraid of the &$olddie guy reraising and us getting
444 # into an indirect recursion loop
449 ### &finish_compilation unless %msg;
452 # return unless defined;
453 if ($exact_duplicate{$_}++) {
456 s/, <.*?> (?:line|chunk).*$//;
457 $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
459 return 0 unless &transmo;
460 $orig = shorten($orig);
463 print THITHER "$orig (#$old_diag{$_})\n";
467 $old_diag{$_} = ++$count;
468 print THITHER "\n" if $wantspace;
470 print THITHER "$orig (#$old_diag{$_})\n";
472 print THITHER $msg{$_};
474 if (0 and $standalone) {
475 print THITHER " **** Error #$old_diag{$_} ",
476 ($real ? "is" : "appears to be"),
477 " an unknown diagnostic message.\n\n";
486 if ($VERBOSE and not $count) {
487 print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
488 "\n$msg{DESCRIPTION}\n";
499 exists $HTML_Escapes{$1}
500 ? do { $HTML_Escapes{$1} }
502 warn "Unknown escape: $& in $_";
511 if (length $line > 79) {
512 my $space_place = rindex($line, ' ', 79);
513 if ($space_place != -1) {
514 substr($line, $space_place, 1) = "\n\t";
521 # have to do this: RS isn't set until run time, but we're executing at compile time
524 1 unless $standalone; # or it'll complain about itself
525 __END__ # wish diag dbase were more accessible