correctly handle C<< >> and C<<< >>> in diagnostics

[perl5.git] / lib / diagnostics.pm

diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
index b224943..26ff013 100755 (executable)
--- a/lib/diagnostics.pm
+++ b/lib/diagnostics.pm
@@ -2,13 +2,11 @@ package diagnostics;
 
 =head1 NAME
 
-diagnostics - Perl compiler pragma to force verbose warning diagnostics
-
-splain - standalone program to do the same thing
+diagnostics, splain - produce verbose warning diagnostics
 
 =head1 SYNOPSIS
 
-As a pragma:
+Using the C<diagnostics> pragma:
 
     use diagnostics;
     use diagnostics -verbose;
@@ -16,12 +14,11 @@ As a pragma:
     enable  diagnostics;
     disable diagnostics;
 
-Aa a program:
+Using the C<splain> standalone filter program:
 
     perl program 2>diag.out
     splain [-v] [-p] diag.out
 
-
 =head1 DESCRIPTION
 
 =head2 The C<diagnostics> Pragma
@@ -53,7 +50,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
@@ -168,10 +165,10 @@ Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
 =cut
 
 use strict;
-use 5.6.0;
+use 5.006;
 use Carp;
 
-our $VERSION = 1.0;
+our $VERSION = 1.12;
 our $DEBUG;
 our $VERBOSE;
 our $PRETTY;
@@ -296,6 +293,7 @@ our %HTML_Escapes;
 
 *THITHER = $standalone ? *STDOUT : *STDERR;
 
+my %transfmt = (); 
 my $transmo = <<EOFUNC;
 sub transmo {
     #local \$^W = 0;  # recursive warnings we do NOT need!
@@ -316,10 +314,10 @@ my %msg;
            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/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
            s/[LIF]<(.*?)>/italic($1)/ges;
        } else {
-           s/[BC]<(.*?)>/$1/gs;
+           s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
            s/[LIF]<(.*?)>/$1/gs;
        } 
        unless (/^=/) {
@@ -330,7 +328,7 @@ my %msg;
                    ) )
                {
                    next;
-               } 
+               }
                s/^/    /gm;
                $msg{$header} .= $_;
                undef $for_item;        
@@ -358,25 +356,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 +401,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;
@@ -411,7 +428,7 @@ sub import {
     shift;
     $^W = 1; # yup, clobbered the global variable; 
             # tough, if you want diags, you want diags.
-    return if $SIG{__WARN__} eq \&warn_trap;
+    return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
 
     for (@_) {
 
@@ -505,15 +522,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();