X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Futf8_heavy.pl;h=f4a0aaa3e8d119e68b648c91a398b240efea7d65;hb=cc83745da206d409d7227df077f422fd9ecbe680;hp=29d4ac2c7d8831b441a8dc15e834a08dd4928ae5;hpb=491fd90a109f6263a896300e5709e6fd255f075f;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index 29d4ac2..f4a0aaa 100644
--- a/lib/utf8_heavy.pl
+++ b/lib/utf8_heavy.pl
@@ -6,12 +6,13 @@ 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
+## "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 {
@@ -28,7 +29,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 +51,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
@@ -85,25 +88,41 @@ sub SWASHNEW {
 	    ## It could be a user-defined property.
 	    ##
 
-	    if ($type =~ /^I[ns](\w+)$/) {
-                my @caller = caller(1);
+	    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;
+		}
+	    }
 
-                if (defined $caller[0]) {
-                    my $prop = $caller[0] . "::" . $type;
+	    ##
+	    ## See if it's a user-level "To".
+	    ##
 
-                    if (exists &{$prop}) {
-                        no strict 'refs';
+	    my $caller0 = caller(0);
 
-                        $list = &{$prop};
-                        last GETFILE;
-                    }
-                }
-            }
+	    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....
@@ -123,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.
@@ -141,7 +160,7 @@ sub SWASHNEW {
     }
 
     my $extras;
-    my $bits;
+    my $bits = 0;
 
     my $ORIG = $list;
     if ($list) {
@@ -150,8 +169,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,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;
 	}
@@ -184,7 +205,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};
@@ -232,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) {
@@ -265,9 +297,10 @@ 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) {
+		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;