X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fdiagnostics.pm;h=0d1a7e2e6ef75e627ad006591324a60e3bb9db54;hb=cc83745da206d409d7227df077f422fd9ecbe680;hp=1ba70c5b6c4502011209f01bcf40bb11ae2d3f79;hpb=327219e7a302d8d18bdc29ddf82363d52e194d49;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
index 1ba70c5..0d1a7e2 100755
--- a/lib/diagnostics.pm
+++ b/lib/diagnostics.pm
@@ -53,7 +53,7 @@ escape sequences for pagers.
 
 Warnings dispatched from perl itself (or more accurately, those that match
 descriptions found in L<perldiag>) are only displayed once (no duplicate
-descriptions).  User code generated warnings ala warn() are unaffected,
+descriptions).  User code generated warnings a la warn() are unaffected,
 allowing duplicate user messages to be displayed.
 
 =head2 The I<splain> Program
@@ -171,7 +171,7 @@ use strict;
 use 5.006;
 use Carp;
 
-our $VERSION = 1.1;
+our $VERSION = 1.11;
 our $DEBUG;
 our $VERBOSE;
 our $PRETTY;
@@ -296,6 +296,7 @@ our %HTML_Escapes;
 
 *THITHER = $standalone ? *STDOUT : *STDERR;
 
+my %transfmt = (); 
 my $transmo = <<EOFUNC;
 sub transmo {
     #local \$^W = 0;  # recursive warnings we do NOT need!
@@ -330,7 +331,7 @@ my %msg;
 		    ) )
 		{
 		    next;
-		} 
+		}
 		s/^/    /gm;
 		$msg{$header} .= $_;
 	 	undef $for_item;	
@@ -358,25 +359,38 @@ my %msg;
 	    }
 	}
 
-	# strip formatting directives in =item line
+	# strip formatting directives from =item line
 	$header =~ s/[A-Z]<(.*?)>/$1/g;
 
-	if ($header =~ /%[csd]/) {
-	    my $rhs = my $lhs = $header;
-	    if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E-?\\d+\Q$2\E/g)  {
-		$lhs =~ s/\\%s/.*?/g;
-	    } else {
-		# if i had lookbehind negations,
-		# i wouldn't have to do this \377 noise
-		$lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
-		$lhs =~ s/\377([^\377]*)$/\Q$1\E/;
-		$lhs =~ s/\377//g;
-		$lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
-	    } 
-	    $lhs =~ s/\\%c/./g;
-	    $transmo .= "    s{^$lhs}\n     {\Q$rhs\E}s\n\t&& return 1;\n";
+        my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header );
+	if (@toks > 1) {
+            my $conlen = 0;
+            for my $i (0..$#toks){
+                if( $i % 2 ){
+                    if(      $toks[$i] eq '%c' ){
+                        $toks[$i] = '.';
+                    } elsif( $toks[$i] eq '%d' ){
+                        $toks[$i] = '\d+';
+                    } elsif( $toks[$i] eq '%s' ){
+                        $toks[$i] = $i == $#toks ? '.*' : '.*?';
+                    } elsif( $toks[$i] =~ '%.(\d+)s' ){
+                        $toks[$i] = ".{$1}";
+                     } elsif( $toks[$i] =~ '^%l*x$' ){
+                        $toks[$i] = '[\da-f]+';
+                   }
+                } elsif( length( $toks[$i] ) ){
+                    $toks[$i] =~ s/^.*$/\Q$&\E/;
+                    $conlen += length( $toks[$i] );
+                }
+            }  
+            my $lhs = join( '', @toks );
+	    $transfmt{$header}{pat} =
+              "    s{^$lhs}\n     {\Q$header\E}s\n\t&& return 1;\n";
+            $transfmt{$header}{len} = $conlen;
 	} else {
-	    $transmo .= "    m{^\Q$header\E} && return 1;\n";
+            $transfmt{$header}{pat} =
+	      "    m{^\Q$header\E} && return 1;\n";
+            $transfmt{$header}{len} = length( $header );
 	} 
 
 	print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
@@ -390,6 +404,12 @@ my %msg;
 
     die "No diagnostics?" unless %msg;
 
+    # Apply patterns in order of decreasing sum of lengths of fixed parts
+    # Seems the best way of hitting the right one.
+    for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
+                  keys %transfmt ){
+        $transmo .= $transfmt{$hdr}{pat};
+    }
     $transmo .= "    return 0;\n}\n";
     print STDERR $transmo if $DEBUG;
     eval $transmo;
@@ -505,15 +525,33 @@ sub splainthis {
     s/\.?\n+$//;
     my $orig = $_;
     # return unless defined;
+
+    # get rid of the where-are-we-in-input part
     s/, <.*?> (?:line|chunk).*$//;
-    my $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
+
+    # Discard 1st " at <file> line <no>" and all text beyond
+    # but be aware of messsages containing " at this-or-that"
+    my $real = 0;
+    my @secs = split( / at / );
+    $_ = $secs[0];
+    for my $i ( 1..$#secs ){
+        if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
+            $real = 1;
+            last;
+        } else {
+            $_ .= ' at ' . $secs[$i];
+	}
+    }
+    
+    # remove parenthesis occurring at the end of some messages 
     s/^\((.*)\)$/$1/;
+
     if ($exact_duplicate{$orig}++) {
 	return &transmo;
-    }
-    else {
+    } else {
 	return 0 unless &transmo;
     }
+
     $orig = shorten($orig);
     if ($old_diag{$_}) {
 	autodescribe();