[Encode] UTF-7 Support

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

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index 4c5ef27..d8c46b5 100644 (file)
--- a/lib/utf8_heavy.pl
+++ b/lib/utf8_heavy.pl
@@ -11,7 +11,8 @@ my %Cache;
 sub croak { require Carp; Carp::croak(@_) }
 
 ##
-## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape
+## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape.
+## It's a data structure that encodes a set of Unicode characters.
 ##
 
 sub SWASHNEW {
@@ -87,10 +88,10 @@ sub SWASHNEW {
            ## It could be a user-defined property.
            ##
 
-           my $caller = caller(1);
+           my $caller1 = caller(1);
 
-           if (defined $caller && $type =~ /^(?:\w+)$/) {
-               my $prop = $caller . "::" . ( $wasIs ? "Is" : "" ) . $type;
+           if (defined $caller1 && $type =~ /^(?:\w+)$/) {
+               my $prop = $caller1 . "::" . ( $wasIs ? "Is" : "" ) . $type;
                if (exists &{$prop}) {
                    no strict 'refs';
                    
@@ -99,10 +100,29 @@ sub SWASHNEW {
                }
            }
 
+           ##
+           ## See if it's a user-level "To".
+           ##
+
+           my $caller0 = caller(0);
+
+           if (defined $caller0 && $type =~ /^To(?:\w+)$/) {
+               my $map = $caller0 . "::" . $type;
+               if (exists &{$map}) {
+                   no strict 'refs';
+                   
+                   $list = &{$map};
+                   last GETFILE;
+               }
+           }
+
             ##
-            ## Last attempt -- see if it's a "To" name (e.g. "ToLower")
+            ## Last attempt -- see if it's a standard "To" name
+           ## (e.g. "ToLower")  ToTitle is used by ucfirst().
+           ## The user-level way to access ToDigit() and ToFold()
+           ## is to use Unicode::UCD.
             ##
-            if ($type =~ /^To([A-Z][A-Za-z]+)$/)
+            if ($type =~ /^To(Digit|Fold|Lower|Title|Upper)$/)
             {
                 $file = "unicore/To/$1.pl";
                 ## would like to test to see if $file actually exists....
@@ -122,7 +142,7 @@ sub SWASHNEW {
 
            ##
            ## If we reach here, it was due to a 'last GETFILE' above
-           ## (exception: user-defined properties), so we
+           ## (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
            ## file to load.
@@ -162,10 +182,10 @@ sub SWASHNEW {
 
     if ($minbits < 32) {
        my $top = 0;
-       while ($list =~ /^([0-9a-fA-F]+)(?:\t([0-9a-fA-F]+)?)(?:\t([0-9a-fA-F]+))?/mg) {
+       while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) {
            my $min = hex $1;
-           my $max = hex(defined $2 ? $2 : $1);
-           my $val = hex(defined $3 ? $3 : "");
+           my $max = defined $2 ? hex $2 : $min;
+           my $val = defined $3 ? hex $3 : 0;
            $val += $max - $min if defined $3;
            $top = $val if $val > $top;
        }
@@ -239,10 +259,15 @@ sub SWASHGET {
        pos $_ = 0;
        if ($bits > 1) {
          LINE:
-           while (/^([0-9a-fA-F]+)(?:\t([0-9a-fA-F]+)?)(?:\t([0-9a-fA-F]+))?/mg) {
-               my $min = hex $1;
-               my $max = (defined $2 ? hex $2 : $min);
-               my $val = hex $3;
+           while (/^([0-9a-fA-F]+)(?:[ \t]([0-9a-fA-F]+)?)?(?:[ \t]([0-9a-fA-F]+))?/mg) {
+               chomp;
+               my ($a, $b, $c) = ($1, $2, $3);
+               croak "$type: illegal mapping '$_'"
+                   if $type =~ /^To/ &&
+                      !(defined $a && defined $c);
+               my $min = hex $a;
+               my $max = defined $b ? hex $b : $min;
+               my $val = defined $c ? hex $c : 0;
                next if $max < $start;
                print "$min $max $val\n" if DEBUG;
                if ($none) {
@@ -273,8 +298,9 @@ sub SWASHGET {
        else {
          LINE:
            while (/^([0-9a-fA-F]+)(?:[ \t]+([0-9a-fA-F]+))?/mg) {
+               chomp;
                my $min = hex $1;
-               my $max = (defined $2 ? hex $2 : $min);
+               my $max = defined $2 ? hex $2 : $min;
                next if $max < $start;
                if ($min < $start) {
                    $min = $start;