Make diagnostics.pm understand messages sharing descriptions

[perl5.git] / lib / utf8_heavy.pl

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index ab31922..4825b0f 100644 (file)
--- a/lib/utf8_heavy.pl
+++ b/lib/utf8_heavy.pl
@@ -32,7 +32,9 @@ sub croak { require Carp; Carp::croak(@_) }
         local $^D = 0 if $^D;
 
         $class = "" unless defined $class;
-        print STDERR __LINE__, ": class=$class, type=$type, list=$list, minbits=$minbits, none=$none\n" if DEBUG;
+        print STDERR __LINE__, ": class=$class, type=$type, list=",
+                                (defined $list) ? $list : ':undef:',
+                                ", minbits=$minbits, none=$none\n" if DEBUG;
 
         ##
         ## Get the list of codepoints for the type.
@@ -89,7 +91,11 @@ sub croak { require Carp; Carp::croak(@_) }
             $type =~ s/^\s+//;
             $type =~ s/\s+$//;
 
-            print STDERR __LINE__, ": type = $type\n" if DEBUG;
+            # regcomp.c surrounds the property name with '__" and '_i' if this
+            # is to be caseless matching.
+            my $caseless = $type =~ s/^__(.*)_i$/$1/;
+
+            print STDERR __LINE__, ": type=$type, caseless=$caseless\n" if DEBUG;
 
         GETFILE:
             {
@@ -100,12 +106,12 @@ sub croak { require Carp; Carp::croak(@_) }
 
                 my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
 
-                if (defined $caller1 && $type =~ /^(?:\w+)$/) {
+                if (defined $caller1 && $type =~ /^I[ns]\w+$/) {
                     my $prop = "${caller1}::$type";
                     if (exists &{$prop}) {
                         no strict 'refs';
                         
-                        $list = &{$prop};
+                        $list = &{$prop}($caseless);
                         last GETFILE;
                     }
                 }
@@ -130,7 +136,7 @@ sub croak { require Carp; Carp::croak(@_) }
                 }
                 BEGIN { delete $utf8::{miniperl} }
 
-                # Everything is caseless matching
+                # All property names are matched caselessly
                 my $property_and_table = lc $type;
                 print STDERR __LINE__, ": $property_and_table\n" if DEBUG;
 
@@ -359,6 +365,12 @@ sub croak { require Carp; Carp::croak(@_) }
                     if ($utf8::why_deprecated{$file}) {
                         warnings::warnif('deprecated', "Use of '$type' in \\p{} or \\P{} is deprecated because: $utf8::why_deprecated{$file};");
                     }
+
+                    if ($caseless
+                        && exists $utf8::caseless_equivalent{$property_and_table})
+                    {
+                        $file = $utf8::caseless_equivalent{$property_and_table};
+                    }
                     $file= "$unicore_dir/lib/$file.pl";
                     last GETFILE;
                 }
@@ -430,7 +442,6 @@ sub croak { require Carp; Carp::croak(@_) }
         my $extras;
         my $bits = $minbits;
 
-        my $ORIG = $list;
         if ($list) {
             my @tmp = split(/^/m, $list);
             my %seen;