File Coverage

blib/lib/CLDR/Number/Role/Base.pm
Criterion Covered Total %
statement 80 80 100.0
branch 28 30 93.3
condition 13 18 72.2
subroutine 15 15 100.0
pod n/a
total 136 143 95.1


line stmt bran cond sub pod time code
1             package CLDR::Number::Role::Base;
2              
3 18     18   110055 use v5.8.1;
  18         44  
4 18     18   63 use utf8;
  18         32  
  18         87  
5 18     18   305 use Carp;
  18         18  
  18         928  
6 18     18   69 use Scalar::Util qw( looks_like_number );
  18         18  
  18         1120  
7 18     18   8194 use CLDR::Number::Data::Base;
  18         126  
  18         1168  
8 18     18   6007 use CLDR::Number::Data::System;
  18         246  
  18         449  
9              
10 18     18   73 use Moo::Role;
  18         15  
  18         122  
11              
12             # This role does not have a publicly supported interface and may change in
13             # backward incompatible ways in the future. Please use one of the documented
14             # classes instead.
15              
16             our $VERSION = '0.19';
17              
18             requires qw( BUILD );
19              
20             has version => (
21             is => 'ro',
22             default => $VERSION,
23             );
24              
25             has cldr_version => (
26             is => 'ro',
27             default => $CLDR::Number::Data::Base::CLDR_VERSION,
28             );
29              
30             has locale => (
31             is => 'rw',
32             trigger => 1,
33             );
34              
35             has default_locale => (
36             is => 'ro',
37             coerce => sub {
38             my ($locale) = @_;
39              
40             if (!defined $locale) {
41             carp 'default_locale is not defined';
42             }
43             elsif (!exists $CLDR::Number::Data::Base::DATA->{$locale}) {
44             carp "default_locale '$locale' is unknown";
45             }
46             else {
47             return $locale;
48             }
49              
50             return;
51             },
52             );
53              
54             has numbering_system => (
55             is => 'rw',
56             isa => sub {
57             carp 'numbering_system is not defined'
58             unless defined $_[0];
59             carp "numbering_system '$_[0]' is unknown"
60             unless exists $CLDR::Number::Data::System::DATA->{$_[0]};
61             },
62             coerce => sub { defined $_[0] ? lc $_[0] : $_[0] },
63             trigger => 1,
64             );
65              
66             has minimum_grouping_digits => (
67             is => 'rw',
68             isa => sub {
69             croak "minimum_grouping_digits '$_[0]' is invalid"
70             if defined $_[0] && !looks_like_number $_[0];
71             },
72             );
73              
74             # TODO: length NYI
75             has length => (
76             is => 'rw',
77             );
78              
79             has decimal_sign => (
80             is => 'rw',
81             );
82              
83             has group_sign => (
84             is => 'rw',
85             );
86              
87             has plus_sign => (
88             is => 'rw',
89             );
90              
91             has minus_sign => (
92             is => 'rw',
93             );
94              
95             has infinity => (
96             is => 'rw',
97             );
98              
99             has nan => (
100             is => 'rw',
101             );
102              
103             has _locale_inheritance => (
104             is => 'rw',
105             default => sub { [] },
106             );
107              
108             has _init_args => (
109             is => 'rw',
110             );
111              
112             around BUILDARGS => sub {
113             my ($orig, $class, @args) = @_;
114              
115             return $class->$orig(@args) if @args % 2;
116             return $class->$orig(@args, _init_args => {@args});
117             };
118              
119             before BUILD => sub {
120             my ($self) = @_;
121              
122             return if $self->_has_init_arg('locale');
123              
124             $self->_trigger_locale;
125             };
126              
127             after BUILD => sub {
128             my ($self) = @_;
129              
130             $self->_init_args({});
131             };
132              
133             sub _has_init_arg {
134 3419     3419   2813 my ($self, $arg) = @_;
135              
136 3419 50       5762 return unless $self->_init_args;
137 3419         10928 return exists $self->_init_args->{$arg};
138             }
139              
140             sub _set_unless_init_arg {
141 1582     1582   1654 my ($self, $attribute, $value) = @_;
142              
143 1582 100       1837 return if $self->_has_init_arg($attribute);
144              
145 1566         3863 $self->$attribute($value);
146             }
147              
148             sub _build_signs {
149 208     208   404 my ($self, @signs) = @_;
150              
151 208         253 for my $sign (@signs) {
152 1200         919 my $attribute = $sign;
153              
154 1200 50       1377 next if $self->_has_init_arg($attribute);
155              
156 1200         2286 $sign =~ s{ _sign $ }{}x;
157              
158 1200         1462 $self->$attribute($self->_get_data(symbol => $sign));
159             }
160             }
161              
162             sub _trigger_locale {
163 196     196   21286 my ($self, $locale) = @_;
164 196         368 my ($lang, $script, $region, $ext) = _split_locale($locale);
165              
166 196 100 66     755 if ($lang && exists $CLDR::Number::Data::Base::DATA->{$lang}) {
    100          
167 164         258 $self->_locale_inheritance(
168             _build_inheritance($lang, $script, $region, $ext)
169             );
170 164         285 $locale = $self->_locale_inheritance->[0];
171             }
172             elsif ($self->default_locale) {
173 2         3 $locale = $self->default_locale;
174 2         5 ($lang, $script, $region, $ext) = _split_locale($locale);
175 2         4 $self->_locale_inheritance(
176             _build_inheritance($lang, $script, $region, $ext)
177             );
178             }
179             else {
180 30         37 $locale = 'root';
181 30         98 $self->_locale_inheritance( [$locale] );
182             }
183              
184 196 100 100     437 if ($ext && $ext =~ m{ -nu- ( [^-]+ ) }x) {
185 4         13 $self->numbering_system($1);
186             }
187             else {
188 192         318 $self->_trigger_numbering_system;
189             }
190              
191 196         284 $self->{locale} = $locale;
192              
193 196         362 $self->_build_signs(qw{
194             decimal_sign group_sign plus_sign minus_sign infinity nan
195             });
196              
197 196         327 $self->_set_unless_init_arg(
198             minimum_grouping_digits => $self->_get_data(attr => 'min_group')
199             );
200             }
201              
202             sub _trigger_numbering_system {
203 201     201   693 my ($self, $system) = @_;
204              
205             return if defined $system
206 201 100 66     439 && exists $CLDR::Number::Data::System::DATA->{$system};
207              
208 193         364 $self->{numbering_system} = $self->_get_data(attr => 'system');
209             }
210              
211             sub _split_locale {
212 239     239   235 my ($locale) = @_;
213              
214 239 100       417 return unless defined $locale;
215              
216 223         284 $locale = lc $locale;
217 223         284 $locale =~ tr{_}{-};
218              
219 223         1149 my ($lang, $script, $region, $ext) = $locale =~ m{ ^
220             ( [a-z]{2,3} ) # language
221             (?: - ( [a-z]{4} ) )? # script
222             (?: - ( [a-z]{2} | [0-9]{3} ) )? # country or region
223             (?: - ( u- .+ ) )? # extension
224             -? # trailing separator
225             $ }xi;
226              
227 223 100       402 $script = ucfirst $script if $script;
228 223 100       354 $region = uc $region if $region;
229              
230 223         434 return $lang, $script, $region, $ext;
231             }
232              
233             sub _build_inheritance {
234 207     207   221 my ($lang, $script, $region, $ext) = @_;
235 207         164 my @tree;
236              
237 207         731 for my $subtags (
238             [$lang, $region, $ext],
239             [$lang, $script, $region],
240             [$lang, $script],
241             [$lang, $region],
242             [$lang],
243             ) {
244 984 100       820 next if grep { !$_ } @$subtags;
  2216         2807  
245 292         421 my $locale = join '-', @$subtags;
246 292 100       507 next if !exists $CLDR::Number::Data::Base::DATA->{$locale};
247 248         285 push @tree, $locale;
248              
249 248 100       598 if (my $parent = $CLDR::Number::Data::Base::PARENT->{$locale}) {
250 41         33 push @tree, @{_build_inheritance(_split_locale($parent))};
  41         53  
251 41         64 last;
252             }
253             }
254              
255 207 100 100     966 if (!@tree || $tree[-1] ne 'root') {
256 166         190 push @tree, 'root';
257             }
258              
259 207         546 return \@tree;
260             }
261              
262             sub _get_data {
263 1835     1835   1744 my ($self, $type, $key) = @_;
264 1835         1323 my $data = $CLDR::Number::Data::Base::DATA;
265              
266 1835         1148 for my $locale (@{$self->_locale_inheritance}) {
  1835         2480  
267             return $data->{$locale}{$type}{$key}
268             if exists $data->{$locale}
269             && exists $data->{$locale}{$type}
270 3725 100 33     14868 && exists $data->{$locale}{$type}{$key};
      66        
271             }
272              
273 85         1399 return undef;
274             }
275              
276             1;