use Carp;
$Carp::Internal{__PACKAGE__.""}++;
-our $VERSION = '1.27';
+our $VERSION = '1.34';
our $DEBUG;
our $VERBOSE;
our $PRETTY;
our $WARNTRACE = 0;
use Config;
-my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
+use Text::Tabs 'expand';
+my $privlib = $Config{privlibexp};
if ($^O eq 'VMS') {
require VMS::Filespec;
$privlib = VMS::Filespec::unixify($privlib);
- $archlib = VMS::Filespec::unixify($archlib);
}
my @trypod = (
- "$archlib/pod/perldiag.pod",
- "$privlib/pod/perldiag-$Config{version}.pod",
"$privlib/pod/perldiag.pod",
- "$archlib/pods/perldiag.pod",
- "$privlib/pods/perldiag-$Config{version}.pod",
"$privlib/pods/perldiag.pod",
);
# handy for development testing of new warnings etc
(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
$DEBUG ||= 0;
-my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
local $| = 1;
-my $_;
+local $_;
local $.;
my $standalone;
if (caller) {
INCPATH: {
- for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
+ for my $file ( (map { "$_/".__PACKAGE__.".pm" } @INC), $0) {
warn "Checking $file\n" if $DEBUG;
if (open(POD_DIAG, $file)) {
while (<POD_DIAG>) {
my $transmo = <<EOFUNC;
sub transmo {
#local \$^W = 0; # recursive warnings we do NOT need!
- study;
EOFUNC
my %msg;
{
print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
local $/ = '';
+ local $_;
my $header;
my @headers;
my $for_item;
while (<POD_DIAG>) {
sub _split_pod_link {
- $_[0] =~ '(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?';
+ $_[0] =~ m'(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?'s;
($1,$2,$4);
}
{
next;
}
+ $_ = expand $_;
s/^/ /gm;
$msg{$header} .= $_;
for my $h(@headers) { $msg{$h} .= $_ }
push @headers, $header if defined $header;
}
- unless ( s/=item (.*?)\s*\z//) {
+ unless ( s/=item (.*?)\s*\z//s) {
if ( s/=head1\sDESCRIPTION//) {
$msg{$header = 'DESCRIPTION'} = '';
}
elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
$for_item = $1;
- }
+ }
+ elsif( /^=back/ ) { # Stop processing body here
+ undef $header;
+ undef $for_item;
+ $seen_body = 0;
+ next;
+ }
next;
}
if( $for_item ) { $header = $for_item; undef $for_item }
else {
$header = $1;
- while( $header =~ /[;,]\z/ ) {
- <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
- $header .= ' '.$1;
- }
+
+ $header =~ s/\n/ /gs; # Allow multi-line headers
}
# strip formatting directives from =item line
$header =~ s/[A-Z]<(.*?)>/$1/g;
- # Since we strip "\.\n" when we search a warning, strip it here as well
- $header =~ s/\.?$//;
+ # Since we strip "(\.\s*)\n" when we search a warning, strip it here as well
+ $header =~ s/(\.\s*)?$//;
- my @toks = split( /(%l?[dxX]|%u|%c|%(?:\.\d+)?[fs])/, $header );
+ my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header );
if (@toks > 1) {
my $conlen = 0;
for my $i (0..$#toks){
$toks[$i] = $i == $#toks ? '.*' : '.*?';
} elsif( $toks[$i] =~ '%.(\d+)s' ){
$toks[$i] = ".{$1}";
- } elsif( $toks[$i] =~ '^%l*([xX])$' ){
- $toks[$i] = $1 eq 'x' ? '[\da-f]+' : '[\dA-F]+';
+ } elsif( $toks[$i] =~ '^%l*([pxX])$' ){
+ $toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+';
}
} elsif( length( $toks[$i] ) ){
$toks[$i] = quotemeta $toks[$i];
}
}
my $lhs = join( '', @toks );
+ $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
$transfmt{$header}{pat} =
- " s{^$lhs}\n {\Q$header\E}s\n\t&& return 1;\n";
+ " s\a^\\s*$lhs\\s*\a\Q$header\E\as\n\t&& return 1;\n";
$transfmt{$header}{len} = $conlen;
} else {
+ my $lhs = "\Q$header\E";
+ $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match
$transfmt{$header}{pat} =
- " m{^\Q$header\E} && return 1;\n";
+ " s\a^\\s*$lhs\\s*\a\Q$header\E\a\n\t && return 1;\n";
$transfmt{$header}{len} = length( $header );
}
- print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
+ print STDERR __PACKAGE__.": Duplicate entry: \"$header\"\n"
if $msg{$header};
$msg{$header} = '';
sub warn_trap {
my $warning = $_[0];
- if (caller eq $WHOAMI or !splainthis($warning)) {
+ if (caller eq __PACKAGE__ or !splainthis($warning)) {
if ($WARNTRACE) {
print STDERR Carp::longmess($warning);
} else {
}
splainthis($exception) unless $in_eval;
- if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
+ if (caller eq __PACKAGE__) {
+ print STDERR "INTERNAL EXCEPTION: $exception";
+ }
&$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
return if $in_eval;
# traps.
$SIG{__DIE__} = $SIG{__WARN__} = '';
- # Have carp skip over death_trap() when showing the stack trace.
- local($Carp::CarpLevel) = 1;
+ $exception =~ s/\n(?=.)/\n\t/gas;
- confess "Uncaught exception from user code:\n\t$exception";
+ die Carp::longmess("__diagnostics__")
+ =~ s/^__diagnostics__.*?line \d+\.?\n/
+ "Uncaught exception from user code:\n\t$exception"
+ /re;
# up we go; where we stop, nobody knows, but i think we die now
# but i'm deeply afraid of the &$olddie guy reraising and us getting
# into an indirect recursion loop
my $count;
my $wantspace;
sub splainthis {
- return 0 if $TRACEONLY;
- $_ = shift;
+ return 0 if $TRACEONLY;
+ for (my $tmp = shift) {
local $\;
local $!;
### &finish_compilation unless %msg;
- s/\.?\n+$//;
+ s/(\.\s*)?\n+$//;
my $orig = $_;
# return unless defined;
$_ .= ' at ' . $secs[$i];
}
}
-
+
# remove parenthesis occurring at the end of some messages
s/^\((.*)\)$/$1/;
return 0 unless &transmo;
}
- $orig = shorten($orig);
+ my $short = shorten($orig);
if ($old_diag{$_}) {
autodescribe();
- print THITHER "$orig (#$old_diag{$_})\n";
+ print THITHER "$short (#$old_diag{$_})\n";
$wantspace = 1;
+ } elsif (!$msg{$_} && $orig =~ /\n./s) {
+ # A multiline message, like "Attempt to reload /
+ # Compilation failed"
+ my $found;
+ for (split /^/, $orig) {
+ splainthis($_) and $found = 1;
+ }
+ return $found;
} else {
autodescribe();
$old_diag{$_} = ++$count;
print THITHER "\n" if $wantspace;
$wantspace = 0;
- print THITHER "$orig (#$old_diag{$_})\n";
+ print THITHER "$short (#$old_diag{$_})\n";
if ($msg{$_}) {
print THITHER $msg{$_};
} else {
}
}
return 1;
+ }
}
sub autodescribe {