=head1 NAME
-diagnostics - Perl compiler pragma to force verbose warning diagnostics
-
-splain - filter to produce verbose descriptions of perl warning diagnostics
+diagnostics, splain - produce verbose warning diagnostics
=head1 SYNOPSIS
-As a pragma:
+Using the C<diagnostics> pragma:
use diagnostics;
use diagnostics -verbose;
enable diagnostics;
disable diagnostics;
-As a program:
+Using the C<splain> standalone filter program:
perl program 2>diag.out
splain [-v] [-p] diag.out
+Using diagnostics to get stack traces from a misbehaving script:
+
+ perl -Mdiagnostics=-traceonly my_script.pl
=head1 DESCRIPTION
=head2 The C<diagnostics> Pragma
This module extends the terse diagnostics normally emitted by both the
-perl compiler and the perl interpreter, augmenting them with the more
+perl compiler and the perl interpreter (from running perl with a -w
+switch or C<use warnings>), augmenting them with the more
explicative and endearing descriptions found in L<perldiag>. Like the
other pragmata, it affects the compilation phase of your program rather
than merely the execution phase.
descriptions). User code generated warnings a la warn() are unaffected,
allowing duplicate user messages to be displayed.
+This module also adds a stack trace to the error message when perl dies.
+This is useful for pinpointing what caused the death. The B<-traceonly> (or
+just B<-t>) flag turns off the explanations of warning messages leaving just
+the stack traces. So if your script is dieing, run it again with
+
+ perl -Mdiagnostics=-traceonly my_bad_script
+
+to see the call stack at the time of death. By supplying the B<-warntrace>
+(or just B<-w>) flag, any warnings emitted will also come with a stack
+trace.
+
=head2 The I<splain> Program
While apparently a whole nuther program, I<splain> is actually nothing
=cut
use strict;
-use 5.006;
+use 5.009001;
use Carp;
+$Carp::Internal{__PACKAGE__.""}++;
-our $VERSION = 1.11;
+our $VERSION = '1.22';
our $DEBUG;
our $VERBOSE;
our $PRETTY;
+our $TRACEONLY = 0;
+our $WARNTRACE = 0;
use Config;
my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
-if ($^O eq 'MacOS') {
- # just updir one from each lib dir, we'll find it ...
- ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
-}
-
-
$DEBUG ||= 0;
my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
local $| = 1;
-local $_;
+my $_;
+local $.;
my $standalone;
my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
{
print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
local $/ = '';
- local $_;
my $header;
+ my @headers;
my $for_item;
+ my $seen_body;
while (<POD_DIAG>) {
+ sub _split_pod_link {
+ $_[0] =~ '(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?';
+ ($1,$2,$4);
+ }
+
unescape();
if ($PRETTY) {
sub noop { return $_[0] } # spensive for a noop
sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
- s/[BC]<(.*?)>/bold($1)/ges;
- s/[LIF]<(.*?)>/italic($1)/ges;
+ s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
+ s/[IF]<(.*?)>/italic($1)/ges;
+ s/L<(.*?)>/
+ my($text,$page,$sect) = _split_pod_link($1);
+ defined $text
+ ? $text
+ : defined $sect
+ ? italic($sect) . ' in ' . italic($page)
+ : italic($page)
+ /ges;
} else {
- s/[BC]<(.*?)>/$1/gs;
- s/[LIF]<(.*?)>/$1/gs;
+ s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
+ s/[IF]<(.*?)>/$1/gs;
+ s/L<(.*?)>/
+ my($text,$page,$sect) = _split_pod_link($1);
+ defined $text
+ ? $text
+ : defined $sect
+ ? qq '"$sect" in $page'
+ : $page
+ /ges;
}
unless (/^=/) {
if (defined $header) {
}
s/^/ /gm;
$msg{$header} .= $_;
+ for my $h(@headers) { $msg{$h} .= $_ }
+ ++$seen_body;
undef $for_item;
}
next;
}
+
+ # If we have not come across the body of the description yet, then
+ # the previous header needs to share the same description.
+ if ($seen_body) {
+ @headers = ();
+ }
+ else {
+ push @headers, $header if defined $header;
+ }
+
unless ( s/=item (.*?)\s*\z//) {
if ( s/=head1\sDESCRIPTION//) {
# strip formatting directives from =item line
$header =~ s/[A-Z]<(.*?)>/$1/g;
- my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header );
+ my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?[fs])/, $header );
if (@toks > 1) {
my $conlen = 0;
for my $i (0..$#toks){
$toks[$i] = '.';
} elsif( $toks[$i] eq '%d' ){
$toks[$i] = '\d+';
- } elsif( $toks[$i] eq '%s' ){
+ } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){
$toks[$i] = $i == $#toks ? '.*' : '.*?';
} elsif( $toks[$i] =~ '%.(\d+)s' ){
$toks[$i] = ".{$1}";
$toks[$i] = '[\da-f]+';
}
} elsif( length( $toks[$i] ) ){
- $toks[$i] =~ s/^.*$/\Q$&\E/;
+ $toks[$i] = quotemeta $toks[$i];
$conlen += length( $toks[$i] );
}
}
if $msg{$header};
$msg{$header} = '';
+ $seen_body = 0;
}
$PRETTY++;
next;
};
+ # matches trace and traceonly for legacy doc mixup reasons
+ /^-t(race(only)?)?$/ && do {
+ $TRACEONLY++;
+ next;
+ };
+ /^-w(arntrace)?$/ && do {
+ $WARNTRACE++;
+ next;
+ };
warn "Unknown flag: $_";
}
sub warn_trap {
my $warning = $_[0];
if (caller eq $WHOAMI or !splainthis($warning)) {
- print STDERR $warning;
+ if ($WARNTRACE) {
+ print STDERR Carp::longmess($warning);
+ } else {
+ print STDERR $warning;
+ }
}
- &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
+ goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
};
sub death_trap {
# want to explain the exception because it's going to get caught.
my $in_eval = 0;
my $i = 0;
- while (1) {
- my $caller = (caller($i++))[3] or last;
+ while (my $caller = (caller($i++))[3]) {
if ($caller eq '(eval)') {
$in_eval = 1;
last;
my $count;
my $wantspace;
sub splainthis {
- local $_ = shift;
+ return 0 if $TRACEONLY;
+ $_ = shift;
local $\;
+ local $!;
### &finish_compilation unless %msg;
s/\.?\n+$//;
my $orig = $_;
s/, <.*?> (?:line|chunk).*$//;
# Discard 1st " at <file> line <no>" and all text beyond
- # but be aware of messsages containing " at this-or-that"
+ # but be aware of messages containing " at this-or-that"
my $real = 0;
my @secs = split( / at / );
+ return unless @secs;
$_ = $secs[0];
for my $i ( 1..$#secs ){
if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
https://perl5.git.perl.org / perl5.git / blobdiff