XS-assisted SWASHGET (esp. for t/uni/class.t speedup)

[perl5.git] / lib / utf8_heavy.pl

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index b6fdeb9..229ed97 100644 (file)
--- a/lib/utf8_heavy.pl
+++ b/lib/utf8_heavy.pl
@@ -267,146 +267,11 @@ 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};
-    my $bits = $self->{BITS};
-    my $none = $self->{NONE};
-    print STDERR "SWASHGET @_ [$type/$bits/$none]\n" if DEBUG;
-    my $end = $start + $len;
-    my $swatch = "";
-    my $key;
-    vec($swatch, $len - 1, $bits) = 0; # Extend to correct length.
-    if ($none) {
-       for $key (0 .. $len - 1) { vec($swatch, $key, $bits) = $none }
-    }
-
-    for ($self->{LIST}) {
-       pos $_ = 0;
-       if ($bits > 1) {
-         LINE:
-           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) {
-                   if ($min < $start) {
-                       $val += $start - $min if $val < $none;
-                       $min = $start;
-                   }
-                   for ($key = $min; $key <= $max; $key++) {
-                       last LINE if $key >= $end;
-                       print STDERR "$key => $val\n" if DEBUG;
-                       vec($swatch, $key - $start, $bits) = $val;
-                       ++$val if $val < $none;
-                   }
-               }
-               else {
-                   if ($min < $start) {
-                       $val += $start - $min;
-                       $min = $start;
-                   }
-                   for ($key = $min; $key <= $max; $key++, $val++) {
-                       last LINE if $key >= $end;
-                       print STDERR "$key => $val\n" if DEBUG;
-                       vec($swatch, $key - $start, $bits) = $val;
-                   }
-               }
-           }
-       }
-       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;
-               next if $max < $start;
-               if ($min < $start) {
-                   $min = $start;
-               }
-               for ($key = $min; $key <= $max; $key++) {
-                   last LINE if $key >= $end;
-                   print STDERR "$key => 1\n" if DEBUG;
-                   vec($swatch, $key - $start, 1) = 1;
-               }
-           }
-       }
-    }
-    for my $x ($self->{EXTRAS}) {
-       pos $x = 0;
-       while ($x =~ /^([-+!&])(.*)/mg) {
-           my $char = $1;
-           my $name = $2;
-           print STDERR "INDIRECT $1 $2\n" if DEBUG;
-           my $otherbits = $self->{$name}->{BITS};
-           croak("SWASHGET size mismatch") if $bits < $otherbits;
-           my $other = $self->{$name}->SWASHGET($start, $len);
-           if ($char eq '+') {
-               if ($bits == 1 and $otherbits == 1) {
-                   $swatch |= $other;
-               }
-               else {
-                   for ($key = 0; $key < $len; $key++) {
-                       vec($swatch, $key, $bits) = vec($other, $key, $otherbits);
-                   }
-               }
-           }
-           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) = 1;
-                       }
-                   }
-               }
-           }
-           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;
-                       }
-                   }
-               }
-           }
-           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) {
-       print STDERR "CELLS ";
-       for ($key = 0; $key < $len; $key++) {
-           print STDERR vec($swatch, $key, $bits), " ";
-       }
-       print STDERR "\n";
-    }
-    $swatch;
+    # See universal.c for XS utf8::SWASHGET_heavy.
+    # USAGE: $swatch = utf8::SWASHGET_heavy($self, $start, $len, DEBUG);
+    return utf8::SWASHGET_heavy($_[0], $_[1], $_[2], DEBUG);
 }
 
 1;