pack changes and related fixes

Message-ID: <75A46BF1A9D8D311863A00508B6259A405F17EB8@ATTMSX4>

p4raw-id: //depot/perl@19010

1 files changed, 59 insertions, 21 deletions

diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
index 1ba70c5b6c..466b9e9efd 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
@@ -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();