change #18038 gives too many problems on t/450_service.t; disable

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

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index 70bd018..4c5ef27 100644 (file)
--- a/lib/utf8_heavy.pl
+++ b/lib/utf8_heavy.pl
@@ -6,10 +6,10 @@ sub DEBUG () { 0 }
 
 sub DESTROY {}
 
-sub croak { require Carp; Carp::croak(@_) }
-
 my %Cache;
 
+sub croak { require Carp; Carp::croak(@_) }
+
 ##
 ## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape
 ##
@@ -28,7 +28,7 @@ sub SWASHNEW {
     ## ranges.
     ##
     ## To make the parsing of $type clear, this code takes the a rather
-    ## unorthadox approach of last'ing out of the block once we have the
+    ## unorthodox approach of last'ing out of the block once we have the
     ## info we need. Were this to be a subroutine, the 'last' would just
     ## be a 'return'.
     ##
@@ -50,7 +50,9 @@ sub SWASHNEW {
             ##
             ## 'Block=' is replaced by 'In'.
             ##
-            $type =~ s/^Is(?:\s+|[-_])?//i
+            my $wasIs;
+
+            ($wasIs = $type =~ s/^Is(?:\s+|[-_])?//i)
               or
             $type =~ s/^Category\s*=\s*//i
               or
@@ -81,6 +83,22 @@ sub SWASHNEW {
                 last GETFILE;
             }
 
+           ##
+           ## It could be a user-defined property.
+           ##
+
+           my $caller = caller(1);
+
+           if (defined $caller && $type =~ /^(?:\w+)$/) {
+               my $prop = $caller . "::" . ( $wasIs ? "Is" : "" ) . $type;
+               if (exists &{$prop}) {
+                   no strict 'refs';
+                   
+                   $list = &{$prop};
+                   last GETFILE;
+               }
+           }
+
             ##
             ## Last attempt -- see if it's a "To" name (e.g. "ToLower")
             ##
@@ -99,21 +117,25 @@ sub SWASHNEW {
             return $type;
         }
 
-        print "found it (file='$file')\n" if DEBUG;
+       if (defined $file) {
+           print "found it (file='$file')\n" if DEBUG;
+
+           ##
+           ## If we reach here, it was due to a 'last GETFILE' above
+           ## (exception: user-defined properties), 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.
+           ##
+           if ($Cache{$file} and ref($Cache{$file}) eq $class)
+           {
+               print "Returning cached '$file' for \\p{$type}\n" if DEBUG;
+               return $Cache{$class, $file};
+           }
 
-        ##
-        ## If we reach here, it was due to a 'last GETFILE' above, 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.
-        ##
-        if ($Cache{$file} and ref($Cache{$file}) eq $class)
-        {
-            print "Returning cached '$file' for \\p{$type}\n" if DEBUG;
-            return $Cache{$class, $file};
-        }
+           $list = do $file;
+       }
 
-        $list = do $file;
         $ListSorted = 1; ## we know that these lists are sorted
     }
 
@@ -127,8 +149,10 @@ sub SWASHNEW {
        no warnings;
        $extras = join '', grep /^[^0-9a-fA-F]/, @tmp;
        $list = join '',
-           sort { hex $a <=> hex $b }
-           grep {/^([0-9a-fA-F]+)/ and not $seen{$1}++} @tmp; # XXX doesn't do ranges right
+           map  { $_->[1] }
+           sort { $a->[0] <=> $b->[0] }
+           map  { /^([0-9a-fA-F]+)/; [ hex($1), $_ ] }
+           grep { /^([0-9a-fA-F]+)/ and not $seen{$1}++ } @tmp; # XXX doesn't do ranges right
     }
 
     if ($none) {
@@ -161,7 +185,13 @@ sub SWASHNEW {
            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);
+               my $subobj;
+               if ($c eq 'utf8') {
+                   $subobj = $c->SWASHNEW($t, "", 0, 0, 0);
+               }
+               elsif ($c =~ /^([0-9a-fA-F]+)/) {
+                   $subobj = utf8->SWASHNEW("", $c, 0, 0, 0);
+               }
                return $subobj unless ref $subobj;
                push @extras, $name => $subobj;
                $bits = $subobj->{BITS} if $bits < $subobj->{BITS};
@@ -242,7 +272,7 @@ sub SWASHGET {
        }
        else {
          LINE:
-           while (/^([0-9a-fA-F]+)(?:\t([0-9a-fA-F]+))?/mg) {
+           while (/^([0-9a-fA-F]+)(?:[ \t]+([0-9a-fA-F]+))?/mg) {
                my $min = hex $1;
                my $max = (defined $2 ? hex $2 : $min);
                next if $max < $start;