require Exporter;
-our $VERSION = '0.21';
+# Supporting on EBCDIC platform is not tested.
+# Tester(s) welcome!
+our $IsEBCDIC = ord("A") != 0x41;
+
+our $VERSION = '0.23';
our $PACKAGE = __PACKAGE__;
our @ISA = qw(Exporter);
}
}
-our $getCombinClass; # coderef for combining class from Unicode::Normalize
-
-use constant Min2 => 0x20; # minimum weight at level 2
-use constant Min3 => 0x02; # minimum weight at level 3
-
-# format for pack
-use constant VCE_FORMAT => 'Cn4'; # for variable + CE with 4 levels
-
-# values of variable
+# Perl's boolean
+use constant TRUE => 1;
+use constant FALSE => "";
+use constant NOMATCHPOS => -1;
+
+# A coderef to get combining class imported from Unicode::Normalize
+# (i.e. \&Unicode::Normalize::getCombinClass).
+# This is also used as a HAS_UNICODE_NORMALIZE flag.
+our $getCombinClass;
+
+# Minimum weights at level 2 and 3, respectively
+use constant Min2 => 0x20;
+use constant Min3 => 0x02;
+
+# Shifted weight at 4th level
+use constant Shift4 => 0xFFFF;
+
+# Variable weight at 1st level.
+# This is a negative value but should be regarded as zero on collation.
+# This is for distinction of variable chars from level 3 ignorable chars.
+use constant Var1 => -1;
+
+
+# A boolean for Variable and 16-bit weights at 4 levels of Collation Element
+# PROBLEM: The Default Unicode Collation Element Table
+# has weights over 0xFFFF at the 4th level.
+# The tie-breaking in the variable weights
+# other than "shift" (as well as "shift-trimmed") is unreliable.
+use constant VCE_TEMPLATE => 'Cn4';
+
+# Unicode encoding of strings to be collated
+# TODO: 'N*' for UTF-32BE, 'V*' for UTF-32LE.
+use constant UTF_TEMPLATE => 'U*';
+
+# A sort key: 16-bit weights
+# See also the PROBLEM on VCE_TEMPLATE above.
+use constant KEY_TEMPLATE => 'n*';
+
+# Level separator in a sort key:
+# i.e. pack(KEY_TEMPLATE, 0)
+use constant LEVEL_SEP => "\0\0";
+
+# As Unicode code point separator for hash keys.
+# A joined code point string (denoted by JCPS below)
+# like "65;768" is used for internal processing
+# instead of Perl's Unicode string like "\x41\x{300}",
+# as the native code point is different from the Unicode code point
+# on EBCDIC platform.
+# This character must not be included in any stringified
+# representation of an integer.
+use constant CODE_SEP => ';';
+
+# boolean values of variable weights
use constant NON_VAR => 0; # Non-Variable character
use constant VAR => 1; # Variable character
+# Logical_Order_Exception in PropList.txt
+# TODO: synchronization with change of PropList.txt.
our $DefaultRearrange = [ 0x0E40..0x0E44, 0x0EC0..0x0EC4 ];
sub UCA_Version { "9" }
entry entries table combining maxlength
ignoreChar ignoreName undefChar undefName
versionTable alternateTable backwardsTable forwardsTable rearrangeTable
- derivCode normCode rearrangeHash isShift L3ignorable
+ derivCode normCode rearrangeHash L3_ignorable
/;
# The hash key 'ignored' is deleted at VERSION 0.21.
+# The hash key 'isShift' are deleted at VERSION 0.23.
my (%ChangeOK, %ChangeNG);
@ChangeOK{ @ChangeOK } = ();
if 4 < $self->{level};
$self->{derivCode} =
- $self->{UCA_Version} == -1 ? \&broken_derivCE :
- $self->{UCA_Version} == 8 ? \&derivCE_8 :
- $self->{UCA_Version} == 9 ? \&derivCE_9 :
+ $self->{UCA_Version} == 8 ? \&_derivCE_8 :
+ $self->{UCA_Version} == 9 ? \&_derivCE_9 :
croak "Illegal UCA version (passed $self->{UCA_Version}).";
$self->{alternate} = lc($self->{alternate});
croak "$PACKAGE unknown alternate tag name: $self->{alternate}"
unless exists $AlternateOK{ $self->{alternate} };
- $self->{isShift} = $self->{alternate} eq 'shifted' ||
- $self->{alternate} eq 'shift-trimmed';
-
$self->{backwards} = []
if ! defined $self->{backwards};
$self->{backwards} = [ $self->{backwards} ]
{
my $self = shift;
my $line = shift;
- my($name, $ele, @key);
+ my($name, $entry, @uv, @key);
return if $line !~ /^\s*[0-9A-Fa-f]/;
croak "Wrong Entry: <charList> must be separated by ';' from <collElement>"
if ! $k;
- my @e = _getHexArray($e);
- return if !@e;
+ @uv = _getHexArray($e);
+ return if !@uv;
+
+ $entry = join(CODE_SEP, @uv); # in JCPS
- $ele = pack('U*', @e);
- return if defined $self->{undefChar} && $ele =~ /$self->{undefChar}/;
+ if (defined $self->{undefChar} || defined $self->{ignoreChar}) {
+ # Do not use UTF_TEMPLATE; Perl' RE is only for utf8.
+ my $ele = $IsEBCDIC
+ ? pack('U*', map utf8::unicode_to_native($_), @uv)
+ : pack('U*', @uv);
- my $combining = 1; # primary = 0, secondary != 0;
- my $level3ignore;
+ # regarded as if it were not entried in the table
+ return
+ if defined $self->{undefChar} && $ele =~ /$self->{undefChar}/;
- # replace with completely ignorable
- if (defined $self->{ignoreName} && $name =~ /$self->{ignoreName}/ ||
- defined $self->{ignoreChar} && $ele =~ /$self->{ignoreChar}/)
- {
- $k = '[.0000.0000.0000.0000]';
+ # replaced as completely ignorable
+ $k = '[.0000.0000.0000.0000]'
+ if defined $self->{ignoreChar} && $ele =~ /$self->{ignoreChar}/;
}
+ # replaced as completely ignorable
+ $k = '[.0000.0000.0000.0000]'
+ if defined $self->{ignoreName} && $name =~ /$self->{ignoreName}/;
+
+ my $combining = TRUE; # primary = 0, secondary != 0;
+ my $is_L3_ignorable;
+
foreach my $arr ($k =~ /\[([^\[\]]+)\]/g) { # SPACEs allowed
my $var = $arr =~ /\*/; # exactly /^\*/ but be lenient.
- my @arr = _getHexArray($arr);
- push @key, pack(VCE_FORMAT, $var, @arr);
- $combining = 0 unless $arr[0] == 0 && $arr[1] != 0;
- $level3ignore = 1 if $arr[0] == 0 && $arr[1] == 0 && $arr[2] == 0;
+ my @wt = _getHexArray($arr);
+ push @key, pack(VCE_TEMPLATE, $var, @wt);
+ $combining = FALSE
+ unless $wt[0] == 0 && $wt[1] != 0;
+ $is_L3_ignorable = TRUE
+ if $wt[0] + $wt[1] + $wt[2] == 0;
+ # if $arr !~ /[1-9A-Fa-f]/; NG
+ # Conformance Test shows L3-ignorable is completely ignorable.
}
- $self->{entries}{$ele} = \@key;
+ $self->{entries}{$entry} = \@key;
- $self->{combining}{$ele} = 1
+ $self->{combining}{$entry} = TRUE
if $combining;
- $self->{L3ignorable}{$e[0]} = 1
- if @e == 1 && $level3ignore;
+ # The key is a string representing a numeral code point.
+
+ $self->{L3_ignorable}{$uv[0]} = TRUE
+ if @uv == 1 && $is_L3_ignorable;
- $self->{maxlength}{ord $ele} = scalar @e if @e > 1;
+ # Contraction is to be considered in the range of this maxlength.
+ $self->{maxlength}{$uv[0]} = scalar @uv
+ if @uv > 1;
}
##
-## arrayref CE = altCE(bool variable?, list[num] weights)
+## arrayref[weights] = altCE(bool variable?, list[num] weights)
##
sub altCE
{
my $self = shift;
- my($var, @c) = unpack(VCE_FORMAT, shift);
+ my($var, @wt) = unpack(VCE_TEMPLATE, shift);
$self->{alternate} eq 'blanked' ?
- $var ? [0,0,0,$c[3]] : \@c :
+ $var ? [Var1, 0, 0, $wt[3]] : \@wt :
$self->{alternate} eq 'non-ignorable' ?
- \@c :
+ \@wt :
$self->{alternate} eq 'shifted' ?
- $var ? [0,0,0,$c[0] ] : [ @c[0..2], $c[0]+$c[1]+$c[2] ? 0xFFFF : 0 ] :
+ $var ? [Var1, 0, 0, $wt[0] ]
+ : [ @wt[0..2], $wt[0]+$wt[1]+$wt[2] ? Shift4 : 0 ] :
$self->{alternate} eq 'shift-trimmed' ?
- $var ? [0,0,0,$c[0] ] : [ @c[0..2], 0 ] :
+ $var ? [Var1, 0, 0, $wt[0] ] : [ @wt[0..2], 0 ] :
croak "$PACKAGE unknown alternate name: $self->{alternate}";
}
my $ver = $self->{UCA_Version};
my $key = $self->getSortKey(@_);
- my $view = join " ", map sprintf("%04X", $_), unpack 'n*', $key;
+ my $view = join " ", map sprintf("%04X", $_), unpack(KEY_TEMPLATE, $key);
+
if ($ver <= 8) {
$view =~ s/ ?0000 ?/|/g;
} else {
##
-## list[strings] elements = splitCE(string arg)
+## arrayref of JCPS = splitCE(string to be collated)
+## arrayref of arrayref[JCPS, ini_pos, fin_pos] = splitCE(string, true)
##
sub splitCE
{
my $self = shift;
+ my $wLen = $_[1];
+
my $code = $self->{preprocess};
my $norm = $self->{normCode};
my $ent = $self->{entries};
my $max = $self->{maxlength};
my $reH = $self->{rearrangeHash};
- my $L3i = $self->{L3ignorable};
+ my $ign = $self->{L3_ignorable};
my $ver9 = $self->{UCA_Version} > 8;
- my $str = ref $code ? &$code(shift) : shift;
- $str = &$norm($str) if ref $norm;
+ my ($str, @buf);
- my @src = unpack('U*', $str);
- my @buf;
+ if ($wLen) {
+ $code and croak "Preprocess breaks character positions. "
+ . "Don't use with index(), match(), etc.";
+ $norm and croak "Normalization breaks character positions. "
+ . "Don't use with index(), match(), etc.";
+ $str = $_[0];
+ }
+ else {
+ $str = $_[0];
+ $str = &$code($str) if ref $code;
+ $str = &$norm($str) if ref $norm;
+ }
- # rearrangement
- if ($reH) {
+ # get array of Unicode code point of string.
+ my @src = $IsEBCDIC
+ ? map(utf8::native_to_unicode($_), unpack UTF_TEMPLATE, $str)
+ : unpack(UTF_TEMPLATE, $str);
+
+ # rearrangement:
+ # Character positions are not kept if rearranged,
+ # then neglected if $wLen is true.
+ if ($reH && ! $wLen) {
for (my $i = 0; $i < @src; $i++) {
if (exists $reH->{ $src[$i] } && $i + 1 < @src) {
($src[$i], $src[$i+1]) = ($src[$i+1], $src[$i]);
}
if ($ver9) {
- @src = grep ! $L3i->{$_}, @src;
+ # To remove a character marked as a completely ignorable.
+ for (my $i = 0; $i < @src; $i++) {
+ $src[$i] = undef if $ign->{ $src[$i] };
+ }
}
for (my $i = 0; $i < @src; $i++) {
- my $ch;
- my $u = $src[$i];
-
- # non-characters
- next if ! defined $u
- || ($u < 0 || 0x10FFFF < $u) # out of range
- || (($u & 0xFFFE) == 0xFFFE) # ??FFFE or ??FFFF (cf. utf8.c)
- || (0xD800 <= $u && $u <= 0xDFFF) # unpaired surrogates
- || (0xFDD0 <= $u && $u <= 0xFDEF) # non-character
- ;
-
- if ($max->{$u}) { # contract
- for (my $j = $max->{$u}; $j >= 1; $j--) {
- next unless $i+$j-1 < @src;
- $ch = pack 'U*', @src[$i .. $i+$j-1];
- $i += $j-1, last if $ent->{$ch};
+ next if _isNonCharacter($src[$i]);
+
+ my $i_orig = $i;
+ my $ce = $src[$i];
+
+ if ($max->{$ce}) { # contract
+ my $temp_ce = $ce;
+
+ for (my $p = $i + 1; $p < @src; $p++) {
+ next if ! defined $src[$p];
+ $temp_ce .= CODE_SEP . $src[$p];
+ if ($ent->{$temp_ce}) {
+ $ce = $temp_ce;
+ $i = $p;
+ }
+ }
+ }
+
+ # with Combining Char (UTS#10, 4.2.1).
+ # requires Unicode::Normalize.
+ # Not be $wLen, as not croaked due to $norm.
+ if ($getCombinClass) {
+ for (my $p = $i + 1; $p < @src; $p++) {
+ next if ! defined $src[$p];
+ last unless $getCombinClass->($src[$p]);
+ my $tail = CODE_SEP . $src[$p];
+ if ($ent->{$ce.$tail}) {
+ $ce .= $tail;
+ $src[$p] = undef;
+ }
}
- } else {
- $ch = pack('U', $u);
}
- # with Combining Char (UTS#10, 4.2.1), here requires Unicode::Normalize.
- if ($getCombinClass && defined $ch) {
- for (my $j = $i+1; $j < @src; $j++) {
- next unless defined $src[$j];
- last unless $getCombinClass->( $src[$j] );
- my $comb = pack 'U', $src[$j];
- next if ! $ent->{ $ch.$comb };
- $ch .= $comb;
- $src[$j] = undef;
+ if ($wLen) {
+ for (my $p = $i + 1; $p < @src; $p++) {
+ last if defined $src[$p];
+ $i = $p;
}
}
- push @buf, $ch;
+
+ push @buf, $wLen ? [$ce, $i_orig, $i + 1] : $ce;
}
- wantarray ? @buf : \@buf;
+ return \@buf;
}
##
-## list[arrayrefs] weight = getWt(string element)
+## list of arrayrefs of weights = getWt(JCPS)
##
sub getWt
{
my $self = shift;
- my $ch = shift;
+ my $ce = shift;
my $ent = $self->{entries};
my $cjk = $self->{overrideCJK};
my $hang = $self->{overrideHangul};
my $der = $self->{derivCode};
- return if !defined $ch;
- return map($self->altCE($_), @{ $ent->{$ch} })
- if $ent->{$ch};
+ return if !defined $ce;
+ return map($self->altCE($_), @{ $ent->{$ce} })
+ if $ent->{$ce};
- my $u = unpack('U', $ch);
+ # CE must not be a contraction, then it's a code point.
+ my $u = $ce;
- if (0xAC00 <= $u && $u <= 0xD7A3) { # is_Hangul
+ if (0xAC00 <= $u && $u <= 0xD7A3) { # is Hangul Syllale
return map $self->altCE($_),
$hang
- ? map(pack(VCE_FORMAT, NON_VAR, @$_), &$hang($u))
+ ? map(pack(VCE_TEMPLATE, NON_VAR, @$_), &$hang($u))
: defined $hang
? map({
- my $v = $_;
- my $vCE = $ent->{pack('U', $v)};
- $vCE ? @$vCE : $der->($v);
+ $ent->{$_} ? @{ $ent->{$_} } : $der->($_);
} _decompHangul($u))
: $der->($u);
}
0x20000 <= $u && $u <= 0x2A6D6) { # CJK Ideograph
return map $self->altCE($_),
$cjk
- ? map(pack(VCE_FORMAT, NON_VAR, @$_), &$cjk($u))
+ ? map(pack(VCE_TEMPLATE, NON_VAR, @$_), &$cjk($u))
: defined $cjk && $self->{UCA_Version} <= 8 && $u < 0x10000
- ? pack(VCE_FORMAT, NON_VAR, $u, 0x20, 0x02, $u)
+ ? pack(VCE_TEMPLATE, NON_VAR, $u, Min2, Min3, $u)
: $der->($u);
}
else {
}
}
-##
-## int = index(string, substring)
-##
-sub index
-{
- my $self = shift;
- my $lev = $self->{level};
- my $comb = $self->{combining};
- my $str = $self->splitCE(shift);
- my $sub = $self->splitCE(shift);
-
- return wantarray ? (0,0) : 0 if ! @$sub;
- return wantarray ? () : -1 if ! @$str;
-
- my @subWt = grep _ignorableAtLevel($_,$lev),
- map $self->getWt($_), @$sub;
-
- my(@strWt,@strPt);
- my $count = 0;
- for (my $i = 0; $i < @$str; $i++) {
- my $go_ahead = 0;
-
- my @tmp = grep _ignorableAtLevel($_,$lev), $self->getWt($str->[$i]);
- $go_ahead += length $str->[$i];
-
- # /*XXX*/ still broken.
- # index("e\x{300}", "e") should be 'no match' at level 2 or higher
- # as "e\x{300}" is a *single* grapheme cluster and not equal to "e".
-
- # go ahead as far as we find a combining character;
- while ($i + 1 < @$str &&
- (! defined $str->[$i+1] || $comb->{ $str->[$i+1] }) ) {
- $i++;
- next if ! defined $str->[$i];
- $go_ahead += length $str->[$i];
- push @tmp,
- grep _ignorableAtLevel($_,$lev), $self->getWt($str->[$i]);
- }
-
- push @strWt, @tmp;
- push @strPt, ($count) x @tmp;
- $count += $go_ahead;
-
- while (@strWt >= @subWt) {
- if (_eqArray(\@strWt, \@subWt, $lev)) {
- my $pos = $strPt[0];
- return wantarray ? ($pos, $count-$pos) : $pos;
- }
- shift @strWt;
- shift @strPt;
- }
- }
- return wantarray ? () : -1;
-}
-
-##
-## bool _eqArray(arrayref, arrayref, level)
-##
-sub _eqArray($$$)
-{
- my $a = shift; # length $a >= length $b;
- my $b = shift;
- my $lev = shift;
- for my $v (0..$lev-1) {
- for my $c (0..@$b-1){
- return if $a->[$c][$v] != $b->[$c][$v];
- }
- }
- return 1;
-}
-
-
-##
-## bool _ignorableAtLevel(CE, level)
-##
-sub _ignorableAtLevel($$)
-{
- my $ce = shift;
- return unless defined $ce;
- my $lv = shift;
- return ! grep { ! $ce->[$_] } 0..$lv-1;
-}
-
##
## string sortkey = getSortKey(string arg)
{
my $self = shift;
my $lev = $self->{level};
- my $rCE = $self->splitCE(shift); # get an arrayref
+ my $rCE = $self->splitCE(shift); # get an arrayref of JCPS
my $ver9 = $self->{UCA_Version} > 8;
- my $sht = $self->{isShift};
+ my $v2i = $self->{alternate} ne 'non-ignorable';
# weight arrays
my (@buf, $last_is_variable);
- foreach my $ce (@$rCE) {
- my @t = $self->getWt($ce);
- if ($sht && $ver9) {
- if (@t == 1 && $t[0][0] == 0) {
- if ($t[0][1] == 0 && $t[0][2] == 0) {
- $last_is_variable = 1;
- } else {
- next if $last_is_variable;
- }
+ foreach my $wt (map $self->getWt($_), @$rCE) {
+ if ($v2i && $ver9) {
+ if ($wt->[0] == 0) { # ignorable
+ next if $last_is_variable;
} else {
- $last_is_variable = 0;
+ $last_is_variable = ($wt->[0] == Var1);
}
}
- push @buf, @t;
+ push @buf, $wt;
}
# make sort key
my @ret = ([],[],[],[]);
foreach my $v (0..$lev-1) {
foreach my $b (@buf) {
- push @{ $ret[$v] }, $b->[$v] if $b->[$v];
+ push @{ $ret[$v] }, $b->[$v]
+ if 0 < $b->[$v];
}
}
foreach (@{ $self->{backwards} }) {
elsif (0x0D <= $_ && $_ <= 0x0E) { $_ += 5 } # hiragana
}
}
- join "\0\0", map pack('n*', @$_), @ret;
+ join LEVEL_SEP, map pack(KEY_TEMPLATE, @$_), @ret;
}
}
-sub derivCE_9 {
+sub _derivCE_9 {
my $u = shift;
my $base =
- (0x4E00 <= $u && $u <= 0x9FA5) # CJK
- ? 0xFB40 :
+ (0x4E00 <= $u && $u <= 0x9FA5)
+ ? 0xFB40 : # CJK
(0x3400 <= $u && $u <= 0x4DB5 || 0x20000 <= $u && $u <= 0x2A6D6)
- ? 0xFB80 : 0xFBC0;
+ ? 0xFB80 # CJK ext.
+ : 0xFBC0; # others
my $aaaa = $base + ($u >> 15);
my $bbbb = ($u & 0x7FFF) | 0x8000;
return
- pack(VCE_FORMAT, NON_VAR, $aaaa, Min2, Min3, $u),
- pack(VCE_FORMAT, NON_VAR, $bbbb, 0, 0, $u);
+ pack(VCE_TEMPLATE, NON_VAR, $aaaa, Min2, Min3, $u),
+ pack(VCE_TEMPLATE, NON_VAR, $bbbb, 0, 0, $u);
}
-sub derivCE_8 {
+sub _derivCE_8 {
my $code = shift;
my $aaaa = 0xFF80 + ($code >> 15);
my $bbbb = ($code & 0x7FFF) | 0x8000;
return
- pack(VCE_FORMAT, NON_VAR, $aaaa, 2, 1, $code),
- pack(VCE_FORMAT, NON_VAR, $bbbb, 0, 0, $code);
-}
-
-sub broken_derivCE { # NG
- my $code = shift;
- my $aaaa = 0xFFC2 + ($code >> 15);
- my $bbbb = $code & 0x7FFF | 0x1000;
- return
- pack(VCE_FORMAT, NON_VAR, $aaaa, 2, 1, $code),
- pack(VCE_FORMAT, NON_VAR, $bbbb, 0, 0, $code);
+ pack(VCE_TEMPLATE, NON_VAR, $aaaa, 2, 1, $code),
+ pack(VCE_TEMPLATE, NON_VAR, $bbbb, 0, 0, $code);
}
##
sub _getHexArray { map hex, $_[0] =~ /([0-9a-fA-F]+)/g }
#
-# $code must be in Hangul syllable.
+# $code *must* be in Hangul syllable.
# Check it before you enter here.
#
sub _decompHangul {
);
}
+sub _isNonCharacter {
+ my $code = shift;
+ return ! defined $code # removed
+ || ($code < 0 || 0x10FFFF < $code) # out of range
+ || (($code & 0xFFFE) == 0xFFFE) # ??FFF[EF] (cf. utf8.c)
+ || (0xD800 <= $code && $code <= 0xDFFF) # unpaired surrogates
+ || (0xFDD0 <= $code && $code <= 0xFDEF) # other non-characters
+ ;
+}
+
+
+##
+## bool _nonIgnorAtLevel(arrayref weights, int level)
+##
+sub _nonIgnorAtLevel($$)
+{
+ my $wt = shift;
+ return if ! defined $wt;
+ my $lv = shift;
+ return grep($wt->[$_] != 0, 0..$lv-1) ? TRUE : FALSE;
+}
+
+##
+## bool _eqArray(
+## arrayref of arrayref[weights] source,
+## arrayref of arrayref[weights] substr,
+## int level)
+## * comparison of graphemes vs graphemes.
+## @$source >= @$substr must be true (check it before call this);
+##
+sub _eqArray($$$)
+{
+ my $source = shift;
+ my $substr = shift;
+ my $lev = shift;
+
+ for my $g (0..@$substr-1){
+ # Do the $g'th graphemes have the same number of AV weigths?
+ return if @{ $source->[$g] } != @{ $substr->[$g] };
+
+ for my $w (0..@{ $substr->[$g] }-1) {
+ for my $v (0..$lev-1) {
+ return if $source->[$g][$w][$v] != $substr->[$g][$w][$v];
+ }
+ }
+ }
+ return 1;
+}
+
+##
+## (int position, int length)
+## int position = index(string, substring, position, [undoc'ed grobal])
+##
+## With "grobal" (only for the list context),
+## returns list of arrayref[position, length].
+##
+sub index
+{
+ my $self = shift;
+ my $str = shift;
+ my $len = length($str);
+ my $subCE = $self->splitCE(shift);
+ my $pos = @_ ? shift : 0;
+ $pos = 0 if $pos < 0;
+ my $grob = shift;
+
+ my $comb = $self->{combining};
+ my $lev = $self->{level};
+ my $ver9 = $self->{UCA_Version} > 8;
+ my $v2i = $self->{alternate} ne 'non-ignorable';
+
+ if (! @$subCE) {
+ my $temp = $pos <= 0 ? 0 : $len <= $pos ? $len : $pos;
+ return $grob
+ ? map([$_, 0], $temp..$len)
+ : wantarray ? ($temp,0) : $temp;
+ }
+ if ($len < $pos) {
+ return wantarray ? () : NOMATCHPOS;
+ }
+ my $strCE = $self->splitCE($pos ? substr($str, $pos) : $str, TRUE);
+ if (! @$strCE) {
+ return wantarray ? () : NOMATCHPOS;
+ }
+ my $last_is_variable;
+ my(@strWt, @iniPos, @finPos, @subWt, @g_ret);
+
+ $last_is_variable = FALSE;
+ for my $wt (map $self->getWt($_), @$subCE) {
+ my $to_be_pushed = _nonIgnorAtLevel($wt,$lev);
+
+ if ($v2i && $ver9) {
+ if ($wt->[0] == 0) {
+ $to_be_pushed = FALSE if $last_is_variable;
+ } else {
+ $last_is_variable = ($wt->[0] == Var1);
+ }
+ }
+
+ if (@subWt && $wt->[0] == 0) {
+ push @{ $subWt[-1] }, $wt if $to_be_pushed;
+ } else {
+ $wt->[0] = 0 if $wt->[0] == Var1;
+ push @subWt, [ $wt ];
+ }
+ }
+
+ my $count = 0;
+ my $end = @$strCE - 1;
+
+ $last_is_variable = FALSE;
+
+ for (my $i = 0; $i <= $end; ) { # no $i++
+ my $found_base = 0;
+
+ # fetch a grapheme
+ while ($i <= $end && $found_base == 0) {
+ for my $wt ($self->getWt($strCE->[$i][0])) {
+ my $to_be_pushed = _nonIgnorAtLevel($wt,$lev);
+
+ if ($v2i && $ver9) {
+ if ($wt->[0] == 0) {
+ $to_be_pushed = FALSE if $last_is_variable;
+ } else {
+ $last_is_variable = ($wt->[0] == Var1);
+ }
+ }
+
+ if (@strWt && $wt->[0] == 0) {
+ push @{ $strWt[-1] }, $wt if $to_be_pushed;
+ $finPos[-1] = $strCE->[$i][2];
+ } elsif ($to_be_pushed) {
+ $wt->[0] = 0 if $wt->[0] == Var1;
+ push @strWt, [ $wt ];
+ push @iniPos, $found_base ? NOMATCHPOS : $strCE->[$i][1];
+ $finPos[-1] = NOMATCHPOS if $found_base;
+ push @finPos, $strCE->[$i][2];
+ $found_base++;
+ }
+ # else ===> no-op
+ }
+ $i++;
+ }
+
+ # try to match
+ while ( @strWt > @subWt || (@strWt == @subWt && $i > $end) ) {
+ if ($iniPos[0] != NOMATCHPOS &&
+ $finPos[$#subWt] != NOMATCHPOS &&
+ _eqArray(\@strWt, \@subWt, $lev)) {
+ my $temp = $iniPos[0] + $pos;
+
+ if ($grob) {
+ push @g_ret, [$temp, $finPos[$#subWt] - $iniPos[0]];
+ splice @strWt, 0, $#subWt;
+ splice @iniPos, 0, $#subWt;
+ splice @finPos, 0, $#subWt;
+ }
+ else {
+ return wantarray
+ ? ($temp, $finPos[$#subWt] - $iniPos[0])
+ : $temp;
+ }
+ }
+ shift @strWt;
+ shift @iniPos;
+ shift @finPos;
+ }
+ }
+
+ return $grob
+ ? @g_ret
+ : wantarray ? () : NOMATCHPOS;
+}
+
+##
+## scalarref to matching part = match(string, substring)
+##
+sub match
+{
+ my $self = shift;
+ if (my($pos,$len) = $self->index($_[0], $_[1])) {
+ my $temp = substr($_[0], $pos, $len);
+ return wantarray ? $temp : \$temp;
+ # An lvalue ref \substr should be avoided,
+ # since its value is affected by modification of its referent.
+ }
+ else {
+ return;
+ }
+}
+
+##
+## arrayref matching parts = gmatch(string, substring)
+##
+sub gmatch
+{
+ my $self = shift;
+ my $str = shift;
+ my $sub = shift;
+ return map substr($str, $_->[0], $_->[1]),
+ $self->index($str, $sub, 0, 'g');
+}
+
+##
+## bool subst'ed = subst(string, substring, replace)
+##
+sub subst
+{
+ my $self = shift;
+ my $code = ref $_[2] eq 'CODE' ? $_[2] : FALSE;
+
+ if (my($pos,$len) = $self->index($_[0], $_[1])) {
+ if ($code) {
+ my $mat = substr($_[0], $pos, $len);
+ substr($_[0], $pos, $len, $code->($mat));
+ } else {
+ substr($_[0], $pos, $len, $_[2]);
+ }
+ return TRUE;
+ }
+ else {
+ return FALSE;
+ }
+}
+
+##
+## int count = gsubst(string, substring, replace)
+##
+sub gsubst
+{
+ my $self = shift;
+ my $code = ref $_[2] eq 'CODE' ? $_[2] : FALSE;
+ my $cnt = 0;
+
+ # Replacement is carried out from the end, then use reverse.
+ for my $pos_len (reverse $self->index($_[0], $_[1], 0, 'g')) {
+ if ($code) {
+ my $mat = substr($_[0], $pos_len->[0], $pos_len->[1]);
+ substr($_[0], $pos_len->[0], $pos_len->[1], $code->($mat));
+ } else {
+ substr($_[0], $pos_len->[0], $pos_len->[1], $_[2]);
+ }
+ $cnt++;
+ }
+ return $cnt;
+}
+
1;
__END__
=head1 DESCRIPTION
+This module is an implementation
+of Unicode Technical Standard #10 (UTS #10)
+"Unicode Collation Algorithm."
+
=head2 Constructor and Tailoring
The C<new> method returns a collator object.
=item alternate
--- see 3.2.2 Variable Weighting, UTR #10.
+-- see 3.2.2 Variable Weighting, UTS #10.
(the title in UCA version 8: Alternate Weighting)
These names are case-insensitive.
By default (if specification is omitted), 'shifted' is adopted.
- 'Blanked' Variable elements are ignorable at levels 1 through 3;
+ 'Blanked' Variable elements are made ignorable at levels 1 through 3;
considered at the 4th level.
'Non-ignorable' Variable elements are not reset to ignorable.
- 'Shifted' Variable elements are ignorable at levels 1 through 3
+ 'Shifted' Variable elements are made ignorable at levels 1 through 3
their level 4 weight is replaced by the old level 1 weight.
Level 4 weight for Non-Variable elements is 0xFFFF.
=item backwards
--- see 3.1.2 French Accents, UTR #10.
+-- see 3.1.2 French Accents, UTS #10.
backwards => $levelNumber or \@levelNumbers
=item entry
--- see 3.1 Linguistic Features; 3.2.1 File Format, UTR #10.
+-- see 3.1 Linguistic Features; 3.2.1 File Format, UTS #10.
Overrides a default order or defines additional collation elements
0043 0068 ; [.0893.0020.0008.0043] # "Ch" in traditional Spanish
ENTRIES
+B<NOTE:> The code point in the UCA file format (before C<';'>)
+B<must> be a Unicode code point, but not a native code point.
+So C<0063> must always denote C<U+0063>,
+but not a character of C<"\x63">.
+
=item ignoreName
=item ignoreChar
--- see Completely Ignorable, 3.2.2 Variable Weighting, UTR #10.
+-- see Completely Ignorable, 3.2.2 Variable Weighting, UTS #10.
Makes the entry in the table completely ignorable;
i.e. as if the weights were zero at all level.
=item level
--- see 4.3 Form a sort key for each string, UTR #10.
+-- see 4.3 Form a sort key for each string, UTS #10.
Set the maximum level.
Any higher levels than the specified one are ignored.
=item normalization
--- see 4.1 Normalize each input string, UTR #10.
+-- see 4.1 Normalize each input string, UTS #10.
If specified, strings are normalized before preparation of sort keys
(the normalization is executed after preprocess).
=item overrideCJK
--- see 7.1 Derived Collation Elements, UTR #10.
+-- see 7.1 Derived Collation Elements, UTS #10.
By default, mapping of CJK Unified Ideographs
uses the Unicode codepoint order.
=item overrideHangul
--- see 7.1 Derived Collation Elements, UTR #10.
+-- see 7.1 Derived Collation Elements, UTS #10.
By default, Hangul Syllables are decomposed into Hangul Jamo.
But the mapping of Hangul Syllables may be overrided.
=item preprocess
--- see 5.1 Preprocessing, UTR #10.
+-- see 5.1 Preprocessing, UTS #10.
If specified, the coderef is used to preprocess
before the formation of sort keys.
=item rearrange
--- see 3.1.3 Rearrangement, UTR #10.
+-- see 3.1.3 Rearrangement, UTS #10.
Characters that are not coded in logical order and to be rearranged.
By default,
=item table
--- see 3.2 Default Unicode Collation Element Table, UTR #10.
+-- see 3.2 Default Unicode Collation Element Table, UTS #10.
You can use another element table if desired.
The table file must be in your C<lib/Unicode/Collate> directory.
=item undefChar
--- see 6.3.4 Reducing the Repertoire, UTR #10.
+-- see 6.3.4 Reducing the Repertoire, UTS #10.
Undefines the collation element as if it were unassigned in the table.
This reduces the size of the table.
=item upper_before_lower
--- see 6.6 Case Comparisons; 7.3.1 Tertiary Weight Table, UTR #10.
+-- see 6.6 Case Comparisons; 7.3.1 Tertiary Weight Table, UTS #10.
By default, lowercase is before uppercase
and hiragana is before katakana.
B<NOTE>: These tags simplemindedly assume
any lowercase/uppercase or hiragana/katakana distinctions
should occur in level 3, and their weights at level 3
-should be same as those mentioned in 7.3.1, UTR #10.
+should be same as those mentioned in 7.3.1, UTS #10.
If you define your collation elements which violates this,
-these tags doesn't work validly.
+these tags don't work validly.
=back
=item C<$sortKey = $Collator-E<gt>getSortKey($string)>
--- see 4.3 Form a sort key for each string, UTR #10.
+-- see 4.3 Form a sort key for each string, UTS #10.
Returns a sort key.
(If C<UCA_Version> is 8, the output is slightly different.)
-=item C<$position = $Collator-E<gt>index($string, $substring)>
+=back
+
+=head2 Methods for Searching
-=item C<($position, $length) = $Collator-E<gt>index($string, $substring)>
+B<DISCLAIMER:> If C<preprocess> or C<normalization> tag is true
+for C<$Collator>, calling these methods (C<index>, C<match>, C<gmatch>,
+C<subst>, C<gsubst>) is croaked,
+as the position and the length might differ
+from those on the specified string.
+(And the C<rearrange> tag is neglected.)
--- see 6.8 Searching, UTR #10.
+The C<match>, C<gmatch>, C<subst>, C<gsubst> methods work
+like C<m//>, C<m//g>, C<s///>, C<s///g>, respectively,
+but they are not aware of any pattern, but only a literal substring.
+
+=over 4
+
+=item C<$position = $Collator-E<gt>index($string, $substring[, $position])>
+
+=item C<($position, $length) = $Collator-E<gt>index($string, $substring[, $position])>
If C<$substring> matches a part of C<$string>, returns
the position of the first occurrence of the matching part in scalar context;
in list context, returns a two-element list of
the position and the length of the matching part.
-B<Notice> that the length of the matching part may differ from
-the length of C<$substring>.
-
-B<Note> that the position and the length are counted on the string
-after the process of preprocess, normalization, and rearrangement.
-Therefore, in case the specified string is not binary equal to
-the preprocessed/normalized/rearranged string, the position and the length
-may differ form those on the specified string. But it is guaranteed
-that, if matched, it returns a non-negative value as C<$position>.
-
If C<$substring> does not match any part of C<$string>,
returns C<-1> in scalar context and
an empty list in list context.
e.g. you say
my $Collator = Unicode::Collate->new( normalization => undef, level => 1 );
- my $str = "Ich mu\x{00DF} studieren.";
- my $sub = "m\x{00FC}ss";
+ # (normalization => undef) is REQUIRED.
+ my $str = "Ich muß studieren Perl.";
+ my $sub = "MÜSS";
my $match;
if (my($pos,$len) = $Collator->index($str, $sub)) {
$match = substr($str, $pos, $len);
}
-and get C<"mu\x{00DF}"> in C<$match> since C<"mu>E<223>C<">
-is primary equal to C<"m>E<252>C<ss">.
+and get C<"muß"> in C<$match> since C<"muß">
+is primary equal to C<"MÜSS">.
+
+=item C<$match_ref = $Collator-E<gt>match($string, $substring)>
+
+=item C<($match) = $Collator-E<gt>match($string, $substring)>
+
+If C<$substring> matches a part of C<$string>, in scalar context, returns
+B<a reference to> the first occurrence of the matching part
+(C<$match_ref> is always true if matches,
+since every reference is B<true>);
+in list context, returns the first occurrence of the matching part.
+
+If C<$substring> does not match any part of C<$string>,
+returns C<undef> in scalar context and
+an empty list in list context.
+
+e.g.
+
+ if ($match_ref = $Collator->match($str, $sub)) { # scalar context
+ print "matches [$$match_ref].\n";
+ } else {
+ print "doesn't match.\n";
+ }
+
+ or
+
+ if (($match) = $Collator->match($str, $sub)) { # list context
+ print "matches [$match].\n";
+ } else {
+ print "doesn't match.\n";
+ }
+
+=item C<@match = $Collator-E<gt>gmatch($string, $substring)>
+
+If C<$substring> matches a part of C<$string>, returns
+all the matching parts (or matching count in scalar context).
+
+If C<$substring> does not match any part of C<$string>,
+returns an empty list.
+
+=item C<$count = $Collator-E<gt>subst($string, $substring, $replacement)>
+
+If C<$substring> matches a part of C<$string>,
+the first occurrence of the matching part is replaced by C<$replacement>
+(C<$string> is modified) and return C<$count> (always equals to C<1>).
+
+C<$replacement> can be a C<CODEREF>,
+taking the matching part as an argument,
+and returning a string to replace the matching part
+(a bit similar to C<s/(..)/$coderef-E<gt>($1)/e>).
+
+=item C<$count = $Collator-E<gt>gsubst($string, $substring, $replacement)>
+
+If C<$substring> matches a part of C<$string>,
+all the occurrences of the matching part is replaced by C<$replacement>
+(C<$string> is modified) and return C<$count>.
+
+C<$replacement> can be a C<CODEREF>,
+taking the matching part as an argument,
+and returning a string to replace the matching part
+(a bit similar to C<s/(..)/$coderef-E<gt>($1)/eg>).
+
+e.g.
+
+ my $Collator = Unicode::Collate->new( normalization => undef, level => 1 );
+ # (normalization => undef) is REQUIRED.
+ my $str = "Camel ass came\x{301}l CAMEL horse cAm\0E\0L...";
+ $Collator->gsubst($str, "camel", sub { "<b>$_[0]</b>" });
+
+ # now $str is "<b>Camel</b> ass <b>came\x{301}l</b> <b>CAMEL</b> horse <b>cAm\0E\0L</b>...";
+ # i.e., all the camels are made bold-faced.
=back
=item UCA_Version
-Returns the version number of Unicode Technical Standard 10
-this module consults.
+Returns the version number of UTS #10 this module consults.
=item Base_Unicode_Version
=head2 TODO
-Unicode::Collate has not been ported to EBCDIC. The code mostly would
-work just fine but a decision needs to be made: how the module should
-work in EBCDIC? Should the low 256 characters be understood as
-Unicode or as EBCDIC code points? Should one be chosen or should
-there be a way to do either? Or should such translation be left
-outside the module for the user to do, for example by using
-Encode::from_to()?
-(or utf8::unicode_to_native()/utf8::native_to_unicode()?)
+Unicode::Collate has not been ported to EBCDIC.
+IMHO, use of utf8::unicode_to_native()/utf8::native_to_unicode()
+at the proper postions should allow
+this module to work on EBCDIC platform...
=head2 CAVEAT
handle any combining characters),
assign C<normalization =E<gt> undef> explicitly.
--- see 6.5 Avoiding Normalization, UTR #10.
+-- see 6.5 Avoiding Normalization, UTS #10.
=head2 Conformance Test
for F<CollationTest_NON_IGNORABLE.txt>, a collator via
C<Unicode::Collate-E<gt>new(alternate =E<gt> "non-ignorable", level =E<gt> 3)>.
-B<Unicode::Normalize is required to try this test.>
-
-=head2 BUGS
-
-C<index()> is an experimental method and
-its return value may be unreliable.
-The correct implementation for C<index()> must be based
-on Locale-Sensitive Support: Level 3 in UTR #18,
-F<Unicode Regular Expression Guidelines>.
-
-See also 4.2 Locale-Dependent Graphemes in UTR #18.
+B<Unicode::Normalize is required to try The Conformance Test.>
=head1 AUTHOR
=item http://www.unicode.org/reports/tr10/
-Unicode Collation Algorithm - UTR #10
+Unicode Collation Algorithm - UTS #10
=item http://www.unicode.org/reports/tr10/allkeys.txt
Unicode Normalization Forms - UAX #15
-=item http://www.unicode.org/reports/tr18
-
-Unicode Regular Expression Guidelines - UTR #18
-
=item L<Unicode::Normalize>
=back
--- /dev/null
+
+BEGIN {
+ if (ord("A") == 193) {
+ print "1..0 # Unicode::Collate not ported to EBCDIC\n";
+ exit 0;
+ }
+}
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir('t') if -d 't';
+ @INC = qw(../lib);
+ }
+}
+
+use Test;
+BEGIN { plan tests => 65 };
+use Unicode::Collate;
+
+our $IsEBCDIC = ord("A") != 0x41;
+
+#########################
+
+ok(1); # If we made it this far, we're ok.
+
+my $Collator = Unicode::Collate->new(
+ table => 'keys.txt',
+ normalization => undef,
+);
+
+##############
+
+my %old_level = $Collator->change(level => 2);
+
+my $str;
+
+my $orig = "This is a Perl book.";
+my $sub = "PERL";
+my $rep = "camel";
+my $ret = "This is a camel book.";
+
+$str = $orig;
+if (my($pos,$len) = $Collator->index($str, $sub)) {
+ substr($str, $pos, $len, $rep);
+}
+
+ok($str, $ret);
+
+$Collator->change(%old_level);
+
+$str = $orig;
+if (my($pos,$len) = $Collator->index($str, $sub)) {
+ substr($str, $pos, $len, $rep);
+}
+
+ok($str, $orig);
+
+##############
+
+my $match;
+
+$Collator->change(level => 1);
+
+$str = "Pe\x{300}rl";
+$sub = "pe";
+$ret = "Pe\x{300}";
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, $ret);
+
+$str = "P\x{300}e\x{300}\x{301}\x{303}rl";
+$sub = "pE";
+$ret = "P\x{300}e\x{300}\x{301}\x{303}";
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, $ret);
+
+$Collator->change(level => 2);
+
+$str = "Pe\x{300}rl";
+$sub = "pe";
+$ret = undef;
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, $ret);
+
+$str = "P\x{300}e\x{300}\x{301}\x{303}rl";
+$sub = "pE";
+$ret = undef;
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, $ret);
+
+$str = "Pe\x{300}rl";
+$sub = "pe\x{300}";
+$ret = "Pe\x{300}";
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, $ret);
+
+$str = "P\x{300}e\x{300}\x{301}\x{303}rl";
+$sub = "p\x{300}E\x{300}\x{301}\x{303}";
+$ret = "P\x{300}e\x{300}\x{301}\x{303}";
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, $ret);
+
+##############
+
+$Collator->change(level => 1);
+
+$str = $IsEBCDIC
+ ? "Ich mu\x{0059} studieren Perl."
+ : "Ich mu\x{00DF} studieren Perl.";
+$sub = $IsEBCDIC
+ ? "m\x{00DC}ss"
+ : "m\x{00FC}ss";
+$ret = $IsEBCDIC
+ ? "mu\x{0059}"
+ : "mu\x{00DF}";
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, $ret);
+
+$Collator->change(%old_level);
+
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, undef);
+
+$match = undef;
+if (my($pos,$len) = $Collator->index("", "")) {
+ $match = substr("", $pos, $len);
+}
+ok($match, "");
+
+$match = undef;
+if (my($pos,$len) = $Collator->index("", "abc")) {
+ $match = substr("", $pos, $len);
+}
+ok($match, undef);
+
+##############
+
+$Collator->change(level => 1);
+
+$str = "\0\cA\0\cAe\0\x{300}\cA\x{301}\cB\x{302}\0 \0\cA";
+$sub = "e";
+$ret = "e\0\x{300}\cA\x{301}\cB\x{302}\0";
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, $ret);
+
+$Collator->change(level => 1);
+
+$str = "\0\cA\0\cAe\0\cA\x{300}\0\cAe";
+$sub = "e";
+$ret = "e\0\cA\x{300}\0\cA";
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, $ret);
+
+
+$Collator->change(%old_level);
+
+$str = "e\x{300}";
+$sub = "e";
+$ret = undef;
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, $ret);
+
+##############
+
+$Collator->change(level => 1);
+
+$str = "The Perl is a language, and the perl is an interpreter.";
+$sub = "PERL";
+
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub, -40)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, "Perl");
+
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub, 4)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, "Perl");
+
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub, 5)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, "perl");
+
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub, 32)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, "perl");
+
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub, 33)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, undef);
+
+$match = undef;
+if (my($pos, $len) = $Collator->index($str, $sub, 100)) {
+ $match = substr($str, $pos, $len);
+}
+ok($match, undef);
+
+$Collator->change(%old_level);
+
+##############
+
+my @ret;
+
+$Collator->change(level => 1);
+
+$ret = $Collator->match("P\cBe\x{300}\cBrl and PERL", "pe");
+ok($ret);
+ok($$ret eq "P\cBe\x{300}\cB");
+
+@ret = $Collator->match("P\cBe\x{300}\cBrl and PERL", "pe");
+ok($ret[0], "P\cBe\x{300}\cB");
+
+$str = $IsEBCDIC ? "mu\x{0059}" : "mu\x{00DF}";
+$sub = $IsEBCDIC ? "m\x{00DC}ss" : "m\x{00FC}ss";
+
+($ret) = $Collator->match($str, $sub);
+ok($ret, $str);
+
+$str = $IsEBCDIC ? "mu\x{0059}" : "mu\x{00DF}";
+$sub = $IsEBCDIC ? "m\x{00DC}s" : "m\x{00FC}s";
+
+($ret) = $Collator->match($str, $sub);
+ok($ret, undef);
+
+$ret = join ':', $Collator->gmatch("P\cBe\x{300}\cBrl, perl, and PERL", "pe");
+ok($ret eq "P\cBe\x{300}\cB:pe:PE");
+
+$ret = $Collator->gmatch("P\cBe\x{300}\cBrl, perl, and PERL", "pe");
+ok($ret == 3);
+
+$str = "ABCDEF";
+$sub = "cde";
+$ret = $Collator->match($str, $sub);
+$str = "01234567";
+ok($ret && $$ret, "CDE");
+
+$str = "ABCDEF";
+$sub = "cde";
+($ret) = $Collator->match($str, $sub);
+$str = "01234567";
+ok($ret, "CDE");
+
+
+$Collator->change(level => 3);
+
+$ret = $Collator->match("P\cBe\x{300}\cBrl and PERL", "pe");
+ok($ret, undef);
+
+@ret = $Collator->match("P\cBe\x{300}\cBrl and PERL", "pe");
+ok(@ret == 0);
+
+$ret = join ':', $Collator->gmatch("P\cBe\x{300}\cBrl and PERL", "pe");
+ok($ret eq "");
+
+$ret = $Collator->gmatch("P\cBe\x{300}\cBrl and PERL", "pe");
+ok($ret == 0);
+
+$ret = join ':', $Collator->gmatch("P\cBe\x{300}\cBrl, perl, and PERL", "pe");
+ok($ret eq "pe");
+
+$ret = $Collator->gmatch("P\cBe\x{300}\cBrl, perl, and PERL", "pe");
+ok($ret == 1);
+
+$str = $IsEBCDIC ? "mu\x{0059}" : "mu\x{00DF}";
+$sub = $IsEBCDIC ? "m\x{00DC}ss" : "m\x{00FC}ss";
+
+($ret) = $Collator->match($str, $sub);
+ok($ret, undef);
+
+$Collator->change(%old_level);
+
+##############
+
+$Collator->change(level => 1);
+
+sub strreverse { scalar reverse shift }
+
+$str = "P\cBe\x{300}\cBrl and PERL.";
+$ret = $Collator->subst($str, "perl", 'Camel');
+ok($ret, 1);
+ok($str, "Camel and PERL.");
+
+$str = "P\cBe\x{300}\cBrl and PERL.";
+$ret = $Collator->subst($str, "perl", \&strreverse);
+ok($ret, 1);
+ok($str, "lr\cB\x{300}e\cBP and PERL.");
+
+$str = "P\cBe\x{300}\cBrl and PERL.";
+$ret = $Collator->gsubst($str, "perl", 'Camel');
+ok($ret, 2);
+ok($str, "Camel and Camel.");
+
+$str = "P\cBe\x{300}\cBrl and PERL.";
+$ret = $Collator->gsubst($str, "perl", \&strreverse);
+ok($ret, 2);
+ok($str, "lr\cB\x{300}e\cBP and LREP.");
+
+$str = "Camel ass came\x{301}l CAMEL horse cAm\0E\0L...";
+$Collator->gsubst($str, "camel", sub { "<b>$_[0]</b>" });
+ok($str,
+"<b>Camel</b> ass <b>came\x{301}l</b> <b>CAMEL</b> horse <b>cAm\0E\0L</b>...");
+
+$Collator->change(level => 3);
+
+$str = "P\cBe\x{300}\cBrl and PERL.";
+$ret = $Collator->subst($str, "perl", "Camel");
+ok(! $ret);
+ok($str, "P\cBe\x{300}\cBrl and PERL.");
+
+$str = "P\cBe\x{300}\cBrl and PERL.";
+$ret = $Collator->subst($str, "perl", \&strreverse);
+ok(! $ret);
+ok($str, "P\cBe\x{300}\cBrl and PERL.");
+
+$str = "P\cBe\x{300}\cBrl and PERL.";
+$ret = $Collator->gsubst($str, "perl", "Camel");
+ok($ret, 0);
+ok($str, "P\cBe\x{300}\cBrl and PERL.");
+
+$str = "P\cBe\x{300}\cBrl and PERL.";
+$ret = $Collator->gsubst($str, "perl", \&strreverse);
+ok($ret, 0);
+ok($str, "P\cBe\x{300}\cBrl and PERL.");
+
+$Collator->change(%old_level);
+
+##############
+
+$str = "Perl and Camel";
+$ret = $Collator->gsubst($str, "\cA\cA\0", "AB");
+ok($ret, 15);
+ok($str, "ABPABeABrABlAB ABaABnABdAB ABCABaABmABeABlAB");
+
+$str = '';
+$ret = $Collator->subst($str, "", "ABC");
+ok($ret, 1);
+ok($str, "ABC");
+
+$str = '';
+$ret = $Collator->gsubst($str, "", "ABC");
+ok($ret, 1);
+ok($str, "ABC");
+
+$str = 'PPPPP';
+$ret = $Collator->gsubst($str, 'PP', "ABC");
+ok($ret, 2);
+ok($str, "ABCABCP");
+
+##############
+
+# Shifted; ignorable after variable
+
+($ret) = $Collator->match("A?\x{300}!\x{301}\x{344}B\x{315}", "?!");
+ok($ret, "?\x{300}!\x{301}\x{344}");
+
+$Collator->change(alternate => 'Non-ignorable');
+
+($ret) = $Collator->match("A?\x{300}!\x{301}B\x{315}", "?!");
+ok($ret, undef);
}
use Test;
-BEGIN { plan tests => 184 };
+BEGIN { plan tests => 194 };
use Unicode::Collate;
+our $IsEBCDIC = ord("A") != 0x41;
+
#########################
ok(1); # If we made it this far, we're ok.
##############
-my $A_acute = pack('U', 0x00C1);
-my $a_acute = pack('U', 0x00E1);
+# Use pack('U'), not chr(), for Perl 5.6.1.
+my $A_acute = pack('U', $IsEBCDIC ? 0x65 : 0xC1);
+my $a_acute = pack('U', $IsEBCDIC ? 0x45 : 0xE1);
my $acute = pack('U', 0x0301);
ok($Collator->cmp("A$acute", $A_acute), 0); # @version 3.1.1 (prev: -1)
ok($Collator->cmp($a_acute, $A_acute), -1);
-ok($Collator->eq("A\cA$acute", $A_acute)); # UCA v9
+ok($Collator->eq("A\cA$acute", $A_acute)); # UCA v9. \cA is invariant.
my %old_level = $Collator->change(level => 1);
ok($Collator->eq("A$acute", $A_acute));
eval { require Unicode::Normalize };
-if (!$@) {
+if (!$@ && !$IsEBCDIC) {
my $NFD = Unicode::Collate->new(
table => undef,
entry => <<'ENTRIES',
entry => << 'ENTRIES',
0063 0068 ; [.0A3F.0020.0002.0063] % "ch" in traditional Spanish
0043 0068 ; [.0A3F.0020.0008.0043] # "Ch" in traditional Spanish
- 00DF ; [.0BA7.0020.0004.00DF][.0000.0153.0004.00DF][.0BA7.0020.001F.00DF] # sz
ENTRIES
);
# 0063 ; [.0A3D.0020.0002.0063] # LATIN SMALL LETTER C
# 0064 ; [.0A49.0020.0002.0064] # LATIN SMALL LETTER D
-# 0073 ; [.0BA7.0020.0002.0073] # LATIN SMALL LETTER S
+# Deutsch sz is included in 'keys.txt';
ok(
join(':', $trad->sort( qw/ acha aca ada acia acka / ) ),
join(':', qw/ aca acha acia acka ada / ),
);
ok($trad->eq("ocho", "oc\cAho")); # UCA v9
-ok($trad->eq("ocho", "oc\000\cA\000\x7Fho")); # UCA v9
+ok($trad->eq("ocho", "oc\0\cA\0\cBho")); # UCA v9
my $hiragana = "\x{3042}\x{3044}";
my $katakana = "\x{30A2}\x{30A4}";
##############
-$Collator->change(level => 2);
-
-my $str;
-
-my $orig = "This is a Perl book.";
-my $sub = "PERL";
-my $rep = "camel";
-my $ret = "This is a camel book.";
-
-$str = $orig;
-if (my($pos,$len) = $Collator->index($str, $sub)) {
- substr($str, $pos, $len, $rep);
-}
-
-ok($str, $ret);
-
-$Collator->change(%old_level);
-
-$str = $orig;
-if (my($pos,$len) = $Collator->index($str, $sub)) {
- substr($str, $pos, $len, $rep);
-}
-
-ok($str, $orig);
-
-##############
-
-my $match;
-
-$Collator->change(level => 1);
-
-$str = "Pe\x{300}rl";
-$sub = "pe";
-$match = undef;
-if (my($pos, $len) = $Collator->index($str, $sub)) {
- $match = substr($str, $pos, $len);
-}
-ok($match, "Pe\x{300}");
-
-$str = "P\x{300}e\x{300}\x{301}\x{303}rl";
-$sub = "pE";
-$match = undef;
-if (my($pos, $len) = $Collator->index($str, $sub)) {
- $match = substr($str, $pos, $len);
-}
-ok($match, "P\x{300}e\x{300}\x{301}\x{303}");
-
-$Collator->change(%old_level);
-
-##############
-
-%old_level = $trad->change(level => 1);
-
-$str = "Ich mu\x{00DF} studieren.";
-$sub = "m\x{00FC}ss";
-$match = undef;
-if (my($pos, $len) = $trad->index($str, $sub)) {
- $match = substr($str, $pos, $len);
-}
-ok($match, "mu\x{00DF}");
-
-$trad->change(%old_level);
-
-$str = "Ich mu\x{00DF} studieren.";
-$sub = "m\x{00FC}ss";
-$match = undef;
-
-if (my($pos, $len) = $trad->index($str, $sub)) {
- $match = substr($str, $pos, $len);
-}
-ok($match, undef);
-
-$match = undef;
-if (my($pos,$len) = $Collator->index("", "")) {
- $match = substr("", $pos, $len);
-}
-ok($match, "");
-
-$match = undef;
-if (my($pos,$len) = $Collator->index("", "abc")) {
- $match = substr("", $pos, $len);
-}
-ok($match, undef);
-
-##############
-
# Table is undefined, then no entry is defined.
my $undef_table = Unicode::Collate->new(
ok($Collator->gt("\x{0E41}A", "\x{0E40}B"));
ok($Collator->gt("A\x{0E41}A", "A\x{0E40}B"));
-$Collator->change(rearrange => [ 0x61 ]); # 'a'
+$Collator->change(rearrange => [ 0x61 ]);
+ # U+0061, 'a': This is a Unicode value, never a native value.
ok($Collator->gt("ab", "AB")); # as 'ba' > 'AB'
ok($Collator ->lt("Ca\x{300}ca\x{302}", "ca\x{302}ca\x{300}"));
ok($Collator ->lt("ca\x{300}ca\x{302}", "Ca\x{302}ca\x{300}"));
-
# HIRAGANA and KATAKANA are made undefined via undefName.
# So they are after CJK Unified Ideographs.
##############
-# Shifted; ignorable after variable
+# ignorable after variable
+# Shifted;
ok($Collator->eq("?\x{300}!\x{301}\x{315}", "?!"));
-ok($Collator->eq("?\x{300}A\x{300}", "?A\x{300}"));
+ok($Collator->eq("?\x{300}A\x{301}", "?$A_acute"));
ok($Collator->eq("?\x{300}", "?"));
+ok($Collator->eq("?\x{344}", "?")); # U+0344 has two CEs.
-$Collator->change(alternate => 'Non-ignorable');
+$Collator->change(level => 3);
+ok($Collator->eq("\cA", "?"));
+
+$Collator->change(alternate => 'blanked', level => 4);
+ok($Collator->eq("?\x{300}!\x{301}\x{315}", "?!"));
+ok($Collator->eq("?\x{300}A\x{301}", "?$A_acute"));
+ok($Collator->eq("?\x{300}", "?"));
+ok($Collator->eq("?\x{344}", "?")); # U+0344 has two CEs.
+
+$Collator->change(level => 3);
+ok($Collator->eq("\cA", "?"));
+$Collator->change(alternate => 'Non-ignorable', level => 4);
+
+ok($Collator->lt("?\x{300}", "?!"));
+ok($Collator->gt("?\x{300}A$acute", "?$A_acute"));
ok($Collator->gt("?\x{300}", "?"));
+ok($Collator->gt("?\x{344}", "?"));
-$Collator->change(alternate => 'Shifted');
+$Collator->change(level => 3);
+ok($Collator->lt("\cA", "?"));
+
+$Collator->change(alternate => 'Shifted', level => 4);
+
+##############
+
+# According to Conformance Test,
+# a L3-ignorable is treated as a completely ignorable.
+
+my $L3ignorable = Unicode::Collate->new(
+ alternate => 'Non-ignorable',
+ table => undef,
+ normalization => undef,
+ entry => <<'ENTRIES',
+0000 ; [.0000.0000.0000.0000] # [0000] NULL (in 6429)
+0001 ; [.0000.0000.0000.0000] # [0001] START OF HEADING (in 6429)
+0591 ; [.0000.0000.0000.0591] # HEBREW ACCENT ETNAHTA
+1D165 ; [.0000.0000.0000.1D165] # MUSICAL SYMBOL COMBINING STEM
+0021 ; [*024B.0020.0002.0021] # EXCLAMATION MARK
+09BE ; [.114E.0020.0002.09BE] # BENGALI VOWEL SIGN AA
+09C7 ; [.1157.0020.0002.09C7] # BENGALI VOWEL SIGN E
+09CB ; [.1159.0020.0002.09CB] # BENGALI VOWEL SIGN O
+09C7 09BE ; [.1159.0020.0002.09CB] # BENGALI VOWEL SIGN O
+ENTRIES
+);
+
+ok($L3ignorable->lt("\cA", "!"));
+ok($L3ignorable->lt("\x{591}", "!"));
+ok($L3ignorable->eq("\cA", "\x{591}"));
+ok($L3ignorable->eq("\x{09C7}\x{09BE}A", "\x{09C7}\cA\x{09BE}A"));
+ok($L3ignorable->eq("\x{09C7}\x{09BE}A", "\x{09C7}\x{0591}\x{09BE}A"));
+ok($L3ignorable->eq("\x{09C7}\x{09BE}A", "\x{09C7}\x{1D165}\x{09BE}A"));
+ok($L3ignorable->eq("\x{09C7}\x{09BE}A", "\x{09CB}A"));
projects / p5sagit/p5-mst-13.2.git / commitdiff