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