File Coverage

blib/lib/Locale/CLDR/Collator.pm
Criterion Covered Total %
statement 29 113 25.6
branch 0 16 0.0
condition 0 6 0.0
subroutine 10 25 40.0
pod 0 13 0.0
total 39 173 22.5


line stmt bran cond sub pod time code
1             package Locale::CLDR::Collator;
2              
3 20     20   120 use version;
  20         35  
  20         182  
4             our $VERSION = version->declare('v0.28.1');
5              
6 20     20   2754 use v5.10.1;
  20         73  
7 20     20   114 use mro 'c3';
  20         38  
  20         186  
8 20     20   802 use utf8;
  20         39  
  20         158  
9 20     20   825 use if $^V ge v5.12.0, feature => 'unicode_strings';
  20         36  
  20         353  
10              
11 20     20   2686 use Unicode::Normalize('NFD');
  20         41  
  20         2267  
12 20     20   212438 use Unicode::UCD qw( charinfo );
  20         1192242  
  20         2413  
13 20     20   195 use List::MoreUtils qw(pairwise);
  20         44  
  20         422  
14 20     20   10085 use Moose;
  20         38  
  20         204  
15              
16             with 'Locale::CLDR::CollatorBase';
17              
18             my $NUMBER_SORT_TOP = "\x{FD00}\x{0034}";
19             my $LEVEL_SEPARATOR = "\x{0001}";
20             my $FIELD_SEPARATOR = "\x{0002}";
21              
22             has 'type' => (
23             is => 'ro',
24             isa => 'Str',
25             default => 'standard',
26             );
27              
28             has 'locale' => (
29             is => 'ro',
30             isa => 'Maybe[Locale::CLDR]',
31             default => undef,
32             predicate => 'has_locale',
33             );
34              
35             has 'alternate' => (
36             is => 'ro',
37             isa => 'Str',
38             default => 'noignore'
39             );
40              
41             has 'backwards' => (
42             is => 'ro',
43             isa => 'Str',
44             default => 'false',
45             );
46              
47             has 'case_level' => (
48             is => 'ro',
49             isa => 'Str',
50             default => 'false',
51             );
52              
53             has 'case_ordering' => (
54             is => 'ro',
55             isa => 'Str',
56             default => 'false',
57             );
58              
59             has 'normalization' => (
60             is => 'ro',
61             isa => 'Str',
62             default => 'false',
63             );
64              
65             has 'numeric' => (
66             is => 'ro',
67             isa => 'Str',
68             default => 'false',
69             );
70              
71             has 'reorder' => (
72             is => 'ro',
73             isa => 'ArrayRef',
74             default => sub { [] },
75             );
76              
77             has 'strength' => (
78             is => 'ro',
79             isa => 'Int',
80             default => 3,
81             );
82              
83             has 'max_variable' => (
84             is => 'ro',
85             isa => 'Str',
86             default => 'punct',
87             );
88              
89             # Set up the locale overrides
90             sub BUILD {
91 0     0 0   my $self = shift;
92            
93 0           my $overrides = [];
94 0 0         if ($self->has_locale) {
95 0           $overrides = $self->locale->_collation_overrides($self->type);
96             }
97            
98 0           foreach my $override (@$overrides) {
99 0           $self->_set_ce(@$override);
100             }
101             }
102              
103             sub _get_sort_digraphs_rx {
104 0     0     my $self = shift;
105            
106 0           my $digraphs = $self->_digraphs();
107            
108 0           my $rx = join '|', @$digraphs, '.';
109            
110             # Fix numeric sorting here
111 0 0         if ($self->numeric eq 'true') {
112 0           $rx = "\\p{Nd}+|$rx";
113             }
114            
115 0           return qr/$rx/;
116             }
117              
118              
119             # Get the collation element at the current strength
120             sub get_collation_element {
121 0     0 0   my ($self, $grapheme) = @_;
122 0           my $ce;
123 0 0 0       if ($self->numeric && $grapheme =~/^\p{Nd}/) {
124 0           my $numeric_top = $self->collation_elements()->{$NUMBER_SORT_TOP};
125 0           my @numbers = $self->_convert_digits_to_numbers($grapheme);
126 0           $ce = join '', map { "$numeric_top${LEVEL_SEPARATOR}â„–$_" } @numbers;
  0            
127             }
128             else {
129 0           $ce = $self->collation_elements()->{$grapheme};
130             }
131              
132 0           my $strength = $self->strength;
133 0           my @elements = split /$LEVEL_SEPARATOR/, $ce;
134 0           foreach my $element (@elements) {
135 0           my @parts = split /$FIELD_SEPARATOR/, $element;
136 0 0         if (@parts > $strength) {
137 0           @parts = @parts[0 .. $strength - 1];
138             }
139 0           $element = join $FIELD_SEPARATOR, @parts;
140             }
141            
142 0           return @elements;
143             }
144              
145             # Converts $string into a string of Collation Elements
146             sub getSortKey {
147 0     0 0   my ($self, $string) = @_;
148              
149 0 0         $string = NFD($string) if $self->normalization eq 'true';
150            
151 0           my $entity_rx = $self->_get_sort_digraphs_rx();
152              
153 0           my @ce;
154 0           while (my ($grapheme) = $string =~ /($entity_rx)/g ) {
155 0           push @ce, $self->get_collation_element($grapheme)
156             }
157              
158 0           return \@ce;
159             }
160              
161             sub generate_ce {
162 0     0 0   my ($self, $character) = @_;
163            
164 0           my $base;
165            
166 0 0         if ($character =~ /\p{Unified_Ideograph}/) {
167 0 0 0       if ($character =~ /\p{Block=CJK_Unified_Ideograph}/ || $character =~ /\p{Block=CJK_Compatibility_Ideographs}/) {
168 0           $base = 0xFB40;
169             }
170             else {
171 0           $base = 0xFB80;
172             }
173             }
174             else {
175 0           $base = 0xFBC0;
176             }
177            
178 0           my $aaaa = $base + unpack( 'L', (pack ('L', ord($character)) >> 15));
179 0           my $bbbb = unpack('L', (pack('L', ord($character)) & 0x7FFF) | 0x8000);
180            
181 0           return join '', map {chr($_)} $aaaa, 0x0020, 0x0002,0, $bbbb,0,0,0;
  0            
182             }
183              
184             # sorts a list according to the locales collation rules
185             sub sort {
186 0     0 0   my $self = shift;
187            
188 0           return map { $_->[0]}
189 0           sort { $a->[1] cmp $b->[1] }
190 0           map { [$_, $self->getSortKey($_)] }
  0            
191             @_;
192             }
193              
194             sub cmp {
195 0     0 0   my ($self, $a, $b) = @_;
196            
197 0           return $self->getSortKey($a) cmp $self->getSortKey($b);
198             }
199              
200             sub eq {
201 0     0 0   my ($self, $a, $b) = @_;
202            
203 0           return $self->getSortKey($a) eq $self->getSortKey($b);
204             }
205              
206             sub ne {
207 0     0 0   my ($self, $a, $b) = @_;
208            
209 0           return $self->getSortKey($a) ne $self->getSortKey($b);
210             }
211              
212             sub lt {
213 0     0 0   my ($self, $a, $b) = @_;
214            
215 0           return $self->getSortKey($a) lt $self->getSortKey($b);
216             }
217              
218             sub le {
219 0     0 0   my ($self, $a, $b) = @_;
220            
221 0           return $self->getSortKey($a) le $self->getSortKey($b);
222             }
223             sub gt {
224 0     0 0   my ($self, $a, $b) = @_;
225            
226 0           return $self->getSortKey($a) gt $self->getSortKey($b);
227             }
228              
229             sub ge {
230 0     0 0   my ($self, $a, $b) = @_;
231            
232 0           return $self->getSortKey($a) ge $self->getSortKey($b);
233             }
234              
235             # Get Human readable sort key
236             sub viewSortKey {
237 0     0 0   my ($self, $sort_key) = @_;
238            
239 0           my @levels = split/\x0/, $sort_key;
240            
241 0           foreach my $level (@levels) {
242 0           $level = join ' ', map { sprintf '%0.4X', ord } split //, $level;
  0            
243             }
244            
245 0           return '[ ' . join (' | ', @levels) . ' ]';
246             }
247              
248             sub _convert_digits_to_numbers {
249 0     0     my ($self, $digits) = @_;
250 0           my @numbers = ();
251 0           my $script = '';
252 0           foreach my $number (split //, $digits) {
253 0           my $char_info = charinfo(ord($number));
254 0           my ($decimal, $chr_script) = @{$char_info}{qw( decimal script )};
  0            
255 0 0         if ($chr_script eq $script) {
256 0           $numbers[-1] *= 10;
257 0           $numbers[-1] += $decimal;
258             }
259             else {
260 0           push @numbers, $decimal;
261 0           $script = $chr_script;
262             }
263             }
264 0           return @numbers;
265             }
266              
267 20     20   242840 no Moose;
  20         46  
  20         164  
268              
269             1;
270              
271             # vim: tabstop=4