add tests for overridden Class::Struct accessors

[perl5.git] / lib / utf8_heavy.pl

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index e63999f..23e06f9 100644 (file)
--- a/lib/utf8_heavy.pl
+++ b/lib/utf8_heavy.pl
@@ -120,7 +120,7 @@ sub _loose_name ($) {
 
             # regcomp.c surrounds the property name with '__" and '_i' if this
             # is to be caseless matching.
-            my $caseless = $type =~ s/^__(.*)_i$/$1/;
+            my $caseless = $type =~ s/^(.*)__(.*)_i$/$1$2/;
 
             print STDERR __LINE__, ": type=$type, caseless=$caseless\n" if DEBUG;
 
@@ -131,7 +131,10 @@ sub _loose_name ($) {
                 ## package if no package given
                 ##
 
-                my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
+
+                my $caller0 = caller(0);
+                my $caller1 = $type =~ s/(.+)::// ? $1 : $caller0 eq 'main' ?
+                'main' : caller(1);
 
                 if (defined $caller1 && $type =~ /^I[ns]\w+$/) {
                     my $prop = "${caller1}::$type";
@@ -402,8 +405,9 @@ sub _loose_name ($) {
                 # Add the constant and go fetch it in.
                 if (defined $file) {
 
-                    # A beginning ! means to invert
-                    $invert_it = $file =~ s/^!//;
+                    # A beginning ! means to invert.  The 0+ makes sure is
+                    # numeric
+                    $invert_it = 0 + $file =~ s/^!//;
 
                     if ($utf8::why_deprecated{$file}) {
                         warnings::warnif('deprecated', "Use of '$type' in \\p{} or \\P{} is deprecated because: $utf8::why_deprecated{$file};");
@@ -475,7 +479,8 @@ sub _loose_name ($) {
                         # get it.
                         $minbits = 1;
 
-                        $invert_it = $file =~ s/^!//;
+                        # The 0+ makes sure is numeric
+                        $invert_it = 0 + $file =~ s/^!//;
                         $file = "$unicore_dir/lib/$file.pl";
                         last GETFILE;
                     }
@@ -498,13 +503,13 @@ sub _loose_name ($) {
                 ## (exception: user-defined properties and mappings), so we
                 ## have a filename, so now we load it if we haven't already.
                 ## If we have, return the cached results. The cache key is the
-                ## class and file to load.
+                ## class and file to load, and whether the results need to be
+                ## inverted.
                 ##
-                my $found = $Cache{$class, $file};
+                my $found = $Cache{$class, $file, $invert_it};
                 if ($found and ref($found) eq $class) {
-                    print STDERR __LINE__, ": Returning cached '$file' for \\p{$type}; invert_it=$invert_it\n" if DEBUG;
+                    print STDERR __LINE__, ": Returning cached swash for '$class,$file,$invert_it' for \\p{$type}\n" if DEBUG;
                     pop @recursed if @recursed;
-                    $found->{'INVERT_IT'} = $invert_it;
                     return $found;
                 }
 
@@ -528,10 +533,10 @@ sub _loose_name ($) {
         if ($list && ! $list_is_from_mktables) {
             my $taint = substr($list,0,0); # maintain taint
 
-            # Separate the extras from the code point list, and for
-            # user-defined properties, make sure the latter are well-behaved
-            # for downstream code.
-            if ($user_defined) {
+            # Separate the extras from the code point list, and make sure
+            # user-defined properties and tr/// are well-behaved for
+            # downstream code.
+            if ($user_defined || $none) {
                 my @tmp = split(/^/m, $list);
                 my %seen;
                 no warnings;
@@ -640,7 +645,7 @@ sub _loose_name ($) {
         } => $class;
 
         if ($file) {
-            $Cache{$class, $file} = $SWASH;
+            $Cache{$class, $file, $invert_it} = $SWASH;
             if ($type
                 && exists $utf8::SwashInfo{$type}
                 && exists $utf8::SwashInfo{$type}{'specials_name'})
@@ -659,6 +664,6 @@ sub _loose_name ($) {
     }
 }
 
-# Now SWASHGET is recasted into a C function S_swash_get (see utf8.c).
+# Now SWASHGET is recasted into a C function S_swatch_get (see utf8.c).
 
 1;