This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Unicode-Collate to CPAN version 0.71
[perl5.git] / cpan / Unicode-Collate / Collate.pm
1 package Unicode::Collate;
2
3 BEGIN {
4     unless ("A" eq pack('U', 0x41)) {
5         die "Unicode::Collate cannot stringify a Unicode code point\n";
6     }
7 }
8
9 use 5.006;
10 use strict;
11 use warnings;
12 use Carp;
13 use File::Spec;
14
15 no warnings 'utf8';
16
17 our $VERSION = '0.71';
18 our $PACKAGE = __PACKAGE__;
19
20 require DynaLoader;
21 our @ISA = qw(DynaLoader);
22 bootstrap Unicode::Collate $VERSION;
23
24 my @Path = qw(Unicode Collate);
25 my $KeyFile = "allkeys.txt";
26
27 # Perl's boolean
28 use constant TRUE  => 1;
29 use constant FALSE => "";
30 use constant NOMATCHPOS => -1;
31
32 # A coderef to get combining class imported from Unicode::Normalize
33 # (i.e. \&Unicode::Normalize::getCombinClass).
34 # This is also used as a HAS_UNICODE_NORMALIZE flag.
35 my $CVgetCombinClass;
36
37 # Supported Levels
38 use constant MinLevel => 1;
39 use constant MaxLevel => 4;
40
41 # Minimum weights at level 2 and 3, respectively
42 use constant Min2Wt => 0x20;
43 use constant Min3Wt => 0x02;
44
45 # Shifted weight at 4th level
46 use constant Shift4Wt => 0xFFFF;
47
48 # A boolean for Variable and 16-bit weights at 4 levels of Collation Element
49 # PROBLEM: The Default Unicode Collation Element Table
50 # has weights over 0xFFFF at the 4th level.
51 # The tie-breaking in the variable weights
52 # other than "shift" (as well as "shift-trimmed") is unreliable.
53 use constant VCE_TEMPLATE => 'Cn4';
54
55 # A sort key: 16-bit weights
56 # See also the PROBLEM on VCE_TEMPLATE above.
57 use constant KEY_TEMPLATE => 'n*';
58
59 # Level separator in a sort key:
60 # i.e. pack(KEY_TEMPLATE, 0)
61 use constant LEVEL_SEP => "\0\0";
62
63 # As Unicode code point separator for hash keys.
64 # A joined code point string (denoted by JCPS below)
65 # like "65;768" is used for internal processing
66 # instead of Perl's Unicode string like "\x41\x{300}",
67 # as the native code point is different from the Unicode code point
68 # on EBCDIC platform.
69 # This character must not be included in any stringified
70 # representation of an integer.
71 use constant CODE_SEP => ';';
72
73 # boolean values of variable weights
74 use constant NON_VAR => 0; # Non-Variable character
75 use constant VAR     => 1; # Variable character
76
77 # specific code points
78 use constant Hangul_SIni   => 0xAC00;
79 use constant Hangul_SFin   => 0xD7A3;
80
81 # Logical_Order_Exception in PropList.txt
82 my $DefaultRearrange = [ 0x0E40..0x0E44, 0x0EC0..0x0EC4 ];
83
84 sub UCA_Version { "20" }
85
86 sub Base_Unicode_Version { "5.2.0" }
87
88 ######
89
90 sub pack_U {
91     return pack('U*', @_);
92 }
93
94 ######
95
96 my (%VariableOK);
97 @VariableOK{ qw/
98     blanked  non-ignorable  shifted  shift-trimmed
99   / } = (); # keys lowercased
100
101 our @ChangeOK = qw/
102     alternate backwards level normalization rearrange
103     katakana_before_hiragana upper_before_lower
104     overrideHangul overrideCJK preprocess UCA_Version
105     hangul_terminator variable
106   /;
107
108 our @ChangeNG = qw/
109     entry mapping table maxlength contraction
110     ignoreChar ignoreName undefChar undefName variableTable
111     versionTable alternateTable backwardsTable forwardsTable rearrangeTable
112     derivCode normCode rearrangeHash backwardsFlag
113     suppress suppressHash
114     __useXS
115   /;
116 # The hash key 'ignored' is deleted at v 0.21.
117 # The hash key 'isShift' is deleted at v 0.23.
118 # The hash key 'combining' is deleted at v 0.24.
119 # The hash key 'entries' is deleted at v 0.30.
120 # The hash key 'L3_ignorable' is deleted at v 0.40.
121
122 sub version {
123     my $self = shift;
124     return $self->{versionTable} || 'unknown';
125 }
126
127 my (%ChangeOK, %ChangeNG);
128 @ChangeOK{ @ChangeOK } = ();
129 @ChangeNG{ @ChangeNG } = ();
130
131 sub change {
132     my $self = shift;
133     my %hash = @_;
134     my %old;
135     if (exists $hash{variable} && exists $hash{alternate}) {
136         delete $hash{alternate};
137     }
138     elsif (!exists $hash{variable} && exists $hash{alternate}) {
139         $hash{variable} = $hash{alternate};
140     }
141     foreach my $k (keys %hash) {
142         if (exists $ChangeOK{$k}) {
143             $old{$k} = $self->{$k};
144             $self->{$k} = $hash{$k};
145         }
146         elsif (exists $ChangeNG{$k}) {
147             croak "change of $k via change() is not allowed!";
148         }
149         # else => ignored
150     }
151     $self->checkCollator();
152     return wantarray ? %old : $self;
153 }
154
155 sub _checkLevel {
156     my $level = shift;
157     my $key   = shift; # 'level' or 'backwards'
158     MinLevel <= $level or croak sprintf
159         "Illegal level %d (in value for key '%s') lower than %d.",
160             $level, $key, MinLevel;
161     $level <= MaxLevel or croak sprintf
162         "Unsupported level %d (in value for key '%s') higher than %d.",
163             $level, $key, MaxLevel;
164 }
165
166 my %DerivCode = (
167     8 => \&_derivCE_8,
168     9 => \&_derivCE_9,
169    11 => \&_derivCE_9, # 11 == 9
170    14 => \&_derivCE_14,
171    16 => \&_derivCE_14, # 16 == 14
172    18 => \&_derivCE_18,
173    20 => \&_derivCE_20,
174    22 => \&_derivCE_22,
175 );
176
177 sub checkCollator {
178     my $self = shift;
179     _checkLevel($self->{level}, "level");
180
181     $self->{derivCode} = $DerivCode{ $self->{UCA_Version} }
182         or croak "Illegal UCA version (passed $self->{UCA_Version}).";
183
184     $self->{variable} ||= $self->{alternate} || $self->{variableTable} ||
185                                 $self->{alternateTable} || 'shifted';
186     $self->{variable} = $self->{alternate} = lc($self->{variable});
187     exists $VariableOK{ $self->{variable} }
188         or croak "$PACKAGE unknown variable parameter name: $self->{variable}";
189
190     if (! defined $self->{backwards}) {
191         $self->{backwardsFlag} = 0;
192     }
193     elsif (! ref $self->{backwards}) {
194         _checkLevel($self->{backwards}, "backwards");
195         $self->{backwardsFlag} = 1 << $self->{backwards};
196     }
197     else {
198         my %level;
199         $self->{backwardsFlag} = 0;
200         for my $b (@{ $self->{backwards} }) {
201             _checkLevel($b, "backwards");
202             $level{$b} = 1;
203         }
204         for my $v (sort keys %level) {
205             $self->{backwardsFlag} += 1 << $v;
206         }
207     }
208
209     defined $self->{rearrange} or $self->{rearrange} = [];
210     ref $self->{rearrange}
211         or croak "$PACKAGE: list for rearrangement must be store in ARRAYREF";
212
213     # keys of $self->{rearrangeHash} are $self->{rearrange}.
214     $self->{rearrangeHash} = undef;
215
216     if (@{ $self->{rearrange} }) {
217         @{ $self->{rearrangeHash} }{ @{ $self->{rearrange} } } = ();
218     }
219
220     $self->{normCode} = undef;
221
222     if (defined $self->{normalization}) {
223         eval { require Unicode::Normalize };
224         $@ and croak "Unicode::Normalize is required to normalize strings";
225
226         $CVgetCombinClass ||= \&Unicode::Normalize::getCombinClass;
227
228         if ($self->{normalization} =~ /^(?:NF)D\z/) { # tweak for default
229             $self->{normCode} = \&Unicode::Normalize::NFD;
230         }
231         elsif ($self->{normalization} ne 'prenormalized') {
232             my $norm = $self->{normalization};
233             $self->{normCode} = sub {
234                 Unicode::Normalize::normalize($norm, shift);
235             };
236             eval { $self->{normCode}->("") }; # try
237             $@ and croak "$PACKAGE unknown normalization form name: $norm";
238         }
239     }
240     return;
241 }
242
243 sub new
244 {
245     my $class = shift;
246     my $self = bless { @_ }, $class;
247
248     if (! exists $self->{table} &&
249         !defined $self->{undefName} && !defined $self->{ignoreName} &&
250         !defined $self->{undefChar} && !defined $self->{ignoreChar}) {
251         $self->{__useXS} = \&_fetch_simple;
252     } # XS only
253
254     # keys of $self->{suppressHash} are $self->{suppress}.
255     if ($self->{suppress} && @{ $self->{suppress} }) {
256         @{ $self->{suppressHash} }{ @{ $self->{suppress} } } = ();
257     } # before read_table()
258
259     # If undef is passed explicitly, no file is read.
260     $self->{table} = $KeyFile if ! exists $self->{table};
261     $self->read_table() if defined $self->{table};
262
263     if ($self->{entry}) {
264         while ($self->{entry} =~ /([^\n]+)/g) {
265             $self->parseEntry($1);
266         }
267     }
268
269     $self->{level} ||= MaxLevel;
270     $self->{UCA_Version} ||= UCA_Version();
271
272     $self->{overrideHangul} = FALSE
273         if ! exists $self->{overrideHangul};
274     $self->{overrideCJK} = FALSE
275         if ! exists $self->{overrideCJK};
276     $self->{normalization} = 'NFD'
277         if ! exists $self->{normalization};
278     $self->{rearrange} = $self->{rearrangeTable} ||
279         ($self->{UCA_Version} <= 11 ? $DefaultRearrange : [])
280         if ! exists $self->{rearrange};
281     $self->{backwards} = $self->{backwardsTable}
282         if ! exists $self->{backwards};
283
284     $self->checkCollator();
285
286     return $self;
287 }
288
289 sub parseAtmark {
290     my $self = shift;
291     my $line = shift; # after s/^\s*\@//
292
293     if ($line =~ /^version\s*(\S*)/) {
294         $self->{versionTable} ||= $1;
295     }
296     elsif ($line =~ /^variable\s+(\S*)/) { # since UTS #10-9
297         $self->{variableTable} ||= $1;
298     }
299     elsif ($line =~ /^alternate\s+(\S*)/) { # till UTS #10-8
300         $self->{alternateTable} ||= $1;
301     }
302     elsif ($line =~ /^backwards\s+(\S*)/) {
303         push @{ $self->{backwardsTable} }, $1;
304     }
305     elsif ($line =~ /^forwards\s+(\S*)/) { # parhaps no use
306         push @{ $self->{forwardsTable} }, $1;
307     }
308     elsif ($line =~ /^rearrange\s+(.*)/) { # (\S*) is NG
309         push @{ $self->{rearrangeTable} }, _getHexArray($1);
310     }
311 }
312
313 sub read_table {
314     my $self = shift;
315
316     if ($self->{__useXS}) {
317         my @rest = _fetch_rest(); # complex matter need to parse
318         for my $line (@rest) {
319             next if $line =~ /^\s*#/;
320
321             if ($line =~ s/^\s*\@//) {
322                 $self->parseAtmark($line);
323             } else {
324                 $self->parseEntry($line);
325             }
326         }
327         return;
328     }
329
330     my($f, $fh);
331     foreach my $d (@INC) {
332         $f = File::Spec->catfile($d, @Path, $self->{table});
333         last if open($fh, $f);
334         $f = undef;
335     }
336     if (!defined $f) {
337         $f = File::Spec->catfile(@Path, $self->{table});
338         croak("$PACKAGE: Can't locate $f in \@INC (\@INC contains: @INC)");
339     }
340
341     while (my $line = <$fh>) {
342         next if $line =~ /^\s*#/;
343
344         if ($line =~ s/^\s*\@//) {
345             $self->parseAtmark($line);
346         } else {
347             $self->parseEntry($line);
348         }
349     }
350     close $fh;
351 }
352
353
354 ##
355 ## get $line, parse it, and write an entry in $self
356 ##
357 sub parseEntry
358 {
359     my $self = shift;
360     my $line = shift;
361     my($name, $entry, @uv, @key);
362
363     return if $line !~ /^\s*[0-9A-Fa-f]/;
364
365     # removes comment and gets name
366     $name = $1
367         if $line =~ s/[#%]\s*(.*)//;
368     return if defined $self->{undefName} && $name =~ /$self->{undefName}/;
369
370     # gets element
371     my($e, $k) = split /;/, $line;
372     croak "Wrong Entry: <charList> must be separated by ';' from <collElement>"
373         if ! $k;
374
375     @uv = _getHexArray($e);
376     return if !@uv;
377     return if @uv > 1 && $self->{suppressHash} &&
378                   exists $self->{suppressHash}{$uv[0]};
379     $entry = join(CODE_SEP, @uv); # in JCPS
380
381     if (defined $self->{undefChar} || defined $self->{ignoreChar}) {
382         my $ele = pack_U(@uv);
383
384         # regarded as if it were not entried in the table
385         return
386             if defined $self->{undefChar} && $ele =~ /$self->{undefChar}/;
387
388         # replaced as completely ignorable
389         $k = '[.0000.0000.0000.0000]'
390             if defined $self->{ignoreChar} && $ele =~ /$self->{ignoreChar}/;
391     }
392
393     # replaced as completely ignorable
394     $k = '[.0000.0000.0000.0000]'
395         if defined $self->{ignoreName} && $name =~ /$self->{ignoreName}/;
396
397     my $is_L3_ignorable = TRUE;
398
399     foreach my $arr ($k =~ /\[([^\[\]]+)\]/g) { # SPACEs allowed
400         my $var = $arr =~ /\*/; # exactly /^\*/ but be lenient.
401         my @wt = _getHexArray($arr);
402         push @key, pack(VCE_TEMPLATE, $var, @wt);
403         $is_L3_ignorable = FALSE
404             if $wt[0] || $wt[1] || $wt[2];
405         # Conformance Test for 3.1.1 and 4.0.0 shows Level 3 ignorable
406         # is completely ignorable.
407         # For expansion, an entry $is_L3_ignorable
408         # if and only if "all" CEs are [.0000.0000.0000].
409     }
410
411     $self->{mapping}{$entry} = $is_L3_ignorable ? [] : \@key;
412
413     if (@uv > 1) {
414         if (!$self->{maxlength}{$uv[0]} || $self->{maxlength}{$uv[0]} < @uv) {
415             $self->{maxlength}{$uv[0]} = @uv;
416         }
417     }
418     if (@uv > 2) {
419         while (@uv) {
420             pop @uv;
421             my $fake_entry = join(CODE_SEP, @uv); # in JCPS
422             $self->{contraction}{$fake_entry} = 1;
423         }
424     }
425 }
426
427
428 sub viewSortKey
429 {
430     my $self = shift;
431     $self->visualizeSortKey($self->getSortKey(@_));
432 }
433
434
435 ##
436 ## arrayref of JCPS   = splitEnt(string to be collated)
437 ## arrayref of arrayref[JCPS, ini_pos, fin_pos] = splitEnt(string, true)
438 ##
439 sub splitEnt
440 {
441     my $self = shift;
442     my $wLen = $_[1];
443
444     my $code = $self->{preprocess};
445     my $norm = $self->{normCode};
446     my $map  = $self->{mapping};
447     my $max  = $self->{maxlength};
448     my $reH  = $self->{rearrangeHash};
449     my $vers = $self->{UCA_Version};
450     my $ver9 = $vers >= 9 && $vers <= 11;
451     my $uXS  = $self->{__useXS};
452
453     my ($str, @buf);
454
455     if ($wLen) {
456         $code and croak "Preprocess breaks character positions. "
457                         . "Don't use with index(), match(), etc.";
458         $norm and croak "Normalization breaks character positions. "
459                         . "Don't use with index(), match(), etc.";
460         $str = $_[0];
461     }
462     else {
463         $str = $_[0];
464         $str = &$code($str) if ref $code;
465         $str = &$norm($str) if ref $norm;
466     }
467
468     # get array of Unicode code point of string.
469     my @src = unpack_U($str);
470
471     # rearrangement:
472     # Character positions are not kept if rearranged,
473     # then neglected if $wLen is true.
474     if ($reH && ! $wLen) {
475         for (my $i = 0; $i < @src; $i++) {
476             if (exists $reH->{ $src[$i] } && $i + 1 < @src) {
477                 ($src[$i], $src[$i+1]) = ($src[$i+1], $src[$i]);
478                 $i++;
479             }
480         }
481     }
482
483     # remove a code point marked as a completely ignorable.
484     for (my $i = 0; $i < @src; $i++) {
485         if (_isIllegal($src[$i]) || $vers <= 20 && _isNonchar($src[$i])) {
486             $src[$i] = undef;
487         } elsif ($ver9) {
488             $src[$i] = undef if $map->{ $src[$i] } &&
489                              @{ $map->{ $src[$i] } } == 0;
490             if ($uXS) {
491                 $src[$i] = undef if _ignorable_simple($src[$i]);
492             }
493         }
494     }
495
496     for (my $i = 0; $i < @src; $i++) {
497         my $jcps = $src[$i];
498
499         # skip removed code point
500         if (! defined $jcps) {
501             if ($wLen && @buf) {
502                 $buf[-1][2] = $i + 1;
503             }
504             next;
505         }
506
507         my $i_orig = $i;
508
509         # find contraction
510         if ($max->{$jcps}) {
511             my $temp_jcps = $jcps;
512             my $jcpsLen = 1;
513             my $maxLen = $max->{$jcps};
514
515             for (my $p = $i + 1; $jcpsLen < $maxLen && $p < @src; $p++) {
516                 next if ! defined $src[$p];
517                 $temp_jcps .= CODE_SEP . $src[$p];
518                 $jcpsLen++;
519                 if ($map->{$temp_jcps}) {
520                     $jcps = $temp_jcps;
521                     $i = $p;
522                 }
523             }
524
525         # discontiguous contraction with Combining Char (cf. UTS#10, S2.1).
526         # This process requires Unicode::Normalize.
527         # If "normalization" is undef, here should be skipped *always*
528         # (in spite of bool value of $CVgetCombinClass),
529         # since canonical ordering cannot be expected.
530         # Blocked combining character should not be contracted.
531
532             # $self->{normCode} is false in the case of "prenormalized".
533             if ($self->{normalization}) {
534                 my $cont = $self->{contraction};
535                 my $preCC = 0;
536                 my $preCC_uc = 0;
537                 my $jcps_uc = $jcps;
538                 my(@out, @out_uc);
539
540                 for (my $p = $i + 1; $p < @src; $p++) {
541                     next if ! defined $src[$p];
542                     my $curCC = $CVgetCombinClass->($src[$p]);
543                     last unless $curCC;
544                     my $tail = CODE_SEP . $src[$p];
545
546                     if ($preCC_uc != $curCC && ($map->{$jcps_uc.$tail} ||
547                                                $cont->{$jcps_uc.$tail})) {
548                         $jcps_uc .= $tail;
549                         push @out_uc, $p;
550                     } else {
551                         $preCC_uc = $curCC;
552                     }
553
554                     if ($preCC != $curCC && $map->{$jcps.$tail}) {
555                         $jcps .= $tail;
556                         push @out, $p;
557                     } else {
558                         $preCC = $curCC;
559                     }
560                 }
561
562                 if ($map->{$jcps_uc}) {
563                     $jcps = $jcps_uc;
564                     $src[$_] = undef for @out_uc;
565                 } else {
566                     $src[$_] = undef for @out;
567                 }
568             }
569         }
570
571         # skip completely ignorable
572         if ($uXS && $jcps =~ /^[0-9]+\z/ && _ignorable_simple($jcps) ||
573             $map->{$jcps} && @{ $map->{$jcps} } == 0) {
574             if ($wLen && @buf) {
575                 $buf[-1][2] = $i + 1;
576             }
577             next;
578         }
579
580         push @buf, $wLen ? [$jcps, $i_orig, $i + 1] : $jcps;
581     }
582     return \@buf;
583 }
584
585 ##
586 ## VCE = _pack_override(input, codepoint, derivCode)
587 ##
588 sub _pack_override ($$$) {
589     my $r = shift;
590     my $u = shift;
591     my $der = shift;
592
593     if (ref $r) {
594         return pack(VCE_TEMPLATE, NON_VAR, @$r);
595     } elsif (defined $r) {
596         return pack(VCE_TEMPLATE, NON_VAR, $r, Min2Wt, Min3Wt, $u);
597     } else {
598         return $der->($u);
599     }
600 }
601
602 ##
603 ## list of VCE = getWt(JCPS)
604 ##
605 sub getWt
606 {
607     my $self = shift;
608     my $u    = shift;
609     my $vbl  = $self->{variable};
610     my $map  = $self->{mapping};
611     my $der  = $self->{derivCode};
612     my $uXS  = $self->{__useXS};
613
614     return if !defined $u;
615     return map(_varCE($vbl, $_), @{ $map->{$u} })
616         if $map->{$u};
617     return map(_varCE($vbl, $_), _fetch_simple($u))
618         if $uXS && _exists_simple($u);
619
620     # JCPS must not be a contraction, then it's a code point.
621     if (Hangul_SIni <= $u && $u <= Hangul_SFin) {
622         my $hang = $self->{overrideHangul};
623         my @hangulCE;
624         if ($hang) {
625             @hangulCE = map _pack_override($_, $u, $der), $hang->($u);
626         } elsif (!defined $hang) {
627             @hangulCE = $der->($u);
628         } else {
629             my $max  = $self->{maxlength};
630             my @decH = _decompHangul($u);
631
632             if (@decH == 2) {
633                 my $contract = join(CODE_SEP, @decH);
634                 @decH = ($contract) if $map->{$contract};
635             } else { # must be <@decH == 3>
636                 if ($max->{$decH[0]}) {
637                     my $contract = join(CODE_SEP, @decH);
638                     if ($map->{$contract}) {
639                         @decH = ($contract);
640                     } else {
641                         $contract = join(CODE_SEP, @decH[0,1]);
642                         $map->{$contract} and @decH = ($contract, $decH[2]);
643                     }
644                     # even if V's ignorable, LT contraction is not supported.
645                     # If such a situation were required, NFD should be used.
646                 }
647                 if (@decH == 3 && $max->{$decH[1]}) {
648                     my $contract = join(CODE_SEP, @decH[1,2]);
649                     $map->{$contract} and @decH = ($decH[0], $contract);
650                 }
651             }
652
653             @hangulCE = map({
654                     $map->{$_} ? @{ $map->{$_} } :
655                     $uXS && _exists_simple($_) ? _fetch_simple($_) :
656                     $der->($_);
657                 } @decH);
658         }
659         return map _varCE($vbl, $_), @hangulCE;
660     } else {
661         my $cjk  = $self->{overrideCJK};
662         my $vers = $self->{UCA_Version};
663         if ($cjk && _isUIdeo($u, $vers)) {
664             my @cjkCE = map _pack_override($_, $u, $der), $cjk->($u);
665             return map _varCE($vbl, $_), @cjkCE;
666         }
667         if ($vers == 8 && defined $cjk && _isUIdeo($u, 0)) {
668             return map _varCE($vbl, $_), _uideoCE_8($u);
669         }
670         return map _varCE($vbl, $_), $der->($u);
671     }
672 }
673
674
675 ##
676 ## string sortkey = getSortKey(string arg)
677 ##
678 sub getSortKey
679 {
680     my $self = shift;
681     my $rEnt = $self->splitEnt(shift); # get an arrayref of JCPS
682     my $vers = $self->{UCA_Version};
683     my $vbl  = $self->{variable};
684     my $term = $self->{hangul_terminator};
685
686     my @buf; # weight arrays
687     if ($term) {
688         my $preHST = '';
689         my $termCE = _varCE($vbl, pack(VCE_TEMPLATE, NON_VAR, $term, 0,0,0));
690         foreach my $jcps (@$rEnt) {
691             # weird things like VL, TL-contraction are not considered!
692             my $curHST = join '', map getHST($_, $vers), split /;/, $jcps;
693             if ($preHST && !$curHST || # hangul before non-hangul
694                 $preHST =~ /L\z/ && $curHST =~ /^T/ ||
695                 $preHST =~ /V\z/ && $curHST =~ /^L/ ||
696                 $preHST =~ /T\z/ && $curHST =~ /^[LV]/) {
697                 push @buf, $termCE;
698             }
699             $preHST = $curHST;
700             push @buf, $self->getWt($jcps);
701         }
702         push @buf, $termCE if $preHST; # end at hangul
703     } else {
704         foreach my $jcps (@$rEnt) {
705             push @buf, $self->getWt($jcps);
706         }
707     }
708
709     return $self->mk_SortKey(\@buf);
710 }
711
712
713 ##
714 ## int compare = cmp(string a, string b)
715 ##
716 sub cmp { $_[0]->getSortKey($_[1]) cmp $_[0]->getSortKey($_[2]) }
717 sub eq  { $_[0]->getSortKey($_[1]) eq  $_[0]->getSortKey($_[2]) }
718 sub ne  { $_[0]->getSortKey($_[1]) ne  $_[0]->getSortKey($_[2]) }
719 sub lt  { $_[0]->getSortKey($_[1]) lt  $_[0]->getSortKey($_[2]) }
720 sub le  { $_[0]->getSortKey($_[1]) le  $_[0]->getSortKey($_[2]) }
721 sub gt  { $_[0]->getSortKey($_[1]) gt  $_[0]->getSortKey($_[2]) }
722 sub ge  { $_[0]->getSortKey($_[1]) ge  $_[0]->getSortKey($_[2]) }
723
724 ##
725 ## list[strings] sorted = sort(list[strings] arg)
726 ##
727 sub sort {
728     my $obj = shift;
729     return
730         map { $_->[1] }
731             sort{ $a->[0] cmp $b->[0] }
732                 map [ $obj->getSortKey($_), $_ ], @_;
733 }
734
735
736 ##
737 ## bool _nonIgnorAtLevel(arrayref weights, int level)
738 ##
739 sub _nonIgnorAtLevel($$)
740 {
741     my $wt = shift;
742     return if ! defined $wt;
743     my $lv = shift;
744     return grep($wt->[$_-1] != 0, MinLevel..$lv) ? TRUE : FALSE;
745 }
746
747 ##
748 ## bool _eqArray(
749 ##    arrayref of arrayref[weights] source,
750 ##    arrayref of arrayref[weights] substr,
751 ##    int level)
752 ## * comparison of graphemes vs graphemes.
753 ##   @$source >= @$substr must be true (check it before call this);
754 ##
755 sub _eqArray($$$)
756 {
757     my $source = shift;
758     my $substr = shift;
759     my $lev = shift;
760
761     for my $g (0..@$substr-1){
762         # Do the $g'th graphemes have the same number of AV weights?
763         return if @{ $source->[$g] } != @{ $substr->[$g] };
764
765         for my $w (0..@{ $substr->[$g] }-1) {
766             for my $v (0..$lev-1) {
767                 return if $source->[$g][$w][$v] != $substr->[$g][$w][$v];
768             }
769         }
770     }
771     return 1;
772 }
773
774 ##
775 ## (int position, int length)
776 ## int position = index(string, substring, position, [undoc'ed grobal])
777 ##
778 ## With "grobal" (only for the list context),
779 ##  returns list of arrayref[position, length].
780 ##
781 sub index
782 {
783     my $self = shift;
784     my $str  = shift;
785     my $len  = length($str);
786     my $subE = $self->splitEnt(shift);
787     my $pos  = @_ ? shift : 0;
788        $pos  = 0 if $pos < 0;
789     my $grob = shift;
790
791     my $lev  = $self->{level};
792     my $v2i  = $self->{UCA_Version} >= 9 &&
793                 $self->{variable} ne 'non-ignorable';
794
795     if (! @$subE) {
796         my $temp = $pos <= 0 ? 0 : $len <= $pos ? $len : $pos;
797         return $grob
798             ? map([$_, 0], $temp..$len)
799             : wantarray ? ($temp,0) : $temp;
800     }
801     $len < $pos
802         and return wantarray ? () : NOMATCHPOS;
803     my $strE = $self->splitEnt($pos ? substr($str, $pos) : $str, TRUE);
804     @$strE
805         or return wantarray ? () : NOMATCHPOS;
806
807     my(@strWt, @iniPos, @finPos, @subWt, @g_ret);
808
809     my $last_is_variable;
810     for my $vwt (map $self->getWt($_), @$subE) {
811         my($var, @wt) = unpack(VCE_TEMPLATE, $vwt);
812         my $to_be_pushed = _nonIgnorAtLevel(\@wt,$lev);
813
814         # "Ignorable (L1, L2) after Variable" since track. v. 9
815         if ($v2i) {
816             if ($var) {
817                 $last_is_variable = TRUE;
818             }
819             elsif (!$wt[0]) { # ignorable
820                 $to_be_pushed = FALSE if $last_is_variable;
821             }
822             else {
823                 $last_is_variable = FALSE;
824             }
825         }
826
827         if (@subWt && !$var && !$wt[0]) {
828             push @{ $subWt[-1] }, \@wt if $to_be_pushed;
829         } elsif ($to_be_pushed) {
830             push @subWt, [ \@wt ];
831         }
832         # else ===> skipped
833     }
834
835     my $count = 0;
836     my $end = @$strE - 1;
837
838     $last_is_variable = FALSE; # reuse
839     for (my $i = 0; $i <= $end; ) { # no $i++
840         my $found_base = 0;
841
842         # fetch a grapheme
843         while ($i <= $end && $found_base == 0) {
844             for my $vwt ($self->getWt($strE->[$i][0])) {
845                 my($var, @wt) = unpack(VCE_TEMPLATE, $vwt);
846                 my $to_be_pushed = _nonIgnorAtLevel(\@wt,$lev);
847
848                 # "Ignorable (L1, L2) after Variable" since track. v. 9
849                 if ($v2i) {
850                     if ($var) {
851                         $last_is_variable = TRUE;
852                     }
853                     elsif (!$wt[0]) { # ignorable
854                         $to_be_pushed = FALSE if $last_is_variable;
855                     }
856                     else {
857                         $last_is_variable = FALSE;
858                     }
859                 }
860
861                 if (@strWt && !$var && !$wt[0]) {
862                     push @{ $strWt[-1] }, \@wt if $to_be_pushed;
863                     $finPos[-1] = $strE->[$i][2];
864                 } elsif ($to_be_pushed) {
865                     push @strWt, [ \@wt ];
866                     push @iniPos, $found_base ? NOMATCHPOS : $strE->[$i][1];
867                     $finPos[-1] = NOMATCHPOS if $found_base;
868                     push @finPos, $strE->[$i][2];
869                     $found_base++;
870                 }
871                 # else ===> no-op
872             }
873             $i++;
874         }
875
876         # try to match
877         while ( @strWt > @subWt || (@strWt == @subWt && $i > $end) ) {
878             if ($iniPos[0] != NOMATCHPOS &&
879                     $finPos[$#subWt] != NOMATCHPOS &&
880                         _eqArray(\@strWt, \@subWt, $lev)) {
881                 my $temp = $iniPos[0] + $pos;
882
883                 if ($grob) {
884                     push @g_ret, [$temp, $finPos[$#subWt] - $iniPos[0]];
885                     splice @strWt,  0, $#subWt;
886                     splice @iniPos, 0, $#subWt;
887                     splice @finPos, 0, $#subWt;
888                 }
889                 else {
890                     return wantarray
891                         ? ($temp, $finPos[$#subWt] - $iniPos[0])
892                         :  $temp;
893                 }
894             }
895             shift @strWt;
896             shift @iniPos;
897             shift @finPos;
898         }
899     }
900
901     return $grob
902         ? @g_ret
903         : wantarray ? () : NOMATCHPOS;
904 }
905
906 ##
907 ## scalarref to matching part = match(string, substring)
908 ##
909 sub match
910 {
911     my $self = shift;
912     if (my($pos,$len) = $self->index($_[0], $_[1])) {
913         my $temp = substr($_[0], $pos, $len);
914         return wantarray ? $temp : \$temp;
915         # An lvalue ref \substr should be avoided,
916         # since its value is affected by modification of its referent.
917     }
918     else {
919         return;
920     }
921 }
922
923 ##
924 ## arrayref matching parts = gmatch(string, substring)
925 ##
926 sub gmatch
927 {
928     my $self = shift;
929     my $str  = shift;
930     my $sub  = shift;
931     return map substr($str, $_->[0], $_->[1]),
932                 $self->index($str, $sub, 0, 'g');
933 }
934
935 ##
936 ## bool subst'ed = subst(string, substring, replace)
937 ##
938 sub subst
939 {
940     my $self = shift;
941     my $code = ref $_[2] eq 'CODE' ? $_[2] : FALSE;
942
943     if (my($pos,$len) = $self->index($_[0], $_[1])) {
944         if ($code) {
945             my $mat = substr($_[0], $pos, $len);
946             substr($_[0], $pos, $len, $code->($mat));
947         } else {
948             substr($_[0], $pos, $len, $_[2]);
949         }
950         return TRUE;
951     }
952     else {
953         return FALSE;
954     }
955 }
956
957 ##
958 ## int count = gsubst(string, substring, replace)
959 ##
960 sub gsubst
961 {
962     my $self = shift;
963     my $code = ref $_[2] eq 'CODE' ? $_[2] : FALSE;
964     my $cnt = 0;
965
966     # Replacement is carried out from the end, then use reverse.
967     for my $pos_len (reverse $self->index($_[0], $_[1], 0, 'g')) {
968         if ($code) {
969             my $mat = substr($_[0], $pos_len->[0], $pos_len->[1]);
970             substr($_[0], $pos_len->[0], $pos_len->[1], $code->($mat));
971         } else {
972             substr($_[0], $pos_len->[0], $pos_len->[1], $_[2]);
973         }
974         $cnt++;
975     }
976     return $cnt;
977 }
978
979 1;
980 __END__
981
982 =head1 NAME
983
984 Unicode::Collate - Unicode Collation Algorithm
985
986 =head1 SYNOPSIS
987
988   use Unicode::Collate;
989
990   #construct
991   $Collator = Unicode::Collate->new(%tailoring);
992
993   #sort
994   @sorted = $Collator->sort(@not_sorted);
995
996   #compare
997   $result = $Collator->cmp($a, $b); # returns 1, 0, or -1.
998
999 B<Note:> Strings in C<@not_sorted>, C<$a> and C<$b> are interpreted
1000 according to Perl's Unicode support. See L<perlunicode>,
1001 L<perluniintro>, L<perlunitut>, L<perlunifaq>, L<utf8>.
1002 Otherwise you can use C<preprocess> or should decode them before.
1003
1004 =head1 DESCRIPTION
1005
1006 This module is an implementation of Unicode Technical Standard #10
1007 (a.k.a. UTS #10) - Unicode Collation Algorithm (a.k.a. UCA).
1008
1009 =head2 Constructor and Tailoring
1010
1011 The C<new> method returns a collator object. If new() is called
1012 with no parameters, the collator should do the default collation.
1013
1014    $Collator = Unicode::Collate->new(
1015       UCA_Version => $UCA_Version,
1016       alternate => $alternate, # alias for 'variable'
1017       backwards => $levelNumber, # or \@levelNumbers
1018       entry => $element,
1019       hangul_terminator => $term_primary_weight,
1020       ignoreName => qr/$ignoreName/,
1021       ignoreChar => qr/$ignoreChar/,
1022       katakana_before_hiragana => $bool,
1023       level => $collationLevel,
1024       normalization  => $normalization_form,
1025       overrideCJK => \&overrideCJK,
1026       overrideHangul => \&overrideHangul,
1027       preprocess => \&preprocess,
1028       rearrange => \@charList,
1029       suppress => \@charList,
1030       table => $filename,
1031       undefName => qr/$undefName/,
1032       undefChar => qr/$undefChar/,
1033       upper_before_lower => $bool,
1034       variable => $variable,
1035    );
1036
1037 =over 4
1038
1039 =item UCA_Version
1040
1041 If the tracking version number of UCA is given,
1042 behavior of that tracking version is emulated on collating.
1043 If omitted, the return value of C<UCA_Version()> is used.
1044
1045 The following tracking versions are supported.  The default is 20.
1046
1047      UCA       Unicode Standard         DUCET (@version)
1048    -------------------------------------------------------
1049       8              3.1                3.0.1 (3.0.1d9)
1050       9     3.1 with Corrigendum 3      3.1.1 (3.1.1)
1051      11              4.0                4.0.0 (4.0.0)
1052      14             4.1.0               4.1.0 (4.1.0)
1053      16              5.0                5.0.0 (5.0.0)
1054      18             5.1.0               5.1.0 (5.1.0)
1055      20             5.2.0               5.2.0 (5.2.0)
1056      22             6.0.0               6.0.0 (6.0.0)
1057
1058 Note: Recent UTS #10 renames "Tracking Version" to "Revision."
1059
1060 * Noncharacters (e.g. U+FFFF) are not ignored, and can be overridden
1061 since C<UCA_Version> 22.
1062
1063 * Fully ignorable characters were ignored, and would not interrupt
1064 contractions with C<UCA_Version> 9 and 11.
1065
1066 * Treatment of ignorables after variables and some behaviors
1067 were changed at C<UCA_Version> 9.
1068
1069 * Characters regarded as CJK unified ideographs (cf. C<overrideCJK>)
1070 depend on C<UCA_Version>.
1071
1072 * Many hangul jamo are assigned at C<UCA_Version> 20, that will affect
1073 C<hangul_terminator>.
1074
1075 =item alternate
1076
1077 -- see 3.2.2 Alternate Weighting, version 8 of UTS #10
1078
1079 For backward compatibility, C<alternate> (old name) can be used
1080 as an alias for C<variable>.
1081
1082 =item backwards
1083
1084 -- see 3.1.2 French Accents, UTS #10.
1085
1086      backwards => $levelNumber or \@levelNumbers
1087
1088 Weights in reverse order; ex. level 2 (diacritic ordering) in French.
1089 If omitted (or C<$levelNumber> is C<undef> or C<\@levelNumbers> is C<[]>),
1090 forwards at all the levels.
1091
1092 =item entry
1093
1094 -- see 3.1 Linguistic Features; 3.2.1 File Format, UTS #10.
1095
1096 If the same character (or a sequence of characters) exists
1097 in the collation element table through C<table>,
1098 mapping to collation elements is overridden.
1099 If it does not exist, the mapping is defined additionally.
1100
1101     entry => <<'ENTRY', # for DUCET v4.0.0 (allkeys-4.0.0.txt)
1102 0063 0068 ; [.0E6A.0020.0002.0063] # ch
1103 0043 0068 ; [.0E6A.0020.0007.0043] # Ch
1104 0043 0048 ; [.0E6A.0020.0008.0043] # CH
1105 006C 006C ; [.0F4C.0020.0002.006C] # ll
1106 004C 006C ; [.0F4C.0020.0007.004C] # Ll
1107 004C 004C ; [.0F4C.0020.0008.004C] # LL
1108 00F1      ; [.0F7B.0020.0002.00F1] # n-tilde
1109 006E 0303 ; [.0F7B.0020.0002.00F1] # n-tilde
1110 00D1      ; [.0F7B.0020.0008.00D1] # N-tilde
1111 004E 0303 ; [.0F7B.0020.0008.00D1] # N-tilde
1112 ENTRY
1113
1114     entry => <<'ENTRY', # for DUCET v4.0.0 (allkeys-4.0.0.txt)
1115 00E6 ; [.0E33.0020.0002.00E6][.0E8B.0020.0002.00E6] # ae ligature as <a><e>
1116 00C6 ; [.0E33.0020.0008.00C6][.0E8B.0020.0008.00C6] # AE ligature as <A><E>
1117 ENTRY
1118
1119 B<NOTE:> The code point in the UCA file format (before C<';'>)
1120 B<must> be a Unicode code point (defined as hexadecimal),
1121 but not a native code point.
1122 So C<0063> must always denote C<U+0063>,
1123 but not a character of C<"\x63">.
1124
1125 Weighting may vary depending on collation element table.
1126 So ensure the weights defined in C<entry> will be consistent with
1127 those in the collation element table loaded via C<table>.
1128
1129 In DUCET v4.0.0, primary weight of C<C> is C<0E60>
1130 and that of C<D> is C<0E6D>. So setting primary weight of C<CH> to C<0E6A>
1131 (as a value between C<0E60> and C<0E6D>)
1132 makes ordering as C<C E<lt> CH E<lt> D>.
1133 Exactly speaking DUCET already has some characters between C<C> and C<D>:
1134 C<small capital C> (C<U+1D04>) with primary weight C<0E64>,
1135 C<c-hook/C-hook> (C<U+0188/U+0187>) with C<0E65>,
1136 and C<c-curl> (C<U+0255>) with C<0E69>.
1137 Then primary weight C<0E6A> for C<CH> makes C<CH>
1138 ordered between C<c-curl> and C<D>.
1139
1140 =item hangul_terminator
1141
1142 -- see 7.1.4 Trailing Weights, UTS #10.
1143
1144 If a true value is given (non-zero but should be positive),
1145 it will be added as a terminator primary weight to the end of
1146 every standard Hangul syllable. Secondary and any higher weights
1147 for terminator are set to zero.
1148 If the value is false or C<hangul_terminator> key does not exist,
1149 insertion of terminator weights will not be performed.
1150
1151 Boundaries of Hangul syllables are determined
1152 according to conjoining Jamo behavior in F<the Unicode Standard>
1153 and F<HangulSyllableType.txt>.
1154
1155 B<Implementation Note:>
1156 (1) For expansion mapping (Unicode character mapped
1157 to a sequence of collation elements), a terminator will not be added
1158 between collation elements, even if Hangul syllable boundary exists there.
1159 Addition of terminator is restricted to the next position
1160 to the last collation element.
1161
1162 (2) Non-conjoining Hangul letters
1163 (Compatibility Jamo, halfwidth Jamo, and enclosed letters) are not
1164 automatically terminated with a terminator primary weight.
1165 These characters may need terminator included in a collation element
1166 table beforehand.
1167
1168 =item ignoreChar
1169
1170 =item ignoreName
1171
1172 -- see 3.2.2 Variable Weighting, UTS #10.
1173
1174 Makes the entry in the table completely ignorable;
1175 i.e. as if the weights were zero at all level.
1176
1177 Through C<ignoreChar>, any character matching C<qr/$ignoreChar/>
1178 will be ignored. Through C<ignoreName>, any character whose name
1179 (given in the C<table> file as a comment) matches C<qr/$ignoreName/>
1180 will be ignored.
1181
1182 E.g. when 'a' and 'e' are ignorable,
1183 'element' is equal to 'lament' (or 'lmnt').
1184
1185 =item katakana_before_hiragana
1186
1187 -- see 7.3.1 Tertiary Weight Table, UTS #10.
1188
1189 By default, hiragana is before katakana.
1190 If the parameter is made true, this is reversed.
1191
1192 B<NOTE>: This parameter simplemindedly assumes that any hiragana/katakana
1193 distinctions must occur in level 3, and their weights at level 3 must be
1194 same as those mentioned in 7.3.1, UTS #10.
1195 If you define your collation elements which violate this requirement,
1196 this parameter does not work validly.
1197
1198 =item level
1199
1200 -- see 4.3 Form Sort Key, UTS #10.
1201
1202 Set the maximum level.
1203 Any higher levels than the specified one are ignored.
1204
1205   Level 1: alphabetic ordering
1206   Level 2: diacritic ordering
1207   Level 3: case ordering
1208   Level 4: tie-breaking (e.g. in the case when variable is 'shifted')
1209
1210   ex.level => 2,
1211
1212 If omitted, the maximum is the 4th.
1213
1214 =item normalization
1215
1216 -- see 4.1 Normalize, UTS #10.
1217
1218 If specified, strings are normalized before preparation of sort keys
1219 (the normalization is executed after preprocess).
1220
1221 A form name C<Unicode::Normalize::normalize()> accepts will be applied
1222 as C<$normalization_form>.
1223 Acceptable names include C<'NFD'>, C<'NFC'>, C<'NFKD'>, and C<'NFKC'>.
1224 See C<Unicode::Normalize::normalize()> for detail.
1225 If omitted, C<'NFD'> is used.
1226
1227 C<normalization> is performed after C<preprocess> (if defined).
1228
1229 Furthermore, special values, C<undef> and C<"prenormalized">, can be used,
1230 though they are not concerned with C<Unicode::Normalize::normalize()>.
1231
1232 If C<undef> (not a string C<"undef">) is passed explicitly
1233 as the value for this key,
1234 any normalization is not carried out (this may make tailoring easier
1235 if any normalization is not desired). Under C<(normalization =E<gt> undef)>,
1236 only contiguous contractions are resolved;
1237 e.g. even if C<A-ring> (and C<A-ring-cedilla>) is ordered after C<Z>,
1238 C<A-cedilla-ring> would be primary equal to C<A>.
1239 In this point,
1240 C<(normalization =E<gt> undef, preprocess =E<gt> sub { NFD(shift) })>
1241 B<is not> equivalent to C<(normalization =E<gt> 'NFD')>.
1242
1243 In the case of C<(normalization =E<gt> "prenormalized")>,
1244 any normalization is not performed, but
1245 discontiguous contractions with combining characters are performed.
1246 Therefore
1247 C<(normalization =E<gt> 'prenormalized', preprocess =E<gt> sub { NFD(shift) })>
1248 B<is> equivalent to C<(normalization =E<gt> 'NFD')>.
1249 If source strings are finely prenormalized,
1250 C<(normalization =E<gt> 'prenormalized')> may save time for normalization.
1251
1252 Except C<(normalization =E<gt> undef)>,
1253 B<Unicode::Normalize> is required (see also B<CAVEAT>).
1254
1255 =item overrideCJK
1256
1257 -- see 7.1 Derived Collation Elements, UTS #10.
1258
1259 By default, CJK unified ideographs are ordered in Unicode codepoint
1260 order, but those in the CJK Unified Ideographs block are lesser than
1261 those in the CJK Unified Ideographs Extension A etc.
1262
1263     In the CJK Unified Ideographs block:
1264     U+4E00..U+9FA5 if UCA_Version is 8 to 11.
1265     U+4E00..U+9FBB if UCA_Version is 14 to 16.
1266     U+4E00..U+9FC3 if UCA_Version is 18.
1267     U+4E00..U+9FCB if UCA_Version is 20 or greater.
1268
1269     In the CJK Unified Ideographs Extension blocks:
1270     Ext.A (U+3400..U+4DB5) and Ext.B (U+20000..U+2A6D6) in any UCA_Version.
1271     Ext.C (U+2A700..U+2B734) if UCA_Version is 20 or greater.
1272     Ext.D (U+2B740..U+2B81D) if UCA_Version is 22 or greater.
1273
1274 Through C<overrideCJK>, ordering of CJK unified ideographs (including
1275 extensions) can be overridden.
1276
1277 ex. CJK unified ideographs in the JIS code point order.
1278
1279   overrideCJK => sub {
1280       my $u = shift;             # get a Unicode codepoint
1281       my $b = pack('n', $u);     # to UTF-16BE
1282       my $s = your_unicode_to_sjis_converter($b); # convert
1283       my $n = unpack('n', $s);   # convert sjis to short
1284       [ $n, 0x20, 0x2, $u ];     # return the collation element
1285   },
1286
1287 The return value may be an arrayref of 1st to 4th weights as shown
1288 above. The return value may be an integer as the primary weight
1289 as shown below.  If C<undef> is returned, the default derived
1290 collation element will be used.
1291
1292   overrideCJK => sub {
1293       my $u = shift;             # get a Unicode codepoint
1294       my $b = pack('n', $u);     # to UTF-16BE
1295       my $s = your_unicode_to_sjis_converter($b); # convert
1296       my $n = unpack('n', $s);   # convert sjis to short
1297       return $n;                 # return the primary weight
1298   },
1299
1300 The return value may be a list containing zero or more of
1301 an arrayref, an integer, or C<undef>.
1302
1303 ex. ignores all CJK unified ideographs.
1304
1305   overrideCJK => sub {()}, # CODEREF returning empty list
1306
1307    # where ->eq("Pe\x{4E00}rl", "Perl") is true
1308    # as U+4E00 is a CJK unified ideograph and to be ignorable.
1309
1310 If C<undef> is passed explicitly as the value for this key,
1311 weights for CJK unified ideographs are treated as undefined.
1312 But assignment of weight for CJK unified ideographs
1313 in C<table> or C<entry> is still valid.
1314
1315 B<Note:> In addition to them, 12 CJK compatibility ideographs (C<U+FA0E>,
1316 C<U+FA0F>, C<U+FA11>, C<U+FA13>, C<U+FA14>, C<U+FA1F>, C<U+FA21>, C<U+FA23>,
1317 C<U+FA24>, C<U+FA27>, C<U+FA28>, C<U+FA29>) are also treated as CJK unified
1318 ideographs. But they can't be overridden via C<overrideCJK> when you use
1319 DUCET, as the table includes weights for them. C<table> or C<entry> has
1320 priority over C<overrideCJK>.
1321
1322 =item overrideHangul
1323
1324 -- see 7.1 Derived Collation Elements, UTS #10.
1325
1326 By default, Hangul syllables are decomposed into Hangul Jamo,
1327 even if C<(normalization =E<gt> undef)>.
1328 But the mapping of Hangul syllables may be overridden.
1329
1330 This parameter works like C<overrideCJK>, so see there for examples.
1331
1332 If you want to override the mapping of Hangul syllables,
1333 NFD and NFKD are not appropriate, since NFD and NFKD will decompose
1334 Hangul syllables before overriding. FCD may decompose Hangul syllables
1335 as the case may be.
1336
1337 If C<undef> is passed explicitly as the value for this key,
1338 weight for Hangul syllables is treated as undefined
1339 without decomposition into Hangul Jamo.
1340 But definition of weight for Hangul syllables
1341 in C<table> or C<entry> is still valid.
1342
1343 =item preprocess
1344
1345 -- see 5.1 Preprocessing, UTS #10.
1346
1347 If specified, the coderef is used to preprocess
1348 before the formation of sort keys.
1349
1350 ex. dropping English articles, such as "a" or "the".
1351 Then, "the pen" is before "a pencil".
1352
1353      preprocess => sub {
1354            my $str = shift;
1355            $str =~ s/\b(?:an?|the)\s+//gi;
1356            return $str;
1357         },
1358
1359 C<preprocess> is performed before C<normalization> (if defined).
1360
1361 ex. decoding strings in a legacy encoding such as shift-jis:
1362
1363     $sjis_collator = Unicode::Collate->new(
1364         preprocess => \&your_shiftjis_to_unicode_decoder,
1365     );
1366     @result = $sjis_collator->sort(@shiftjis_strings);
1367
1368 B<Note:> Strings returned from the coderef will be interpreted
1369 according to Perl's Unicode support. See L<perlunicode>,
1370 L<perluniintro>, L<perlunitut>, L<perlunifaq>, L<utf8>.
1371
1372 =item rearrange
1373
1374 -- see 3.1.3 Rearrangement, UTS #10.
1375
1376 Characters that are not coded in logical order and to be rearranged.
1377 If C<UCA_Version> is equal to or lesser than 11, default is:
1378
1379     rearrange => [ 0x0E40..0x0E44, 0x0EC0..0x0EC4 ],
1380
1381 If you want to disallow any rearrangement, pass C<undef> or C<[]>
1382 (a reference to empty list) as the value for this key.
1383
1384 If C<UCA_Version> is equal to or greater than 14, default is C<[]>
1385 (i.e. no rearrangement).
1386
1387 B<According to the version 9 of UCA, this parameter shall not be used;
1388 but it is not warned at present.>
1389
1390 =item suppress
1391
1392 -- see suppress contractions in 5.14.11 Special-Purpose Commands,
1393 UTS #35 (LDML).
1394
1395 Contractions beginning with the specified characters are suppressed,
1396 even if those contractions are defined in C<table> or C<entry>.
1397
1398 An example for Russian and some languages using the Cyrillic script:
1399
1400     suppress => [0x0400..0x0417, 0x041A..0x0437, 0x043A..0x045F],
1401
1402 where 0x0400 stands for C<U+0400>, CYRILLIC CAPITAL LETTER IE WITH GRAVE.
1403
1404 =item table
1405
1406 -- see 3.2 Default Unicode Collation Element Table, UTS #10.
1407
1408 You can use another collation element table if desired.
1409
1410 The table file should locate in the F<Unicode/Collate> directory
1411 on C<@INC>. Say, if the filename is F<Foo.txt>,
1412 the table file is searched as F<Unicode/Collate/Foo.txt> in C<@INC>.
1413
1414 By default, F<allkeys.txt> (as the filename of DUCET) is used.
1415 If you will prepare your own table file, any name other than F<allkeys.txt>
1416 may be better to avoid namespace conflict.
1417
1418 B<NOTE>: When XSUB is used, the DUCET is compiled on building this
1419 module, and it may save time at the run time.
1420 Explicit saying C<table =E<gt> 'allkeys.txt'> (or using another table),
1421 or using C<ignoreChar>, C<ignoreName>, C<undefChar>, or C<undefName>
1422 will prevent this module from using the compiled DUCET.
1423
1424 If C<undef> is passed explicitly as the value for this key,
1425 no file is read (but you can define collation elements via C<entry>).
1426
1427 A typical way to define a collation element table
1428 without any file of table:
1429
1430    $onlyABC = Unicode::Collate->new(
1431        table => undef,
1432        entry => << 'ENTRIES',
1433 0061 ; [.0101.0020.0002.0061] # LATIN SMALL LETTER A
1434 0041 ; [.0101.0020.0008.0041] # LATIN CAPITAL LETTER A
1435 0062 ; [.0102.0020.0002.0062] # LATIN SMALL LETTER B
1436 0042 ; [.0102.0020.0008.0042] # LATIN CAPITAL LETTER B
1437 0063 ; [.0103.0020.0002.0063] # LATIN SMALL LETTER C
1438 0043 ; [.0103.0020.0008.0043] # LATIN CAPITAL LETTER C
1439 ENTRIES
1440     );
1441
1442 If C<ignoreName> or C<undefName> is used, character names should be
1443 specified as a comment (following C<#>) on each line.
1444
1445 =item undefChar
1446
1447 =item undefName
1448
1449 -- see 6.3.4 Reducing the Repertoire, UTS #10.
1450
1451 Undefines the collation element as if it were unassigned in the C<table>.
1452 This reduces the size of the table.
1453 If an unassigned character appears in the string to be collated,
1454 the sort key is made from its codepoint
1455 as a single-character collation element,
1456 as it is greater than any other assigned collation elements
1457 (in the codepoint order among the unassigned characters).
1458 But, it'd be better to ignore characters
1459 unfamiliar to you and maybe never used.
1460
1461 Through C<undefChar>, any character matching C<qr/$undefChar/>
1462 will be undefined. Through C<undefName>, any character whose name
1463 (given in the C<table> file as a comment) matches C<qr/$undefName/>
1464 will be undefined.
1465
1466 ex. Collation weights for beyond-BMP characters are not stored in object:
1467
1468     undefChar => qr/[^\0-\x{fffd}]/,
1469
1470 =item upper_before_lower
1471
1472 -- see 6.6 Case Comparisons, UTS #10.
1473
1474 By default, lowercase is before uppercase.
1475 If the parameter is made true, this is reversed.
1476
1477 B<NOTE>: This parameter simplemindedly assumes that any lowercase/uppercase
1478 distinctions must occur in level 3, and their weights at level 3 must be
1479 same as those mentioned in 7.3.1, UTS #10.
1480 If you define your collation elements which differs from this requirement,
1481 this parameter doesn't work validly.
1482
1483 =item variable
1484
1485 -- see 3.2.2 Variable Weighting, UTS #10.
1486
1487 This key allows to variable weighting for variable collation elements,
1488 which are marked with an ASTERISK in the table
1489 (NOTE: Many punctuation marks and symbols are variable in F<allkeys.txt>).
1490
1491    variable => 'blanked', 'non-ignorable', 'shifted', or 'shift-trimmed'.
1492
1493 These names are case-insensitive.
1494 By default (if specification is omitted), 'shifted' is adopted.
1495
1496    'Blanked'        Variable elements are made ignorable at levels 1 through 3;
1497                     considered at the 4th level.
1498
1499    'Non-Ignorable'  Variable elements are not reset to ignorable.
1500
1501    'Shifted'        Variable elements are made ignorable at levels 1 through 3
1502                     their level 4 weight is replaced by the old level 1 weight.
1503                     Level 4 weight for Non-Variable elements is 0xFFFF.
1504
1505    'Shift-Trimmed'  Same as 'shifted', but all FFFF's at the 4th level
1506                     are trimmed.
1507
1508 =back
1509
1510 =head2 Methods for Collation
1511
1512 =over 4
1513
1514 =item C<@sorted = $Collator-E<gt>sort(@not_sorted)>
1515
1516 Sorts a list of strings.
1517
1518 =item C<$result = $Collator-E<gt>cmp($a, $b)>
1519
1520 Returns 1 (when C<$a> is greater than C<$b>)
1521 or 0 (when C<$a> is equal to C<$b>)
1522 or -1 (when C<$a> is lesser than C<$b>).
1523
1524 =item C<$result = $Collator-E<gt>eq($a, $b)>
1525
1526 =item C<$result = $Collator-E<gt>ne($a, $b)>
1527
1528 =item C<$result = $Collator-E<gt>lt($a, $b)>
1529
1530 =item C<$result = $Collator-E<gt>le($a, $b)>
1531
1532 =item C<$result = $Collator-E<gt>gt($a, $b)>
1533
1534 =item C<$result = $Collator-E<gt>ge($a, $b)>
1535
1536 They works like the same name operators as theirs.
1537
1538    eq : whether $a is equal to $b.
1539    ne : whether $a is not equal to $b.
1540    lt : whether $a is lesser than $b.
1541    le : whether $a is lesser than $b or equal to $b.
1542    gt : whether $a is greater than $b.
1543    ge : whether $a is greater than $b or equal to $b.
1544
1545 =item C<$sortKey = $Collator-E<gt>getSortKey($string)>
1546
1547 -- see 4.3 Form Sort Key, UTS #10.
1548
1549 Returns a sort key.
1550
1551 You compare the sort keys using a binary comparison
1552 and get the result of the comparison of the strings using UCA.
1553
1554    $Collator->getSortKey($a) cmp $Collator->getSortKey($b)
1555
1556       is equivalent to
1557
1558    $Collator->cmp($a, $b)
1559
1560 =item C<$sortKeyForm = $Collator-E<gt>viewSortKey($string)>
1561
1562 Converts a sorting key into its representation form.
1563 If C<UCA_Version> is 8, the output is slightly different.
1564
1565    use Unicode::Collate;
1566    my $c = Unicode::Collate->new();
1567    print $c->viewSortKey("Perl"),"\n";
1568
1569    # output:
1570    # [0B67 0A65 0B7F 0B03 | 0020 0020 0020 0020 | 0008 0002 0002 0002 | FFFF FFFF FFFF FFFF]
1571    #  Level 1               Level 2               Level 3               Level 4
1572
1573 =back
1574
1575 =head2 Methods for Searching
1576
1577 B<DISCLAIMER:> If C<preprocess> or C<normalization> parameter is true
1578 for C<$Collator>, calling these methods (C<index>, C<match>, C<gmatch>,
1579 C<subst>, C<gsubst>) is croaked,
1580 as the position and the length might differ
1581 from those on the specified string.
1582 (And C<rearrange> and C<hangul_terminator> parameters are neglected.)
1583
1584 The C<match>, C<gmatch>, C<subst>, C<gsubst> methods work
1585 like C<m//>, C<m//g>, C<s///>, C<s///g>, respectively,
1586 but they are not aware of any pattern, but only a literal substring.
1587
1588 =over 4
1589
1590 =item C<$position = $Collator-E<gt>index($string, $substring[, $position])>
1591
1592 =item C<($position, $length) = $Collator-E<gt>index($string, $substring[, $position])>
1593
1594 If C<$substring> matches a part of C<$string>, returns
1595 the position of the first occurrence of the matching part in scalar context;
1596 in list context, returns a two-element list of
1597 the position and the length of the matching part.
1598
1599 If C<$substring> does not match any part of C<$string>,
1600 returns C<-1> in scalar context and
1601 an empty list in list context.
1602
1603 e.g. you say
1604
1605   my $Collator = Unicode::Collate->new( normalization => undef, level => 1 );
1606                                      # (normalization => undef) is REQUIRED.
1607   my $str = "Ich muß studieren Perl.";
1608   my $sub = "MÜSS";
1609   my $match;
1610   if (my($pos,$len) = $Collator->index($str, $sub)) {
1611       $match = substr($str, $pos, $len);
1612   }
1613
1614 and get C<"muß"> in C<$match> since C<"muß">
1615 is primary equal to C<"MÜSS">.
1616
1617 =item C<$match_ref = $Collator-E<gt>match($string, $substring)>
1618
1619 =item C<($match)   = $Collator-E<gt>match($string, $substring)>
1620
1621 If C<$substring> matches a part of C<$string>, in scalar context, returns
1622 B<a reference to> the first occurrence of the matching part
1623 (C<$match_ref> is always true if matches,
1624 since every reference is B<true>);
1625 in list context, returns the first occurrence of the matching part.
1626
1627 If C<$substring> does not match any part of C<$string>,
1628 returns C<undef> in scalar context and
1629 an empty list in list context.
1630
1631 e.g.
1632
1633     if ($match_ref = $Collator->match($str, $sub)) { # scalar context
1634         print "matches [$$match_ref].\n";
1635     } else {
1636         print "doesn't match.\n";
1637     }
1638
1639      or
1640
1641     if (($match) = $Collator->match($str, $sub)) { # list context
1642         print "matches [$match].\n";
1643     } else {
1644         print "doesn't match.\n";
1645     }
1646
1647 =item C<@match = $Collator-E<gt>gmatch($string, $substring)>
1648
1649 If C<$substring> matches a part of C<$string>, returns
1650 all the matching parts (or matching count in scalar context).
1651
1652 If C<$substring> does not match any part of C<$string>,
1653 returns an empty list.
1654
1655 =item C<$count = $Collator-E<gt>subst($string, $substring, $replacement)>
1656
1657 If C<$substring> matches a part of C<$string>,
1658 the first occurrence of the matching part is replaced by C<$replacement>
1659 (C<$string> is modified) and return C<$count> (always equals to C<1>).
1660
1661 C<$replacement> can be a C<CODEREF>,
1662 taking the matching part as an argument,
1663 and returning a string to replace the matching part
1664 (a bit similar to C<s/(..)/$coderef-E<gt>($1)/e>).
1665
1666 =item C<$count = $Collator-E<gt>gsubst($string, $substring, $replacement)>
1667
1668 If C<$substring> matches a part of C<$string>,
1669 all the occurrences of the matching part is replaced by C<$replacement>
1670 (C<$string> is modified) and return C<$count>.
1671
1672 C<$replacement> can be a C<CODEREF>,
1673 taking the matching part as an argument,
1674 and returning a string to replace the matching part
1675 (a bit similar to C<s/(..)/$coderef-E<gt>($1)/eg>).
1676
1677 e.g.
1678
1679   my $Collator = Unicode::Collate->new( normalization => undef, level => 1 );
1680                                      # (normalization => undef) is REQUIRED.
1681   my $str = "Camel donkey zebra came\x{301}l CAMEL horse cAm\0E\0L...";
1682   $Collator->gsubst($str, "camel", sub { "<b>$_[0]</b>" });
1683
1684   # now $str is "<b>Camel</b> donkey zebra <b>came\x{301}l</b> <b>CAMEL</b> horse <b>cAm\0E\0L</b>...";
1685   # i.e., all the camels are made bold-faced.
1686
1687 =back
1688
1689 =head2 Other Methods
1690
1691 =over 4
1692
1693 =item C<%old_tailoring = $Collator-E<gt>change(%new_tailoring)>
1694
1695 =item C<$modified_collator = $Collator-E<gt>change(%new_tailoring)>
1696
1697 Change the value of specified keys and returns the changed part.
1698
1699     $Collator = Unicode::Collate->new(level => 4);
1700
1701     $Collator->eq("perl", "PERL"); # false
1702
1703     %old = $Collator->change(level => 2); # returns (level => 4).
1704
1705     $Collator->eq("perl", "PERL"); # true
1706
1707     $Collator->change(%old); # returns (level => 2).
1708
1709     $Collator->eq("perl", "PERL"); # false
1710
1711 Not all C<(key,value)>s are allowed to be changed.
1712 See also C<@Unicode::Collate::ChangeOK> and C<@Unicode::Collate::ChangeNG>.
1713
1714 In the scalar context, returns the modified collator
1715 (but it is B<not> a clone from the original).
1716
1717     $Collator->change(level => 2)->eq("perl", "PERL"); # true
1718
1719     $Collator->eq("perl", "PERL"); # true; now max level is 2nd.
1720
1721     $Collator->change(level => 4)->eq("perl", "PERL"); # false
1722
1723 =item C<$version = $Collator-E<gt>version()>
1724
1725 Returns the version number (a string) of the Unicode Standard
1726 which the C<table> file used by the collator object is based on.
1727 If the table does not include a version line (starting with C<@version>),
1728 returns C<"unknown">.
1729
1730 =item C<UCA_Version()>
1731
1732 Returns the tracking version number of UTS #10 this module consults.
1733 C<UCA_Version()> should return the tracking version corresponding
1734 with the DUCET incorporated.
1735
1736 =item C<Base_Unicode_Version()>
1737
1738 Returns the version number of UTS #10 this module consults.
1739
1740 =back
1741
1742 =head1 EXPORT
1743
1744 No method will be exported.
1745
1746 =head1 INSTALL
1747
1748 Though this module can be used without any C<table> file,
1749 to use this module easily, it is recommended to install a table file
1750 in the UCA format, by copying it under the directory
1751 <a place in @INC>/Unicode/Collate.
1752
1753 The most preferable one is "The Default Unicode Collation Element Table"
1754 (aka DUCET), available from the Unicode Consortium's website:
1755
1756    http://www.unicode.org/Public/UCA/
1757
1758    http://www.unicode.org/Public/UCA/latest/allkeys.txt (latest version)
1759
1760 If DUCET is not installed, it is recommended to copy the file
1761 from http://www.unicode.org/Public/UCA/latest/allkeys.txt
1762 to <a place in @INC>/Unicode/Collate/allkeys.txt
1763 manually.
1764
1765 =head1 CAVEATS
1766
1767 =over 4
1768
1769 =item Normalization
1770
1771 Use of the C<normalization> parameter requires the B<Unicode::Normalize>
1772 module (see L<Unicode::Normalize>).
1773
1774 If you need not it (say, in the case when you need not
1775 handle any combining characters),
1776 assign C<normalization =E<gt> undef> explicitly.
1777
1778 -- see 6.5 Avoiding Normalization, UTS #10.
1779
1780 =item Conformance Test
1781
1782 The Conformance Test for the UCA is available
1783 under L<http://www.unicode.org/Public/UCA/>.
1784
1785 For F<CollationTest_SHIFTED.txt>,
1786 a collator via C<Unicode::Collate-E<gt>new( )> should be used;
1787 for F<CollationTest_NON_IGNORABLE.txt>, a collator via
1788 C<Unicode::Collate-E<gt>new(variable =E<gt> "non-ignorable", level =E<gt> 3)>.
1789
1790 B<Unicode::Normalize is required to try The Conformance Test.>
1791
1792 =back
1793
1794 =head1 AUTHOR, COPYRIGHT AND LICENSE
1795
1796 The Unicode::Collate module for perl was written by SADAHIRO Tomoyuki,
1797 <SADAHIRO@cpan.org>. This module is Copyright(C) 2001-2011,
1798 SADAHIRO Tomoyuki. Japan. All rights reserved.
1799
1800 This module is free software; you can redistribute it and/or
1801 modify it under the same terms as Perl itself.
1802
1803 The file Unicode/Collate/allkeys.txt was copied verbatim
1804 from L<http://www.unicode.org/Public/UCA/5.2.0/allkeys.txt>.
1805 This file is Copyright (c) 1991-2009 Unicode, Inc. All rights reserved.
1806 Distributed under the Terms of Use in L<http://www.unicode.org/copyright.html>.
1807
1808 =head1 SEE ALSO
1809
1810 =over 4
1811
1812 =item Unicode Collation Algorithm - UTS #10
1813
1814 L<http://www.unicode.org/reports/tr10/>
1815
1816 =item The Default Unicode Collation Element Table (DUCET)
1817
1818 L<http://www.unicode.org/Public/UCA/latest/allkeys.txt>
1819
1820 =item The conformance test for the UCA
1821
1822 L<http://www.unicode.org/Public/UCA/latest/CollationTest.html>
1823
1824 L<http://www.unicode.org/Public/UCA/latest/CollationTest.zip>
1825
1826 =item Hangul Syllable Type
1827
1828 L<http://www.unicode.org/Public/UNIDATA/HangulSyllableType.txt>
1829
1830 =item Unicode Normalization Forms - UAX #15
1831
1832 L<http://www.unicode.org/reports/tr15/>
1833
1834 =item Unicode Locale Data Markup Language (LDML) - UTS #35
1835
1836 L<http://www.unicode.org/reports/tr35/>
1837
1838 =back
1839
1840 =cut