Upgrade to Cwd 2.17_03

[perl5.git] / lib / utf8_heavy.pl

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index d8c46b5..b6fdeb9 100644 (file)
--- a/lib/utf8_heavy.pl
+++ b/lib/utf8_heavy.pl
@@ -8,6 +8,8 @@ sub DESTROY {}
 
 my %Cache;
 
+our (%PropertyAlias, %PA_reverse, %PropValueAlias, %PVA_reverse, %PVA_abbr_map);
+
 sub croak { require Carp; Carp::croak(@_) }
 
 ##
@@ -45,28 +47,67 @@ sub SWASHNEW {
 
       GETFILE:
         {
-            ##
-            ## 'Is' is always optional, so if it's there, remove it.
-            ## Same with 'Category=' and 'Script='.
-            ##
-            ## 'Block=' is replaced by 'In'.
-            ##
+           ##
+           ## It could be a user-defined property.
+           ##
+
+           my $caller1 = $type =~ s/(.+)::// ? $1 : caller(1);
+
+           if (defined $caller1 && $type =~ /^(?:\w+)$/) {
+               my $prop = "${caller1}::$type";
+               if (exists &{$prop}) {
+                   no strict 'refs';
+                   
+                   $list = &{$prop};
+                   last GETFILE;
+               }
+           }
+
             my $wasIs;
 
             ($wasIs = $type =~ s/^Is(?:\s+|[-_])?//i)
               or
-            $type =~ s/^Category\s*=\s*//i
+            $type =~ s/^(?:(?:General(?:\s+|_)?)?Category|gc)\s*[:=]\s*//i
               or
-            $type =~ s/^Script\s*=\s*//i
+            $type =~ s/^(?:Script|sc)\s*[:=]\s*//i
               or
-            $type =~ s/^Block\s*=\s*/In/i;
+            $type =~ s/^Block\s*[:=]\s*/In/i;
+
+
+           ##
+           ## See if it's in some enumeration.
+           ##
+           require "unicore/PVA.pl";
+           if ($type =~ /^([\w\s]+)[:=]\s*(.*)/) {
+               my ($enum, $val) = (lc $1, lc $2);
+               $enum =~ tr/ _-//d;
+               $val =~ tr/ _-//d;
+
+               my $pa = $PropertyAlias{$enum} ? $enum : $PA_reverse{$enum};
+               my $f = $PropValueAlias{$pa}{$val} ? $val : $PVA_reverse{$pa}{lc $val};
+
+               if ($pa and $f) {
+                   $pa = "gc_sc" if $pa eq "gc" or $pa eq "sc";
+                   $file = "unicore/lib/$pa/$PVA_abbr_map{$pa}{lc $f}.pl";
+                   last GETFILE;
+               }
+           }
+           else {
+               my $t = lc $type;
+               $t =~ tr/ _-//d;
+
+               if ($PropValueAlias{gc}{$t} or $PropValueAlias{sc}{$t}) {
+                   $file = "unicore/lib/gc_sc/$PVA_abbr_map{gc_sc}{$t}.pl";
+                   last GETFILE;
+               }
+           }
 
             ##
             ## See if it's in the direct mapping table.
             ##
             require "unicore/Exact.pl";
             if (my $base = $utf8::Exact{$type}) {
-                $file = "unicore/lib/$base.pl";
+                $file = "unicore/lib/gc_sc/$base.pl";
                 last GETFILE;
             }
 
@@ -79,28 +120,12 @@ sub SWASHNEW {
             print "canonical = $canonical\n" if DEBUG;
 
             require "unicore/Canonical.pl";
-            if (my $base = $utf8::Canonical{$canonical}) {
-                $file = "unicore/lib/$base.pl";
+            if (my $base = ($utf8::Canonical{$canonical} || $utf8::Canonical{ lc $utf8::PropertyAlias{$canonical} })) {
+                $file = "unicore/lib/gc_sc/$base.pl";
                 last GETFILE;
             }
 
            ##
-           ## It could be a user-defined property.
-           ##
-
-           my $caller1 = caller(1);
-
-           if (defined $caller1 && $type =~ /^(?:\w+)$/) {
-               my $prop = $caller1 . "::" . ( $wasIs ? "Is" : "" ) . $type;
-               if (exists &{$prop}) {
-                   no strict 'refs';
-                   
-                   $list = &{$prop};
-                   last GETFILE;
-               }
-           }
-
-           ##
            ## See if it's a user-level "To".
            ##
 
@@ -108,6 +133,7 @@ sub SWASHNEW {
 
            if (defined $caller0 && $type =~ /^To(?:\w+)$/) {
                my $map = $caller0 . "::" . $type;
+
                if (exists &{$map}) {
                    no strict 'refs';
                    
@@ -160,7 +186,7 @@ sub SWASHNEW {
     }
 
     my $extras;
-    my $bits;
+    my $bits = 0;
 
     my $ORIG = $list;
     if ($list) {
@@ -203,11 +229,14 @@ sub SWASHNEW {
            my $char = $1;
            my $name = $2;
            print STDERR "$1 => $2\n" if DEBUG;
-           if ($char =~ /[-+!]/) {
+           if ($char =~ /[-+!&]/) {
                my ($c,$t) = split(/::/, $name, 2);     # bogus use of ::, really
                my $subobj;
                if ($c eq 'utf8') {
-                   $subobj = $c->SWASHNEW($t, "", 0, 0, 0);
+                   $subobj = utf8->SWASHNEW($t, "", 0, 0, 0);
+               }
+               elsif (exists &$name) {
+                   $subobj = utf8->SWASHNEW($name, "", 0, 0, 0);
                }
                elsif ($c =~ /^([0-9a-fA-F]+)/) {
                    $subobj = utf8->SWASHNEW("", $c, 0, 0, 0);
@@ -315,7 +344,7 @@ sub SWASHGET {
     }
     for my $x ($self->{EXTRAS}) {
        pos $x = 0;
-       while ($x =~ /^([-+!])(.*)/mg) {
+       while ($x =~ /^([-+!&])(.*)/mg) {
            my $char = $1;
            my $name = $2;
            print STDERR "INDIRECT $1 $2\n" if DEBUG;
@@ -356,6 +385,18 @@ sub SWASHGET {
                    }
                }
            }
+           elsif ($char eq '&') {
+               if ($bits == 1 and $otherbits == 1) {
+                   $swatch &= $other;
+               }
+               else {
+                   for ($key = 0; $key < $len; $key++) {
+                       if (!vec($other, $key, $otherbits)) {
+                           vec($swatch, $key, $bits) = 0;
+                       }
+                   }
+               }
+           }
        }
     }
     if (DEBUG) {