Support [] style prototypes.

[p5sagit/p5-mst-13.2.git] / lib / utf8_heavy.pl

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index f73b9eb..0cc71f4 100644 (file)
--- a/lib/utf8_heavy.pl
+++ b/lib/utf8_heavy.pl
@@ -12,51 +12,93 @@ sub SWASHNEW {
 
     print STDERR "SWASHNEW @_\n" if DEBUG;
 
-    my $file;
-
     if ($type and ref ${"${class}::{$type}"} eq $class) {
        warn qq/Found \${"${class}::{$type}"}\n/ if DEBUG;
        return ${"${class}::{$type}"};  # Already there...
     }
 
     if ($type) {
+       $type =~ s/^\s+//;
+       $type =~ s/\s+$//;
 
-       defined %utf8::In || do "unicore/In.pl";
+       print "type = $type\n" if DEBUG;
 
-       $type =~ s/^In(?:[-_]|\s+)?(?!herited$)//i;
-       $type =~ s/\s+$//;
+       my $file;
 
-        $type = 'Lampersand' if $type =~ /^(?:Is)?L&$/;
-
-       my $inprefix = substr(lc($type), 0, 3);
-       if (exists $utf8::InPat{$inprefix}) {
-           my $In = $type;
-           for my $k (keys %{$utf8::InPat{$inprefix}}) {
-               if ($In =~ /^$k$/i) {
-                   $In = $utf8::InPat{$inprefix}->{$k};
-                   if (exists $utf8::In{$In}) {
-                       $file = "unicore/In/$utf8::In{$In}";
-                       print "inprefix = $inprefix, In = $In, k = $k, file = $file\n" if DEBUG;
-                       last;
+       unless (defined $file) {
+           defined %utf8::Is || do "unicore/Is.pl";
+           if ($type =~ /^(?:Is|Category\s*=\s*)?[- _]?([A-Z].*)$/i) {
+               my $istype = $1;
+               print "istype = $istype\n" if DEBUG;
+               unless ($list = do "unicore/Is/$istype.pl") {
+                   if (exists $utf8::Is{$istype}) {
+                       $file = "unicore/Is/$utf8::Is{$istype}";
+                   } else {
+                       my $isprefix = substr(lc($istype), 0, 2);
+                       print "isprefix = $isprefix\n" if DEBUG;
+                       if (exists $utf8::IsPat{$isprefix}) {
+                           my $Is = $istype;
+                           print "isprefix = $isprefix, Is = $Is\n" if DEBUG;
+                           for my $k (keys %{$utf8::IsPat{$isprefix}}) {
+                               print "isprefix = $isprefix, Is = $Is, k = $k\n" if DEBUG;
+                               if ($Is =~ /^$k$/i) {
+                                   $file = "unicore/Is/$utf8::IsPat{$isprefix}->{$k}";
+                                   print "isprefix = $isprefix, Is = $Is, k = $k, file = $file\n" if DEBUG;
+                                   last;
+                               }
+                           }
+                       }
+                   }
+               }
+           }
+                       
+           unless (defined $file) {
+               defined %utf8::In || do "unicore/In.pl";
+               $type = 'Lampersand' if $type =~ /^(?:Is)?L&$/;
+               if ($type =~ /^(In|(?:Script|Block)\s*=\s*)?[- _]?(?!herited$)(.+)/i) {
+                   my $incat  = $1;
+                   my $intype = $2;
+                   print "incat = $incat, intype = $intype\n" if DEBUG;
+                   if (exists $utf8::In{$intype}) {
+                       $file = "unicore/In/$utf8::In{$intype}";
+                   } else {
+                       my $inprefix = substr(lc($intype), 0, 2);
+                       print "inprefix = $inprefix\n" if DEBUG;
+                       if (exists $utf8::InPat{$inprefix}) {
+                           my $In = $intype;
+                           print "inprefix = $inprefix, In = $In\n" if DEBUG;
+                           for my $k (keys %{$utf8::InPat{$inprefix}}) {
+                               print "inprefix = $inprefix, In = $In, k = $k\n" if DEBUG;
+                               if ($In =~ /^$k$/i) {
+                                   my $i = $utf8::InPat{$inprefix}->{$k};
+                                   print "inprefix = $inprefix, In = $In, k = $k, i = $i\n" if DEBUG;
+                                   next if $incat =~ /^S/ &&
+                                           !exists $utf8::InScript{$i};
+                                   next if $incat =~ /^B/ &&
+                                           !exists $utf8::InBlock{$i};
+                                   $file = "unicore/In/$i";
+                                   print "inprefix = $inprefix, In = $In, k = $k, file = $file\n" if DEBUG;
+                                   last;
+                               }
+                           }
+                       }
                    }
                }
            }
-       }
 
-       unless (defined $file) {
-           # This is separate from 'To' in preparation of Is.pl (a la In.pl).
-           if ($type =~ /^Is([A-Z][A-Za-z]*)$/) {
-               $file = "unicore/Is/$1";
-           } elsif ((not defined $file) && $type =~ /^To([A-Z][A-Za-z]*)$/) {
-               $file = "unicore/To/$1";
+           unless (defined $file) {
+               if ($type =~ /^To([A-Z][A-Za-z]+)$/) {
+                   $file = "unicore/To/$1";
+               }
            }
        }
-    }
 
-    {
-        $list ||= do "$file.pl"
-             ||  do "unicore/Is/$type.pl"
-             ||  croak("Can't find Unicode character property \"$type\"");
+       if (defined $file) {
+           $list = do "$file.pl";
+       }
+
+       croak("Can't find Unicode character property \"$type\"")
+           unless $list;
     }
 
     my $extras;
@@ -99,7 +141,7 @@ sub SWASHNEW {
        while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) {
            my $char = $1;
            my $name = $2;
-#          print STDERR "$1 => $2\n" if DEBUG;
+           print STDERR "$1 => $2\n" if DEBUG;
            if ($char =~ /[-+!]/) {
                my ($c,$t) = split(/::/, $name, 2);     # bogus use of ::, really
                my $subobj = $c->SWASHNEW($t, "", 0, 0, 0);
@@ -124,6 +166,7 @@ sub SWASHNEW {
 # NOTE: utf8.c:swash_init() assumes entries are never modified once generated.
 
 sub SWASHGET {
+    # See utf8.c:Perl_swash_fetch for problems with this interface.
     my ($self, $start, $len) = @_;
     local $^D = 0 if $^D;
     my $type = $self->{TYPE};
@@ -147,7 +190,7 @@ sub SWASHGET {
                my $max = (defined $2 ? hex $2 : $min);
                my $val = hex $3;
                next if $max < $start;
-#              print "$min $max $val\n";
+               print "$min $max $val\n" if DEBUG;
                if ($none) {
                    if ($min < $start) {
                        $val += $start - $min if $val < $none;
@@ -155,7 +198,7 @@ sub SWASHGET {
                    }
                    for ($key = $min; $key <= $max; $key++) {
                        last LINE if $key >= $end;
-#                      print STDERR "$key => $val\n" if DEBUG;
+                       print STDERR "$key => $val\n" if DEBUG;
                        vec($swatch, $key - $start, $bits) = $val;
                        ++$val if $val < $none;
                    }
@@ -167,7 +210,7 @@ sub SWASHGET {
                    }
                    for ($key = $min; $key <= $max; $key++, $val++) {
                        last LINE if $key >= $end;
-#                      print STDERR "$key => $val\n" if DEBUG;
+                       print STDERR "$key => $val\n" if DEBUG;
                        vec($swatch, $key - $start, $bits) = $val;
                    }
                }
@@ -184,7 +227,7 @@ sub SWASHGET {
                }
                for ($key = $min; $key <= $max; $key++) {
                    last LINE if $key >= $end;
-#                  print STDERR "$key => 1\n" if DEBUG;
+                   print STDERR "$key => 1\n" if DEBUG;
                    vec($swatch, $key - $start, 1) = 1;
                }
            }