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