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