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

Message-Id: <20051123175603.FFD5.BQW10602@nifty.com>

And :
Message-Id: <20051123202935.4D9D.BQW10602@nifty.com>

with some nits to use U8 instead of char more consistently

p4raw-id: //depot/perl@26199

1 files changed, 3 insertions, 138 deletions

diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl
index b6fdeb997b..229ed97536 100644
--- 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;