Increase $DBM_Filter::VERSION to 0.06

[perl5.git] / lib / diagnostics.pm

diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
index 6c166a3..6ccc3d0 100644 (file)
--- a/lib/diagnostics.pm
+++ b/lib/diagnostics.pm
@@ -186,7 +186,7 @@ use 5.009001;
 use Carp;
 $Carp::Internal{__PACKAGE__.""}++;
 
-our $VERSION = '1.27';
+our $VERSION = '1.31';
 our $DEBUG;
 our $VERBOSE;
 our $PRETTY;
@@ -194,18 +194,13 @@ our $TRACEONLY = 0;
 our $WARNTRACE = 0;
 
 use Config;
-my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
+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
@@ -216,7 +211,7 @@ $DEBUG ||= 0;
 my $WHOAMI = ref bless [];  # nobody's business, prolly not even mine
 
 local $| = 1;
-my $_;
+local $_;
 local $.;
 
 my $standalone;
@@ -312,13 +307,13 @@ my %transfmt = ();
 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;
@@ -390,7 +385,7 @@ my %msg;
            push @headers, $header if defined $header;
        }
 
-       unless ( s/=item (.*?)\s*\z//) {
+       unless ( s/=item (.*?)\s*\z//s) {
 
            if ( s/=head1\sDESCRIPTION//) {
                $msg{$header = 'DESCRIPTION'} = '';
@@ -405,19 +400,17 @@ my %msg;
        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){
@@ -430,8 +423,8 @@ my %msg;
                         $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];
@@ -439,12 +432,15 @@ my %msg;
                 }
             }  
             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 );
        } 
 
@@ -573,8 +569,7 @@ sub death_trap {
     # 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;
 
     die Carp::longmess("__diagnostics__")
          =~ s/^__diagnostics__.*?line \d+\.?\n/
@@ -590,12 +585,12 @@ my %old_diag;
 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;
 
@@ -616,7 +611,7 @@ sub splainthis {
             $_ .= ' at ' . $secs[$i];
        }
     }
-    
+
     # remove parenthesis occurring at the end of some messages 
     s/^\((.*)\)$/$1/;
 
@@ -626,17 +621,25 @@ sub splainthis {
        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 {
@@ -649,6 +652,7 @@ sub splainthis {
        } 
     }
     return 1;
+  }
 } 
 
 sub autodescribe {