File Coverage

blib/lib/Locale/CLDR.pm
Criterion Covered Total %
statement 945 1266 74.6
branch 226 396 57.0
condition 69 139 49.6
subroutine 141 168 83.9
pod 49 49 100.0
total 1430 2018 70.8


line stmt bran cond sub pod time code
1             package Locale::CLDR;
2              
3             =encoding utf8
4              
5             =head1 NAME
6              
7             Locale::CLDR - A Module to create locale objects with localisation data from the CLDR
8              
9             =head1 VERSION
10              
11             Version 0.26.10
12              
13             =head1 SYNOPSIS
14              
15             This module provides a locale object you can use to localise your output.
16             The localisation data comes from the Unicode Common Locale Data Repository.
17             Most of this code can be used with Perl version 5.10 or above. There are a
18             few parts of the code that require version 5.18 or above.
19              
20             =head1 USAGE
21              
22             my $locale = Locale::CLDR->new('en_US');
23              
24             or
25              
26             my $locale = Locale::CLDR->new(language_id => 'en', territory_id => 'us');
27            
28             A full locale identifier is
29            
30             C<language>_C<script>_C<territory>_C<variant>_u_C<extension name>_C<extension value>
31            
32             my $locale = Locale::CLDR->new('en_latn_US_SCOUSE_u_nu_traditional');
33            
34             or
35            
36             my $locale = Locale::CLDR->new(language_id => 'en', script_id => 'latn', territory_id => 'US', variant => 'SCOUSE', extensions => { nu => 'traditional' } );
37            
38             =cut
39              
40 20     20   350772 use v5.10;
  20         57  
  20         663  
41 20     20   6995 use version;
  20         24965  
  20         80  
42             our $VERSION = version->declare('v0.26.10');
43              
44 20     20   9210 use open ':encoding(utf8)';
  20         16305  
  20         75  
45 20     20   170766 use utf8;
  20         38  
  20         86  
46 20     20   1071 use if ($^V ge v5.12.0), (feature => 'unicode_strings');
  20         29  
  20         751  
47              
48 20     20   10697 use Moose;
  20         6281293  
  20         143  
49 20     20   107865 use MooseX::ClassAttribute;
  20         1121126  
  20         92  
50             with 'Locale::CLDR::ValidCodes', 'Locale::CLDR::EraBoundries', 'Locale::CLDR::WeekData',
51             'Locale::CLDR::MeasurementSystem', 'Locale::CLDR::LikelySubtags', 'Locale::CLDR::NumberingSystems',
52             'Locale::CLDR::NumberFormatter', 'Locale::CLDR::TerritoryContainment', 'Locale::CLDR::CalendarPreferences',
53             'Locale::CLDR::Currencies', 'Locale::CLDR::Plurals';
54            
55 20     20   4036113 use Class::Load;
  20         38  
  20         783  
56 20     20   78 use namespace::autoclean;
  20         25  
  20         156  
57 20     20   1558 use List::Util qw(first);
  20         27  
  20         996  
58 20     20   71 use Class::MOP;
  20         20  
  20         309  
59 20     20   11540 use DateTime::Locale;
  20         816650  
  20         580  
60 20     20   13029 use Unicode::Normalize();
  20         30313  
  20         468  
61             #use Locale::CLDR::Collator();
62 20     20   118 use File::Spec();
  20         21  
  20         2109  
63              
64             # Backwards compatibility
65             BEGIN {
66 20 50   20   72 if (defined &CORE::fc) { #v5.16
67 20         17448 *fc = \&CORE::fc;
68             }
69             else {
70             # We only use fc() with code that expects Perl v5.18 or above
71 0         0 *fc = sub {};
  0         0  
72             }
73             }
74              
75             =head1 ATTRIBUTES
76              
77             These can be passed into the constructor and all are optional.
78              
79             =over 4
80              
81             =item language_id
82              
83             A valid language or language alias id, such as C<en>
84              
85             =cut
86              
87             has 'language_id' => (
88             is => 'ro',
89             isa => 'Str',
90             required => 1,
91             );
92              
93             # language aliases
94             around 'language_id' => sub {
95             my ($orig, $self) = @_;
96             my $value = $self->$orig;
97             return $self->language_aliases->{$value} // $value;
98             };
99              
100             =item script_id
101              
102             A valid script id, such as C<latn> or C<Ctcl>. The code will pick a likely script
103             depending on the given language if non is provided.
104              
105             =cut
106              
107             has 'script_id' => (
108             is => 'ro',
109             isa => 'Str',
110             default => '',
111             predicate => 'has_script',
112             );
113              
114             =item territory_id
115              
116             A valid territory id or territory alias such as C<GB>
117              
118             =cut
119              
120             has 'territory_id' => (
121             is => 'ro',
122             isa => 'Str',
123             default => '',
124             predicate => 'has_territory',
125             );
126              
127             # territory aliases
128             around 'territory_id' => sub {
129             my ($orig, $self) = @_;
130             my $value = $self->$orig;
131             my $alias = $self->territory_aliases->{$value};
132             return $value if ! defined $alias;
133             return (split /\s+/, $alias)[0];
134             };
135              
136             =item variant_id
137              
138             A valid variant id. The code currently ignores this
139              
140             =cut
141              
142             has 'variant_id' => (
143             is => 'ro',
144             isa => 'Str',
145             default => '',
146             predicate => 'has_variant',
147             );
148              
149             =item extensions
150              
151             A Hashref of extension names and values. You can use this to override
152             the locales number formatting and calendar by passing in the Unicode
153             extension names or aliases as keys and the extension value as the hash
154             value.
155              
156             Currently supported extensions are
157              
158             =over 8
159              
160             =item nu
161              
162             =item numbers
163              
164             The number type can be one of
165              
166             =over 12
167              
168             =item arab
169              
170             Arabic-Indic Digits
171              
172             =item arabext
173              
174             Extended Arabic-Indic Digits
175              
176             =item armn
177              
178             Armenian Numerals
179              
180             =item armnlow
181              
182             Armenian Lowercase Numerals
183              
184             =item bali
185              
186             Balinese Digits
187              
188             =item beng
189              
190             Bengali Digits
191              
192             =item brah
193              
194             Brahmi Digits
195              
196             =item cakm
197              
198             Chakma Digits
199              
200             =item cham
201              
202             Cham Digits
203              
204             =item deva
205              
206             Devanagari Digits
207              
208             =item ethi
209              
210             Ethiopic Numerals
211              
212             =item finance
213              
214             Financial Numerals
215              
216             =item fullwide
217              
218             Full Width Digits
219              
220             =item geor
221              
222             Georgian Numerals
223              
224             =item grek
225              
226             Greek Numerals
227              
228             =item greklow
229              
230             Greek Lowercase Numerals
231              
232             =item gujr
233              
234             Gujarati Digits
235              
236             =item guru
237              
238             Gurmukhi Digits
239              
240             =item hanidays
241              
242             Chinese Calendar Day-of-Month Numerals
243              
244             =item hanidec
245              
246             Chinese Decimal Numerals
247              
248             =item hans
249              
250             Simplified Chinese Numerals
251              
252             =item hansfin
253              
254             Simplified Chinese Financial Numerals
255              
256             =item hant
257              
258             Traditional Chinese Numerals
259              
260             =item hantfin
261              
262             Traditional Chinese Financial Numerals
263              
264             =item hebr
265              
266             Hebrew Numerals
267              
268             =item java
269              
270             Javanese Digits
271              
272             =item jpan
273              
274             Japanese Numerals
275              
276             =item jpanfin
277              
278             Japanese Financial Numerals
279              
280             =item kali
281              
282             Kayah Li Digits
283              
284             =item khmr
285              
286             Khmer Digits
287              
288             =item knda
289              
290             Kannada Digits
291              
292             =item lana
293              
294             Tai Tham Hora Digits
295              
296             =item lanatham
297              
298             Tai Tham Tham Digits
299              
300             =item laoo
301              
302             Lao Digits
303              
304             =item latn
305              
306             Western Digits
307              
308             =item lepc
309              
310             Lepcha Digits
311              
312             =item limb
313              
314             Limbu Digits
315              
316             =item mlym
317              
318             Malayalam Digits
319              
320             =item mong
321              
322             Mongolian Digits
323              
324             =item mtei
325              
326             Meetei Mayek Digits
327              
328             =item mymr
329              
330             Myanmar Digits
331              
332             =item mymrshan
333              
334             Myanmar Shan Digits
335              
336             =item native
337              
338             Native Digits
339              
340             =item nkoo
341              
342             N'Ko Digits
343              
344             =item olck
345              
346             Ol Chiki Digits
347              
348             =item orya
349              
350             Oriya Digits
351              
352             =item osma
353              
354             Osmanya Digits
355              
356             =item roman
357              
358             Roman Numerals
359              
360             =item romanlow
361              
362             Roman Lowercase Numerals
363              
364             =item saur
365              
366             Saurashtra Digits
367              
368             =item shrd
369              
370             Sharada Digits
371              
372             =item sora
373              
374             Sora Sompeng Digits
375              
376             =item sund
377              
378             Sundanese Digits
379              
380             =item takr
381              
382             Takri Digits
383              
384             =item talu
385              
386             New Tai Lue Digits
387              
388             =item taml
389              
390             Traditional Tamil Numerals
391              
392             =item tamldec
393              
394             Tamil Digits
395              
396             =item telu
397              
398             Telugu Digits
399              
400             =item thai
401              
402             Thai Digits
403              
404             =item tibt
405              
406             Tibetan Digits
407              
408             =item traditional
409              
410             Traditional Numerals
411              
412             =item vaii
413              
414             Vai Digits
415              
416             =back
417              
418             =item ca
419              
420             =item calendar
421              
422             You can use this to override a locales default calendar. Valid values are
423              
424             =over 12
425              
426             =item buddhist
427              
428             Buddhist Calendar
429              
430             =item chinese
431              
432             Chinese Calendar
433              
434             =item coptic
435              
436             Coptic Calendar
437              
438             =item dangi
439              
440             Dangi Calendar
441              
442             =item ethiopic
443              
444             Ethiopic Calendar
445              
446             =item ethiopic-amete-alem
447              
448             Ethiopic Amete Alem Calendar
449              
450             =item gregorian
451              
452             Gregorian Calendar
453              
454             =item hebrew
455              
456             Hebrew Calendar
457              
458             =item indian
459              
460             Indian National Calendar
461              
462             =item islamic
463              
464             Islamic Calendar
465              
466             =item islamic-civil
467              
468             Islamic Calendar (tabular, civil epoch)
469              
470             =item islamic-rgsa
471              
472             Islamic Calendar (Saudi Arabia, sighting)
473              
474             =item islamic-tbla
475              
476             Islamic Calendar (tabular, astronomical epoch)
477              
478             =item islamic-umalqura
479              
480             Islamic Calendar (Umm al-Qura)
481              
482             =item iso8601
483              
484             ISO-8601 Calendar
485              
486             =item japanese
487              
488             Japanese Calendar
489              
490             =item persian
491              
492             Persian Calendar
493              
494             =item roc
495              
496             Minguo Calendar
497              
498             =back
499              
500             =back
501              
502             =cut
503              
504             has 'extensions' => (
505             is => 'ro',
506             isa => 'Undef|HashRef',
507             default => undef,
508             writer => '_set_extensions',
509             );
510              
511             =back
512              
513             =head1 Methods
514              
515             The following methods can be called on the locale object
516              
517             =over 4
518              
519             =item id()
520              
521             The local identifier. This is what you get if you attempt to
522             stringify a locale object.
523              
524             =item likely_language()
525              
526             Given a locale with no language passed in or with the explicit language
527             code of C<und>, this method attempts to use the script and territory
528             data to guess the locale's language.
529              
530             =cut
531              
532             has 'likely_language' => (
533             is => 'ro',
534             isa => 'Str',
535             init_arg => undef,
536             lazy => 1,
537             builder => '_build_likely_language',
538             );
539              
540             sub _build_likely_language {
541 0     0   0 my $self = shift;
542            
543 0         0 my $language = $self->language();
544            
545 0 0       0 return $language unless $language eq 'und';
546            
547 0         0 return $self->likely_subtag->language;
548             }
549              
550             =item likely_script()
551              
552             Given a locale with no script passed in this method attempts to use the
553             language and territory data to guess the locale's script.
554              
555             =cut
556              
557             has 'likely_script' => (
558             is => 'ro',
559             isa => 'Str',
560             init_arg => undef,
561             lazy => 1,
562             builder => '_build_likely_script',
563             );
564              
565             sub _build_likely_script {
566 0     0   0 my $self = shift;
567            
568 0         0 my $script = $self->script();
569            
570 0 0       0 return $script if $script;
571            
572 0   0     0 return $self->likely_subtag->script || '';
573             }
574              
575             =item likely_territory()
576              
577             Given a locale with no territory passed in this method attempts to use the
578             language and script data to guess the locale's territory.
579              
580             =back
581              
582             =cut
583              
584             has 'likely_territory' => (
585             is => 'ro',
586             isa => 'Str',
587             init_arg => undef,
588             lazy => 1,
589             builder => '_build_likely_territory',
590             );
591              
592             sub _build_likely_territory {
593 0     0   0 my $self = shift;
594            
595 0         0 my $territory = $self->territory();
596            
597 0 0       0 return $territory if $territory;
598            
599 0   0     0 return $self->likely_subtag->territory || '';
600             }
601              
602             has 'module' => (
603             is => 'ro',
604             isa => 'Object',
605             init_arg => undef,
606             lazy => 1,
607             builder => '_build_module',
608             );
609              
610             sub _build_module {
611             # Create the new path
612 98     98   159 my $self = shift;
613            
614 294 100       553 my @path = map { ucfirst lc }
  294         624  
615 98         428 map { $_ ? $_ : 'Any' } (
616             $self->language_id,
617             $self->script_id,
618             $self->territory_id,
619             );
620              
621 294         517 my @likely_path =
622 98 100       2771 map { ucfirst lc } (
    100          
    100          
623             $self->has_likely_subtag ? $self->likely_subtag->language_id : 'Any',
624             $self->has_likely_subtag ? $self->likely_subtag->script_id : 'Any',
625             $self->has_likely_subtag ? $self->likely_subtag->territory_id : 'Any',
626             );
627            
628 98         406 for (my $i = 0; $i < @path; $i++) {
629 294 100 66     1360 $likely_path[$i] = $path[$i] unless $path[$i] eq 'und' or $path[$i] eq 'Any';
630             }
631            
632             # Note the order we push these onto the stack is important
633 98         362 @path = join '::', @likely_path;
634 98         260 push @path, join '::', $likely_path[0], 'Any', $likely_path[2];
635 98         251 push @path, join '::', @likely_path[0 .. 1];
636 98         196 push @path, join '::', $likely_path[0];
637            
638             # Now we go through the path loading each module
639             # And calling new on it.
640 98         132 my $module;
641 98         199 foreach my $module_name (@path) {
642 261         490 $module_name = "Locale::CLDR::Locales::$module_name";
643 261 100       1276 if (Class::Load::try_load_class($module_name, { -version => $VERSION})) {
644 78         8069 Class::Load::load_class($module_name, { -version => $VERSION});
645             }
646             else {
647 182         54934 next;
648             }
649 78         7832 $module = $module_name->new;
650 78         228 last;
651             }
652              
653             # If we only have the root module then we have a problem as
654             # none of the language specific data is in the root. So we
655             # fall back to the en module
656              
657 97 50       396 if ( ref $module eq 'Locale::CLDR::Locales::Root') {
658 0         0 Class::Load::load_class('Locale::CLDR::Locales::En');
659 0         0 $module = Locale::CLDR::Locales::En->new
660             }
661              
662 97         2219 return $module;
663             }
664              
665             class_has 'method_cache' => (
666             is => 'rw',
667             isa => 'HashRef[HashRef[ArrayRef[Object]]]',
668             init_arg => undef,
669             default => sub { return {}},
670             );
671              
672             has 'break_grapheme_cluster' => (
673             is => 'ro',
674             isa => 'ArrayRef',
675             init_arg => undef(),
676             lazy => 1,
677             default => sub {shift->_build_break('GraphemeClusterBreak')},
678             );
679              
680             has 'break_word' => (
681             is => 'ro',
682             isa => 'ArrayRef',
683             init_arg => undef(),
684             lazy => 1,
685             default => sub {shift->_build_break('WordBreak')},
686             );
687              
688             has 'break_line' => (
689             is => 'ro',
690             isa => 'ArrayRef',
691             init_arg => undef(),
692             lazy => 1,
693             default => sub {shift->_build_break('LineBreak')},
694             );
695              
696             has 'break_sentence' => (
697             is => 'ro',
698             isa => 'ArrayRef',
699             init_arg => undef(),
700             lazy => 1,
701             default => sub {shift->_build_break('SentenceBreak')},
702             );
703              
704             =head2 Meta Data
705              
706             The following methods return, in English, the names if the various
707             id's passed into the locales constructor. I.e. if you passed
708             C<language =E<gt> 'fr'> to the constructor you would get back C<French>
709             for the language.
710              
711             =over 4
712              
713             =item name
714              
715             The locale's name. This is usually built up out of the language,
716             script, territory and variant of the locale
717              
718             =item language
719              
720             The name of the locale's language
721              
722             =item script
723              
724             The name of the locale's script
725              
726             =item territory
727              
728             The name of the locale's territory
729              
730             =item variant
731              
732             The name of the locale's variant
733              
734             =back
735              
736             =head2 Native Meta Data
737              
738             Like Meta Data above this provides the names of the various id's
739             passed into the locale's constructor. However in this case the
740             names are formatted to match the locale. I.e. if you passed
741             C<language =E<gt> 'fr'> to the constructor you would get back
742             C<français> for the language.
743              
744             =over 4
745              
746             =item native_name
747              
748             The locale's name. This is usually built up out of the language,
749             script, territory and variant of the locale. Returned in the locale's
750             language and script
751              
752             =item native_language
753              
754             The name of the locale's language in the locale's language and script.
755              
756             =item native_script
757              
758             The name of the locale's script in the locale's language and script.
759              
760             =item native_territory
761              
762             The name of the locale's territory in the locale's language and script.
763              
764             =item native_variant
765              
766             The name of the locale's variant in the locale's language and script.
767              
768             =back
769              
770             =cut
771              
772             foreach my $property (qw( name language script territory variant)) {
773             has $property => (
774             is => 'ro',
775             isa => 'Str',
776             init_arg => undef,
777             lazy => 1,
778             builder => "_build_$property",
779             );
780              
781 20     20   95 no strict 'refs';
  20         27  
  20         10999  
782             *{"native_$property"} = sub {
783 0     0   0 my ($self, $for) = @_;
784            
785 0   0     0 $for //= $self;
786 0         0 my $build = "_build_native_$property";
787 0         0 return $self->$build($for);
788             };
789             }
790              
791             =head2 Calenders
792              
793             The Calendar data is built to hook into L<DateTime::Locale> so that
794             all Locale::CLDR objects can be used as replacements for DateTime::Locale's
795             locale data. To use, say, the French data do
796              
797             my $french_locale = Locale::CLDR->new('fr_FR');
798             my $french_dt = DateTime->now(locale => $french_locale);
799             say "French month : ", $french_dt->month_name; # prints out the current month in French
800              
801             =over 4
802              
803             =item month_format_wide
804              
805             =item month_format_abbreviated
806              
807             =item month_format_narrow
808              
809             =item month_stand_alone_wide
810              
811             =item month_stand_alone_abbreviated
812              
813             =item month_stand_alone_narrow
814              
815             All the above return an arrayref of month names in the requested style.
816              
817             =item day_format_wide
818              
819             =item day_format_abbreviated
820              
821             =item day_format_narrow
822              
823             =item day_stand_alone_wide
824              
825             =item day_stand_alone_abbreviated
826              
827             =item day_stand_alone_narrow
828              
829             All the above return an array ref of day names in the requested style.
830              
831             =item quarter_format_wide
832              
833             =item quarter_format_abbreviated
834              
835             =item quarter_format_narrow
836              
837             =item quarter_stand_alone_wide
838              
839             =item quarter_stand_alone_abbreviated
840              
841             =item quarter_stand_alone_narrow
842              
843             All the above return an arrayref of quarter names in the requested style.
844              
845             =item am_pm_wide
846              
847             =item am_pm_abbreviated
848              
849             =item am_pm_narrow
850              
851             All the above return the date period name for AM and PM
852             in the requested style
853              
854             =item era_wide
855              
856             =item era_abbreviated
857              
858             =item era_narrow
859              
860             All the above return an array ref of era names. Note that these
861             return the first two eras which is what you normally want for
862             BC and AD etc. but won't work correctly for Japanese calendars.
863              
864             =back
865              
866             =cut
867              
868             foreach my $property (qw(
869             month_format_wide month_format_abbreviated month_format_narrow
870             month_stand_alone_wide month_stand_alone_abbreviated month_stand_alone_narrow
871             day_format_wide day_format_abbreviated day_format_narrow
872             day_stand_alone_wide day_stand_alone_abbreviated day_stand_alone_narrow
873             quarter_format_wide quarter_format_abbreviated quarter_format_narrow
874             quarter_stand_alone_wide quarter_stand_alone_abbreviated quarter_stand_alone_narrow
875             am_pm_wide am_pm_abbreviated am_pm_narrow
876             era_wide era_abbreviated era_narrow
877             era_format_wide era_format_abbreviated era_format_narrow
878             era_stand_alone_wide era_stand_alone_abbreviated era_stand_alone_narrow
879             )) {
880             has $property => (
881             is => 'ro',
882             isa => 'ArrayRef',
883             init_arg => undef,
884             lazy => 1,
885             builder => "_build_$property",
886             clearer => "_clear_$property",
887             );
888             }
889              
890             =pod
891              
892             The next set of methods are not used by DateTime::Locale but CLDR provide
893             the data and you might want it
894              
895             =over 4
896              
897             =item am_pm_format_wide
898              
899             =item am_pm_format_abbreviated
900              
901             =item am_pm_format_narrow
902              
903             =item am_pm_stand_alone_wide
904              
905             =item am_pm_stand_alone_abbreviated
906              
907             =item am_pm_stand_alone_narrow
908              
909             All the above return a hashref keyed on date period
910             with the value being the value for that date period
911              
912             =item era_format_wide
913              
914             =item era_format_abbreviated
915              
916             =item era_format_narrow
917            
918             =item era_stand_alone_wide
919              
920             =item era_stand_alone_abbreviated
921              
922             =item era_stand_alone_narrow
923              
924             All the above return an array ref with I<all> the era data for the
925             locale formatted to the requested width
926              
927             =cut
928              
929             foreach my $property (qw(
930             am_pm_format_wide am_pm_format_abbreviated am_pm_format_narrow
931             am_pm_stand_alone_wide am_pm_stand_alone_abbreviated am_pm_stand_alone_narrow
932             )) {
933             has $property => (
934             is => 'ro',
935             isa => 'HashRef',
936             init_arg => undef,
937             lazy => 1,
938             builder => "_build_$property",
939             clearer => "_clear_$property",
940             );
941             }
942              
943             =item date_format_full
944              
945             =item date_format_long
946              
947             =item date_format_medium
948              
949             =item date_format_short
950              
951             =item time_format_full
952              
953             =item time_format_long
954              
955             =item time_format_medium
956              
957             =item time_format_short
958              
959             =item datetime_format_full
960              
961             =item datetime_format_long
962              
963             =item datetime_format_medium
964              
965             =item datetime_format_short
966              
967             All the above return the CLDR I<date format pattern> for the given
968             element and width
969              
970             =cut
971              
972             foreach my $property (qw(
973             id
974             date_format_full date_format_long
975             date_format_medium date_format_short
976             time_format_full time_format_long
977             time_format_medium time_format_short
978             datetime_format_full datetime_format_long
979             datetime_format_medium datetime_format_short
980             )) {
981             has $property => (
982             is => 'ro',
983             isa => 'Str',
984             init_arg => undef,
985             lazy => 1,
986             builder => "_build_$property",
987             clearer => "_clear_$property",
988             );
989             }
990              
991             has '_available_formats' => (
992             traits => ['Array'],
993             is => 'ro',
994             isa => 'ArrayRef',
995             init_arg => undef,
996             lazy => 1,
997             builder => "_build_available_formats",
998             clearer => "_clear_available_formats",
999             handles => {
1000             available_formats => 'elements',
1001             },
1002             );
1003              
1004             has 'format_data' => (
1005             is => 'ro',
1006             isa => 'HashRef',
1007             init_arg => undef,
1008             lazy => 1,
1009             builder => "_build_format_data",
1010             clearer => "_clear_format_data",
1011             );
1012              
1013             # default_calendar
1014             foreach my $property (qw(
1015             default_date_format_length default_time_format_length
1016             )) {
1017             has $property => (
1018             is => 'ro',
1019             isa => 'Str',
1020             init_arg => undef,
1021             lazy => 1,
1022             builder => "_build_$property",
1023             writer => "set_$property"
1024             );
1025             }
1026              
1027             =item prefers_24_hour_time()
1028              
1029             Returns a boolean value, true if the locale has a preference
1030             for 24 hour time over 12 hour
1031              
1032             =cut
1033              
1034             has 'prefers_24_hour_time' => (
1035             is => 'ro',
1036             isa => 'Bool',
1037             init_arg => undef,
1038             lazy => 1,
1039             builder => "_build_prefers_24_hour_time",
1040             );
1041              
1042             =item first_day_of_week()
1043              
1044             Returns the numeric representation of the first day of the week
1045             With 0 = Saturday
1046              
1047             =item get_day_period($time)
1048              
1049             This method will calculate the correct
1050             period for a given time and return the period name in
1051             the locale's language and script
1052              
1053             =item format_for($date_time_format)
1054              
1055             This method takes a CLDR date time format and returns
1056             the localised version of the format.
1057              
1058             =cut
1059              
1060             has 'first_day_of_week' => (
1061             is => 'ro',
1062             isa => 'Int',
1063             init_arg => undef,
1064             lazy => 1,
1065             builder => "_build_first_day_of_week",
1066             );
1067              
1068             has 'likely_subtag' => (
1069             is => 'ro',
1070             isa => __PACKAGE__,
1071             init_arg => undef,
1072             writer => '_set_likely_subtag',
1073             predicate => 'has_likely_subtag',
1074             );
1075              
1076             sub _build_break {
1077 4     4   8 my ($self, $what) = @_;
1078              
1079 4         11 my $vars = $self->_build_break_vars($what);
1080 4         11 my $rules = $self->_build_break_rules($vars, $what);
1081 4         137 return $rules;
1082             }
1083              
1084             sub _build_break_vars {
1085 4     4   6 my ($self, $what) = @_;
1086              
1087 4         9 my $name = "${what}_variables";
1088 4         12 my @bundles = $self->_find_bundle($name);
1089 4         6 my @vars;
1090 4         9 foreach my $bundle (reverse @bundles) {
1091 4         7 push @vars, @{$bundle->$name};
  4         103  
1092             }
1093              
1094 4         10 my %vars = ();
1095 4         16 while (my ($name, $value) = (shift @vars, shift @vars)) {
1096 146 100       144 last unless defined $name;
1097 142 50       144 if (! defined $value) {
1098 0         0 delete $vars{$name};
1099 0         0 next;
1100             }
1101              
1102 20     20   90 $value =~ s{ ( \$ \p{ID_START} \p{ID_CONTINUE}* ) }{$vars{$1}}msxeg;
  20         22  
  20         233  
  142         171  
  148         221  
1103 142         285 $vars{$name} = $value;
1104             }
1105              
1106 4         11 return \%vars;
1107             }
1108              
1109             sub _build_break_rules {
1110 4     4   10 my ($self, $vars, $what) = @_;
1111              
1112 4         6 my $name = "${what}_rules";
1113 4         13 my @bundles = $self->_find_bundle($name);
1114              
1115 4         6 my %rules;
1116 4         10 foreach my $bundle (reverse @bundles) {
1117 4         5 %rules = (%rules, %{$bundle->$name});
  4         105  
1118             }
1119              
1120 4         6 my @rules;
1121 4         27 foreach my $rule_number ( sort { $a <=> $b } keys %rules ) {
  384         257  
1122             # Test for deleted rules
1123 97 50       206 next unless defined $rules{$rule_number};
1124              
1125 97         503 $rules{$rule_number} =~ s{ ( \$ \p{ID_START} \p{ID_CONTINUE}* ) }{$vars->{$1}}msxeg;
  290         785  
1126 97         590 my ($first, $opp, $second) = split /(×|÷)/, $rules{$rule_number};
1127              
1128 97         115 foreach my $operand ($first, $second) {
1129 194 100       40017 if ($operand =~ m{ \S }msx) {
1130 161         2958 $operand = _unicode_to_perl($operand);
1131             }
1132             else {
1133 33         45 $operand = '.';
1134             }
1135             }
1136            
1137 20     20   281589 no warnings 'deprecated';
  20         31  
  20         23051  
1138 97 100       38726 push @rules, [qr{$first}msx, qr{$second}msx, ($opp eq '×' ? 1 : 0)];
1139             }
1140              
1141 4         22 push @rules, [ '.', '.', 0 ];
1142              
1143 4         55 return \@rules;
1144             }
1145              
1146             sub BUILDARGS {
1147 90     90 1 1272 my $self = shift;
1148 90         164 my %args;
1149              
1150             # Used for arguments when we call new from our own code
1151 90         223 my %internal_args = ();
1152 90 50 66     530 if (@_ > 1 && ref $_[-1] eq 'HASH') {
1153 0         0 %internal_args = %{pop @_};
  0         0  
1154             }
1155              
1156 90 100 66     564 if (1 == @_ && ! ref $_[0]) {
1157 69         677 my ($language, $script, $territory, $variant, $extensions)
1158             = $_[0]=~/^
1159             ([a-zA-Z]+)
1160             (?:[-_]([a-zA-Z]{4}))?
1161             (?:[-_]([a-zA-Z]{2,3}))?
1162             (?:[-_]([a-zA-Z0-9]+))?
1163             (?:[-_]u[_-](.+))?
1164             $/x;
1165              
1166 69         195 foreach ($language, $script, $territory, $variant) {
1167 276 100       497 $_ = '' unless defined $_;
1168             }
1169              
1170             %args = (
1171 69         451 language_id => $language,
1172             script_id => $script,
1173             territory_id => $territory,
1174             variant_id => $variant,
1175             extensions => $extensions,
1176             );
1177             }
1178              
1179 90 100       307 if (! keys %args ) {
1180 0         0 %args = ref $_[0]
1181 21 50       98 ? %{$_[0]}
1182             : @_
1183             }
1184              
1185             # Split up the extensions
1186 90 100 66     371 if ( defined $args{extensions} && ! ref $args{extensions} ) {
1187 2         6 $args{extensions} = {
1188 1         4 map {lc}
1189             split /[_-]/, $args{extensions}
1190             };
1191             }
1192              
1193             # Fix casing of args
1194 90 100       435 $args{language_id} = lc $args{language_id} if defined $args{language_id};
1195 90 100       443 $args{script_id} = ucfirst lc $args{script_id} if defined $args{script_id};
1196 90 100       348 $args{territory_id} = uc $args{territory_id} if defined $args{territory_id};
1197 90 100       322 $args{variant_id} = uc $args{variant_id} if defined $args{variant_id};
1198            
1199             # Set up undefined language
1200 90   100     292 $args{language_id} //= 'und';
1201              
1202 90         577 $self->SUPER::BUILDARGS(%args, %internal_args);
1203             }
1204              
1205             sub BUILD {
1206             my ($self, $args) = @_;
1207              
1208             # Check that the args are valid
1209             # also check for aliases
1210             $args->{language_id} = $self->language_aliases->{$args->{language_id}}
1211             // $args->{language_id};
1212            
1213             die "Invalid language" if $args->{language_id}
1214             && ! first { $args->{language_id} eq $_ } $self->valid_languages;
1215              
1216             die "Invalid script" if $args->{script_id}
1217             && ! first { ucfirst lc $args->{script_id} eq $_ } $self->valid_scripts;
1218              
1219             die "Invalid territory" if $args->{territory_id}
1220             && ( ! ( first { uc $args->{territory_id} eq $_ } $self->valid_territories )
1221             && ( ! $self->territory_aliases->{$self->{territory_id}} )
1222             );
1223            
1224             die "Invalid variant" if $args->{variant_id}
1225             && ( ! ( first { uc $args->{variant_id} eq $_ } $self->valid_variants )
1226             && ( ! $self->variant_aliases->{lc $self->{variant_id}} )
1227             );
1228            
1229             if ($args->{extensions}) {
1230             my %valid_keys = $self->valid_keys;
1231             my %key_aliases = $self->key_names;
1232             my @keys = keys %{$args->{extensions}};
1233              
1234             foreach my $key ( @keys ) {
1235             my $canonical_key = $key_aliases{$key} if exists $key_aliases{$key};
1236             $canonical_key //= $key;
1237             if ($canonical_key ne $key) {
1238             $args->{extensions}{$canonical_key} = delete $args->{extensions}{$key};
1239             }
1240              
1241             $key = $canonical_key;
1242             die "Invalid extension name" unless exists $valid_keys{$key};
1243             die "Invalid extension value" unless
1244             first { $_ eq $args->{extensions}{$key} } @{$valid_keys{$key}};
1245              
1246             $self->_set_extensions($args->{extensions})
1247             }
1248             }
1249              
1250             # Check for variant aliases
1251             if ($args->{variant_id} && (my $variant_alias = $self->variant_aliases->{lc $self->variant_id})) {
1252             delete $args->{variant_id};
1253             my ($what) = keys %{$variant_alias};
1254             my ($value) = values %{$variant_alias};
1255             $args->{$what} = $value;
1256             }
1257            
1258             # Now set up the module
1259             $self->_build_module;
1260             }
1261              
1262             after 'BUILD' => sub {
1263              
1264             my $self = shift;
1265            
1266             # Fix up likely sub tags
1267            
1268             my $likely_subtags = $self->likely_subtags;
1269             my $likely_subtag;
1270             my ($language_id, $script_id, $territory_id) = ($self->language_id, $self->script_id, $self->territory_id);
1271            
1272             unless ($language_id ne 'und' && $script_id && $territory_id ) {
1273             $likely_subtag = $likely_subtags->{join '_', grep { length() } ($language_id, $script_id, $territory_id)};
1274            
1275             if (! $likely_subtag ) {
1276             $likely_subtag = $likely_subtags->{join '_', $language_id, $territory_id};
1277             }
1278            
1279             if (! $likely_subtag ) {
1280             $likely_subtag = $likely_subtags->{join '_', $language_id, $script_id};
1281             }
1282            
1283             if (! $likely_subtag ) {
1284             $likely_subtag = $likely_subtags->{$language_id};
1285             }
1286            
1287             if (! $likely_subtag ) {
1288             $likely_subtag = $likely_subtags->{join '_', 'und', $script_id};
1289             }
1290             }
1291            
1292             my ($likely_language_id, $likely_script_id, $likely_territory_id);
1293             if ($likely_subtag) {
1294             ($likely_language_id, $likely_script_id, $likely_territory_id) = split /_/, $likely_subtag;
1295             $likely_language_id = $language_id unless $language_id eq 'und';
1296             $likely_script_id = $script_id if length $script_id;
1297             $likely_territory_id = $territory_id if length $territory_id;
1298             $self->_set_likely_subtag(__PACKAGE__->new(join '_',$likely_language_id, $likely_script_id, $likely_territory_id));
1299             }
1300            
1301             # Fix up extension overrides
1302             my $extensions = $self->extensions;
1303             if (exists $extensions->{ca}) {
1304             $self->_set_default_ca(($territory_id // $likely_territory_id) => $extensions->{ca});
1305             }
1306              
1307             if (exists $extensions->{nu}) {
1308             $self->_clear_default_nu;
1309             $self->_set_default_nu($extensions->{nu});
1310             }
1311             };
1312              
1313             use overload
1314 40     40   126 'bool' => sub { 1 },
1315 20     20   173 '""' => sub {shift->id};
  20     1   30  
  20         224  
  1         77  
1316              
1317             sub _build_id {
1318 29     29   54 my $self = shift;
1319 29         96 my $string = lc $self->language_id;
1320              
1321 29 100       597 if ($self->script_id) {
1322 21         411 $string.= '_' . ucfirst lc $self->script_id;
1323             }
1324              
1325 29 100       93 if ($self->territory_id) {
1326 21         65 $string.= '_' . uc $self->territory_id;
1327             }
1328              
1329 29 100       628 if ($self->variant_id) {
1330 3         58 $string.= '_' . uc $self->variant_id;
1331             }
1332              
1333 29 50       590 if (defined $self->extensions) {
1334 0         0 $string.= '_u';
1335 0         0 foreach my $key (sort keys %{$self->extensions}) {
  0         0  
1336 0         0 my $value = $self->extensions->{$key};
1337 0         0 $string .= "_${key}_$value";
1338             }
1339 0         0 $string =~ s/_u$//;
1340             }
1341              
1342 29         539 return $string;
1343             }
1344              
1345             sub _get_english {
1346 0     0   0 my $self = shift;
1347 0         0 my $english;
1348 0 0       0 if ($self->language_id eq 'en') {
1349 0         0 $english = $self;
1350             }
1351             else {
1352 0         0 $english = Locale::CLDR->new('en_Latn_US');
1353             }
1354              
1355 0         0 return $english;
1356             }
1357              
1358             sub _build_name {
1359 0     0   0 my $self = shift;
1360              
1361 0         0 return $self->_get_english->native_name($self);
1362             }
1363              
1364             sub _build_native_name {
1365 0     0   0 my ($self, $for) = @_;
1366              
1367 0         0 return $self->locale_name($for);
1368             }
1369              
1370             sub _build_language {
1371 0     0   0 my $self = shift;
1372              
1373 0         0 return $self->_get_english->native_language($self);
1374             }
1375              
1376             sub _build_native_language {
1377 0     0   0 my ($self, $for) = @_;
1378              
1379 0   0     0 return $self->language_name($for) // '';
1380             }
1381              
1382             sub _build_script {
1383 0     0   0 my $self = shift;
1384              
1385 0         0 return $self->_get_english->native_script($self);
1386             }
1387              
1388             sub _build_native_script {
1389 0     0   0 my ($self, $for) = @_;
1390              
1391 0         0 return $self->script_name($for);
1392             }
1393              
1394             sub _build_territory {
1395 0     0   0 my $self = shift;
1396              
1397 0         0 return $self->_get_english->native_territory($self);
1398             }
1399              
1400             sub _build_native_territory {
1401 0     0   0 my ($self, $for) = @_;
1402              
1403 0         0 return $self->territory_name($for);
1404             }
1405              
1406             sub _build_variant {
1407 0     0   0 my $self = shift;
1408              
1409 0         0 return $self->_get_english->native_variant($self);
1410             }
1411              
1412             sub _build_native_variant {
1413 0     0   0 my ($self, $for) = @_;
1414              
1415 0         0 return $self->variant_name($for);
1416             }
1417              
1418             # Method to locate the resource bundle with the required data
1419             sub _find_bundle {
1420 3188     3188   3494 my ($self, $method_name) = @_;
1421 3188 50       88607 my $id = $self->has_likely_subtag()
1422             ? $self->likely_subtag()->id()
1423             : $self->id();
1424            
1425            
1426 3188 100       70199 if ($self->method_cache->{$id}{$method_name}) {
1427             return wantarray
1428 3111 100       20665 ? @{$self->method_cache->{$id}{$method_name}}
  2361         50449  
1429             : $self->method_cache->{$id}{$method_name}[0];
1430             }
1431              
1432 77         1626 foreach my $module ($self->module->meta->linearized_isa) {
1433 385 100       11936 last if $module eq 'Moose::Object';
1434 308 100       1311 if ($module->meta->has_method($method_name)) {
1435 116         4890 push @{$self->method_cache->{$id}{$method_name}}, $module->new;
  116         3030  
1436             }
1437             }
1438              
1439 77 50       2037 return unless $self->method_cache->{$id}{$method_name};
1440             return wantarray
1441 77 100       497 ? @{$self->method_cache->{$id}{$method_name}}
  64         1335  
1442             : $self->method_cache->{$id}{$method_name}[0];
1443             }
1444              
1445             =back
1446              
1447             =head2 Names
1448              
1449             These methods allow you to pass in a locale, either by C<id> or as a
1450             Locale::CLDR object and return an name formatted in the locale of $self.
1451             If you don't pass in a locale then it will use $self.
1452              
1453             =over 4
1454              
1455             =item locale_name($name)
1456              
1457             Returns the given locale name in the current locale's format. The name can be
1458             a locale id or a locale object or non existent. If a name is not passed in
1459             then the name of the current locale is returned.
1460              
1461             =cut
1462              
1463             sub locale_name {
1464 6     6 1 2780 my ($self, $name) = @_;
1465 6   66     19 $name //= $self;
1466              
1467 6 50       22 my $code = ref $name
    100          
1468             ? join ( '_', $name->language_id, $name->territory_id ? $name->territory_id : () )
1469             : $name;
1470            
1471 6         25 my @bundles = $self->_find_bundle('display_name_language');
1472              
1473 6         13 foreach my $bundle (@bundles) {
1474 6         178 my $display_name = $bundle->display_name_language->($code);
1475 6 100       37 return $display_name if defined $display_name;
1476             }
1477              
1478             # $name can be a string or a Locale::CLDR::Locales::*
1479 2 50       9 if (! ref $name) {
1480 2         13 $name = Locale::CLDR->new($name);
1481             }
1482              
1483             # Now we have to process each individual element
1484             # to pass to the display name pattern
1485 2         35 my $language = $self->language_name($name);
1486 2         9 my $script = $self->script_name($name);
1487 2         9 my $territory = $self->territory_name($name);
1488 2         9 my $variant = $self->variant_name($name);
1489              
1490 2         6 my $bundle = $self->_find_bundle('display_name_pattern');
1491 2         12 return $bundle
1492             ->display_name_pattern($language, $territory, $script, $variant);
1493             }
1494              
1495             =item language_name($language)
1496              
1497             Returns the language name in the current locale's format. The name can be
1498             a locale language id or a locale object or non existent. If a name is not
1499             passed in then the language name of the current locale is returned.
1500              
1501             =cut
1502              
1503             sub language_name {
1504 8     8 1 4475 my ($self, $name) = @_;
1505              
1506 8   66     30 $name //= $self;
1507              
1508 8 100       38 my $code = ref $name ? $name->language_id : eval { Locale::CLDR->new(language_id => $name)->language_id };
  3         24  
1509              
1510 8         1434 my $language = undef;
1511 8         3747 my @bundles = $self->_find_bundle('display_name_language');
1512 8 100       25 if ($code) {
1513 7         19 foreach my $bundle (@bundles) {
1514 7         200 my $display_name = $bundle->display_name_language->($code);
1515 7 50       23 if (defined $display_name) {
1516 7         12 $language = $display_name;
1517 7         16 last;
1518             }
1519             }
1520             }
1521             # If we don't have a display name for the language we try again
1522             # with the und tag
1523 8 100       23 if (! defined $language ) {
1524 1         3 foreach my $bundle (@bundles) {
1525 1         27 my $display_name = $bundle->display_name_language->('und');
1526 1 50       4 if (defined $display_name) {
1527 1         2 $language = $display_name;
1528 1         2 last;
1529             }
1530             }
1531             }
1532              
1533 8         41 return $language;
1534             }
1535              
1536             =item all_languages()
1537              
1538             Returns a hash ref keyed on language id of all the languages the system
1539             knows about. The values are the language names for the corresponding id's
1540              
1541             =cut
1542              
1543             sub all_languages {
1544 1     1 1 2 my $self = shift;
1545              
1546 1         4 my @bundles = $self->_find_bundle('display_name_language');
1547 1         2 my %languages;
1548 1         3 foreach my $bundle (@bundles) {
1549 1         24 my $languages = $bundle->display_name_language->();
1550              
1551             # Remove existing languages
1552 1         3 delete @{$languages}{keys %languages};
  1         2  
1553              
1554             # Assign new ones to the hash
1555 1         269 @languages{keys %$languages} = values %$languages;
1556             }
1557              
1558 1         6 return \%languages;
1559             }
1560              
1561             =item script_name($script)
1562              
1563             Returns the script name in the current locale's format. The script can be
1564             a locale script id or a locale object or non existent. If a script is not
1565             passed in then the script name of the current locale is returned.
1566              
1567             =cut
1568              
1569             sub script_name {
1570 7     7 1 5373 my ($self, $name) = @_;
1571 7   66     27 $name //= $self;
1572              
1573 7 100       22 if (! ref $name ) {
1574 3         5 $name = eval {__PACKAGE__->new(script_id => $name)};
  3         23  
1575             }
1576              
1577 7 100 100     1946 if ( ref $name && ! $name->script_id ) {
1578 3         9 return '';
1579             }
1580              
1581 4         10 my $script = undef;
1582 4         22 my @bundles = $self->_find_bundle('display_name_script');
1583 4 100       21 if ($name) {
1584 3         12 foreach my $bundle (@bundles) {
1585 3         88 $script = $bundle->display_name_script->($name->script_id);
1586 3 50       11 if (defined $script) {
1587 3         6 last;
1588             }
1589             }
1590             }
1591              
1592 4 100       11 if (! $script) {
1593 1         3 foreach my $bundle (@bundles) {
1594 1         28 $script = $bundle->display_name_script->('Zzzz');
1595 1 50       4 if (defined $script) {
1596 1         3 last;
1597             }
1598             }
1599             }
1600              
1601 4         32 return $script;
1602             }
1603              
1604             =item all_scripts()
1605              
1606             Returns a hash ref keyed on script id of all the scripts the system
1607             knows about. The values are the script names for the corresponding id's
1608              
1609             =cut
1610              
1611             sub all_scripts {
1612 1     1 1 3349 my $self = shift;
1613              
1614 1         61 my @bundles = $self->_find_bundle('display_name_script');
1615 1         2 my %scripts;
1616 1         2 foreach my $bundle (@bundles) {
1617 1         25 my $scripts = $bundle->display_name_script->();
1618              
1619             # Remove existing scripts
1620 1         3 delete @{$scripts}{keys %scripts};
  1         1  
1621              
1622             # Assign new ones to the hash
1623 1         69 @scripts{keys %$scripts} = values %$scripts;
1624             }
1625              
1626 1         7 return \%scripts;
1627             }
1628              
1629             =item territory_name($territory)
1630              
1631             Returns the territory name in the current locale's format. The territory can be
1632             a locale territory id or a locale object or non existent. If a territory is not
1633             passed in then the territory name of the current locale is returned.
1634              
1635             =cut
1636              
1637             sub territory_name {
1638 9     9 1 6788 my ($self, $name) = @_;
1639 9   66     33 $name //= $self;
1640              
1641 9 100       28 if (! ref $name ) {
1642 5         12 $name = eval { __PACKAGE__->new(language_id => 'und', territory_id => $name); };
  5         34  
1643             }
1644              
1645 9 50 66     3055 if ( ref $name && ! $name->territory_id) {
1646 0         0 return '';
1647             }
1648              
1649 9         18 my $territory = undef;
1650 9         40 my @bundles = $self->_find_bundle('display_name_territory');
1651 9 100       94 if ($name) {
1652 7         17 foreach my $bundle (@bundles) {
1653 7         221 $territory = $bundle->display_name_territory->{$name->territory_id};
1654 7 50       27 if (defined $territory) {
1655 7         13 last;
1656             }
1657             }
1658             }
1659              
1660 9 100       31 if (! defined $territory) {
1661 2         7 foreach my $bundle (@bundles) {
1662 2         53 $territory = $bundle->display_name_territory->{'ZZ'};
1663 2 50       6 if (defined $territory) {
1664 2         6 last;
1665             }
1666             }
1667             }
1668              
1669 9         47 return $territory;
1670             }
1671              
1672             =item all_territories
1673              
1674             Returns a hash ref keyed on territory id of all the territory the system
1675             knows about. The values are the territory names for the corresponding ids
1676              
1677             =cut
1678              
1679             sub all_territories {
1680 1     1 1 2813 my $self = shift;
1681              
1682 1         4 my @bundles = $self->_find_bundle('display_name_territory');
1683 1         2 my %territories;
1684 1         2 foreach my $bundle (@bundles) {
1685 1         23 my $territories = $bundle->display_name_territory;
1686              
1687             # Remove existing territories
1688 1         2 delete @{$territories}{keys %territories};
  1         2  
1689              
1690             # Assign new ones to the hash
1691 1         165 @territories{keys %$territories} = values %$territories;
1692             }
1693              
1694 1         6 return \%territories;
1695             }
1696              
1697             =item variant_name($variant)
1698              
1699             Returns the variant name in the current locale's format. The variant can be
1700             a locale variant id or a locale object or non existent. If a variant is not
1701             passed in then the variant name of the current locale is returned.
1702              
1703             =cut
1704              
1705             sub variant_name {
1706 7     7 1 3404 my ($self, $name) = @_;
1707 7   66     21 $name //= $self;
1708              
1709 7 100       23 if (! ref $name ) {
1710 4         30 $name = __PACKAGE__->new(language_id=> 'und', variant_id => $name);
1711             }
1712              
1713 6 100       184 return '' unless $name->variant_id;
1714 3         9 my $variant = undef;
1715 3 50       74 if ($name->has_variant) {
1716 3         15 my @bundles = $self->_find_bundle('display_name_variant');
1717 3         8 foreach my $bundle (@bundles) {
1718 3         80 $variant= $bundle->display_name_variant->{$name->variant_id};
1719 3 100       11 if (defined $variant) {
1720 2         4 last;
1721             }
1722             }
1723             }
1724              
1725 3   100     32 return $variant // '';
1726             }
1727              
1728             =item key_name($key)
1729              
1730             Returns the key name in the current locale's format. The key must be
1731             a locale key id as a string
1732              
1733             =cut
1734              
1735             sub key_name {
1736 3     3 1 7305 my ($self, $key) = @_;
1737              
1738 3         13 $key = lc $key;
1739            
1740 3         104 my %key_aliases = $self->key_aliases;
1741 3         79 my %key_names = $self->key_names;
1742 3         78 my %valid_keys = $self->valid_keys;
1743              
1744 3   100     18 my $alias = $key_aliases{$key} // '';
1745 3   100     13 my $name = $key_names{$key} // '';
1746              
1747 3 50 66     23 return '' unless exists $valid_keys{$key} || exists $valid_keys{$alias} || exists $valid_keys{$name};
      66        
1748 3         13 my @bundles = $self->_find_bundle('display_name_key');
1749 3         9 foreach my $bundle (@bundles) {
1750 3         78 my $return = $bundle->display_name_key->{$key};
1751 3   66     30 $return //= $bundle->display_name_key->{$alias};
1752 3   33     8 $return //= $bundle->display_name_key->{$name};
1753              
1754 3 50 33     79 return $return if defined $return && length $return;
1755             }
1756              
1757 0   0     0 return ucfirst ($key_names{$name} || $key_names{$alias} || $key_names{$key} || $key);
1758             }
1759              
1760             =item type_name($key, $type)
1761              
1762             Returns the type name in the current locale's format. The key and type must be
1763             a locale key id and type id as a string
1764              
1765             =cut
1766              
1767             sub type_name {
1768 3     3 1 10 my ($self, $key, $type) = @_;
1769              
1770 3         9 $key = lc $key;
1771 3         6 $type = lc $type;
1772              
1773 3         96 my %key_aliases = $self->key_aliases;
1774 3         76 my %valid_keys = $self->valid_keys;
1775 3         75 my %key_names = $self->key_names;
1776              
1777 3   100     21 my $alias = $key_aliases{$key} // '';
1778 3   100     12 my $name = $key_names{$key} // '';
1779              
1780 3 50 66     24 return '' unless exists $valid_keys{$key} || $valid_keys{$alias} || $valid_keys{$name};
      66        
1781 3 100   20   15 return '' unless first { $_ eq $type } @{$valid_keys{$key} || []}, @{$valid_keys{$alias} || []}, @{$valid_keys{$name} || []};
  20 50       21  
  3 100       18  
  3 50       18  
  3         22  
1782              
1783 3         17 my @bundles = $self->_find_bundle('display_name_type');
1784 3         7 foreach my $bundle (@bundles) {
1785 3   66     78 my $types = $bundle->display_name_type->{$key} // $bundle->display_name_type->{$alias} // $bundle->display_name_type->{$name};
      33        
1786 3         8 my $type = $types->{$type};
1787 3 50       100 return $type if defined $type;
1788             }
1789              
1790 0         0 return '';
1791             }
1792            
1793             =item measurement_system_name($measurement_system)
1794              
1795             Returns the measurement system name in the current locale's format. The measurement system must be
1796             a measurement system id as a string
1797              
1798             =cut
1799            
1800             sub measurement_system_name {
1801 6     6 1 30 my ($self, $name) = @_;
1802              
1803             # Fix case of code
1804 6         14 $name = uc $name;
1805 6 100       20 $name = 'metric' if $name eq 'METRIC';
1806              
1807 6         22 my @bundles = $self->_find_bundle('display_name_measurement_system');
1808 6         9 foreach my $bundle (@bundles) {
1809 6         149 my $system = $bundle->display_name_measurement_system->{$name};
1810 6 50       36 return $system if defined $system;
1811             }
1812              
1813 0         0 return '';
1814             }
1815              
1816             =item transform_name($name)
1817              
1818             Returns the transform (transliteration) name in the current locale's format. The transform must be
1819             a transform id as a string
1820              
1821             =cut
1822              
1823             sub transform_name {
1824 1     1 1 3 my ($self, $name) = @_;
1825              
1826 1         4 $name = lc $name;
1827              
1828 1         3 my @bundles = $self->_find_bundle('display_name_transform_name');
1829 1         3 foreach my $bundle (@bundles) {
1830 1         28 my $key = $bundle->display_name_transform_name->{$name};
1831 1 50       10 return $key if length $key;
1832             }
1833              
1834 0         0 return '';
1835             }
1836              
1837             =item code_pattern($type, $locale)
1838              
1839             This method formats a language, script or territory name, given as C<$type>
1840             from C<$locale> in a way expected by the current locale. If $locale is
1841             not passed in or is undef() the method uses the current locale.
1842              
1843             =cut
1844              
1845             sub code_pattern {
1846 3     3 1 35 my ($self, $type, $locale) = @_;
1847 3         8 $type = lc $type;
1848              
1849             # If locale is not passed in then we are using ourself
1850 3   33     14 $locale //= $self;
1851              
1852             # If locale is not an object then inflate it
1853 3 50       11 $locale = __PACKAGE__->new($locale) unless blessed $locale;
1854              
1855 3 50       17 return '' unless $type =~ m{ \A (?: language | script | territory ) \z }xms;
1856              
1857 3         8 my $method = $type . '_name';
1858 3         14 my $substitute = $self->$method($locale);
1859              
1860 3         9 my @bundles = $self->_find_bundle('display_name_code_patterns');
1861 3         6 foreach my $bundle (@bundles) {
1862 3         92 my $text = $bundle->display_name_code_patterns->{$type};
1863 3 50       5 next unless defined $text;
1864 3         14 my $match = qr{ \{ 0 \} }xms;
1865 3         40 $text=~ s{ $match }{$substitute}gxms;
1866 3         21 return $text;
1867             }
1868              
1869 0         0 return '';
1870             }
1871              
1872             =item text_orientation($type)
1873              
1874             Gets the text orientation for the locale. Type must be one of
1875             C<lines> or C<characters>
1876              
1877             =cut
1878              
1879             sub text_orientation {
1880 2     2 1 22 my $self = shift;
1881 2         5 my $type = shift;
1882              
1883 2         6 my @bundles = $self->_find_bundle('text_orientation');
1884 2         4 foreach my $bundle (@bundles) {
1885 2         49 my $orientation = $bundle->text_orientation;
1886 2 50       5 next unless defined $orientation;
1887 2         12 return $orientation->{$type};
1888             }
1889              
1890 0         0 return;
1891             }
1892              
1893             sub _set_casing {
1894 0     0   0 my ($self, $casing, $string) = @_;
1895              
1896 0         0 my @words = $self->split_words($string);
1897              
1898 0 0       0 if ($casing eq 'titlecase-firstword') {
    0          
    0          
1899             # Check to see whether $words[0] is white space or not
1900 0         0 my $firstword_location = 0;
1901 0 0       0 if ($words[0] =~ m{ \A \s }msx) {
1902 0         0 $firstword_location = 1;
1903             }
1904              
1905 0         0 $words[$firstword_location] = ucfirst $words[$firstword_location];
1906             }
1907             elsif ($casing eq 'titlecase-words') {
1908 0         0 @words = map{ ucfirst } @words;
  0         0  
1909             }
1910             elsif ($casing eq 'lowercase-words') {
1911 0         0 @words = map{ lc } @words;
  0         0  
1912             }
1913              
1914 0         0 return join '', @words;
1915             }
1916              
1917             =back
1918              
1919             =head2 Segmentation
1920              
1921             This group of methods allow you to split a string in various ways
1922             Note you need Perl 5.18 or above for this
1923              
1924             =over 4
1925              
1926             =item split_grapheme_clusters($string)
1927              
1928             Splits a string on grapheme clusters using the locale's segmentation rules.
1929             Returns a list of grapheme clusters.
1930              
1931             =cut
1932             # Need 5.18 and above
1933             sub _new_perl {
1934 10 50   10   135 die "You need Perl 5.18 or later for this functionality\n"
1935             if $^V lt v5.18.0;
1936             }
1937              
1938             sub split_grapheme_clusters {
1939 1     1 1 35 _new_perl();
1940            
1941 1         3 my ($self, $string) = @_;
1942              
1943 1         25 my $rules = $self->break_grapheme_cluster;
1944 1         5 my @clusters = $self->_split($rules, $string, 1);
1945              
1946 1         10 return @clusters;
1947             }
1948              
1949             =item split_words($string)
1950              
1951             Splits a string on word boundaries using the locale's segmentation rules.
1952             Returns a list of words.
1953              
1954             =cut
1955              
1956             sub split_words {
1957 1     1 1 847 _new_perl();
1958            
1959 1         3 my ($self, $string) = @_;
1960              
1961 1         40 my $rules = $self->break_word;
1962 1         3 my @words = $self->_split($rules, $string);
1963              
1964 1         7 return @words;
1965             }
1966              
1967             =item split_sentences($string)
1968              
1969             Splits a string on on all points where a sentence could
1970             end using the locale's segmentation rules. Returns a list
1971             the end of each list element is the point where a sentence
1972             could end.
1973              
1974             =cut
1975              
1976             sub split_sentences {
1977 1     1 1 758 _new_perl();
1978            
1979 1         3 my ($self, $string) = @_;
1980              
1981 1         38 my $rules = $self->break_sentence;
1982 1         3 my @sentences = $self->_split($rules, $string);
1983              
1984 1         5 return @sentences;
1985             }
1986              
1987             =item split_lines($string)
1988              
1989             Splits a string on on all points where a line could
1990             end using the locale's segmentation rules. Returns a list
1991             the end of each list element is the point where a line
1992             could end.
1993              
1994             =cut
1995              
1996             sub split_lines {
1997 1     1 1 745 _new_perl();
1998            
1999 1         3 my ($self, $string) = @_;
2000              
2001 1         39 my $rules = $self->break_line;
2002 1         5 my @lines = $self->_split($rules, $string);
2003              
2004 1         6 return @lines;
2005             }
2006              
2007             sub _split {
2008 4     4   8 my ($self, $rules, $string, $grapheme_split) = @_;
2009              
2010 4         21 my @split = (scalar @$rules) x (length($string) - 1);
2011              
2012 4         13 pos($string)=0;
2013             # The Unicode Consortium has deprecated LB=Surrogate but the CLDR still
2014             # uses it, at last in this version.
2015 20     20   58908 no warnings 'deprecated';
  20         33  
  20         55149  
2016 4         14 while (length($string) -1 != pos $string) {
2017 161         151 my $rule_number = 0;
2018 161         145 my $first;
2019 161         241 foreach my $rule (@$rules) {
2020 2656 100       32327 unless( ($first) = $string =~ m{
2021             \G
2022             ($rule->[0])
2023             $rule->[1]
2024             }msx) {
2025 2495         1292336 $rule_number++;
2026 2495         14840 next;
2027             }
2028 161         105532 my $location = pos($string) + length($first) -1;
2029 161         218 $split[$location] = $rule_number;
2030            
2031             # If the left hand side was part of a grapheme cluster
2032             # we have to jump past the entire cluster
2033 161         153 my $length = length $first;
2034 161         496 my ($gc) = $string =~ /\G(\X)/;
2035 161 100 66     1557 $length = (! $grapheme_split && length($gc)) > $length ? length($gc) : $length;
2036 161         379 pos($string)+= $length;
2037 161         612 last;
2038             }
2039             }
2040              
2041 4         13 push @$rules,[undef,undef,1];
2042 4 100       8 @split = map {$rules->[$_][2] ? 1 : 0} @split;
  164         242  
2043 4         10 my $count = 0;
2044 4         8 my @sections = ('.');
2045 4         8 foreach my $split (@split) {
2046 164 100       162 $count++ unless $split;
2047 164         119 $sections[$count] .= '.';
2048             }
2049            
2050 4         16 my $regex = '(' . join(')(', @sections) . ')';
2051 4         72 $regex = qr{ \A $regex \z}msx;
2052 4         45 @split = $string =~ $regex;
2053              
2054 4         30 return @split;
2055             }
2056              
2057             =back
2058              
2059             =head2 Characters
2060              
2061             =over 4
2062              
2063             =item is_exemplar_character( $type, $character)
2064              
2065             =item is_exemplar_character($character)
2066              
2067             Tests if the given character is used in the locale. There are
2068             three possible types; C<main>, C<auxiliary> and C<punctuation>.
2069             If no type is given C<main> is assumed. Unless the C<index> type
2070             is given you will have to have a Perl version of 5.18 or above
2071             to use this method
2072              
2073             =cut
2074              
2075             sub is_exemplar_character {
2076 6     6 1 50 my ($self, @parameters) = @_;
2077 6 100       16 unshift @parameters, 'main' if @parameters == 1;
2078              
2079 6 50       21 _new_perl() unless $parameters[0] eq 'index';
2080            
2081 6         19 my @bundles = $self->_find_bundle('characters');
2082 6         9 foreach my $bundle (@bundles) {
2083 9         217 my $characters = $bundle->characters->{lc $parameters[0]};
2084 9 100       16 next unless defined $characters;
2085 7 100       47 return 1 if fc($parameters[1])=~$characters;
2086             }
2087              
2088 3         13 return;
2089             }
2090              
2091             =item index_characters()
2092              
2093             Returns an array ref of characters normally used when creating
2094             an index and ordered appropriately.
2095              
2096             =cut
2097              
2098             sub index_characters {
2099 1     1 1 297 my $self = shift;
2100              
2101 1         3 my @bundles = $self->_find_bundle('characters');
2102 1         3 foreach my $bundle (@bundles) {
2103 1         25 my $characters = $bundle->characters->{index};
2104 1 50       4 next unless defined $characters;
2105 1         11 return $characters;
2106             }
2107 0         0 return [];
2108             }
2109              
2110             sub _truncated {
2111 6     6   13 my ($self, $type, @params) = @_;
2112              
2113 6         12 my @bundles = $self->_find_bundle('ellipsis');
2114 6         9 foreach my $bundle (@bundles) {
2115 6         134 my $ellipsis = $bundle->ellipsis->{$type};
2116 6 50       11 next unless defined $ellipsis;
2117 6         24 $ellipsis=~s{ \{ 0 \} }{$params[0]}msx;
2118 6         15 $ellipsis=~s{ \{ 1 \} }{$params[1]}msx;
2119 6         27 return $ellipsis;
2120             }
2121             }
2122              
2123             =back
2124              
2125             =head2 Truncation
2126              
2127             These methods format a string to show where part of the string has been removed
2128              
2129             =over 4
2130              
2131             =item truncated_beginning($string)
2132              
2133             Adds the locale specific marking to show that the
2134             string has been truncated at the beginning.
2135              
2136             =cut
2137              
2138             sub truncated_beginning {
2139 1     1 1 20 shift->_truncated(initial => @_);
2140             }
2141              
2142             =item truncated_between($string, $string)
2143              
2144             Adds the locale specific marking to show that something
2145             has been truncated between the two strings. Returns a
2146             string comprising of the concatenation of the first string,
2147             the mark and the second string
2148              
2149             =cut
2150              
2151             sub truncated_between {
2152 1     1 1 5 shift->_truncated(medial => @_);
2153             }
2154              
2155             =item truncated_end($string)
2156              
2157             Adds the locale specific marking to show that the
2158             string has been truncated at the end.
2159              
2160             =cut
2161              
2162             sub truncated_end {
2163 1     1 1 3 shift->_truncated(final => @_);
2164             }
2165              
2166             =item truncated_word_beginning($string)
2167              
2168             Adds the locale specific marking to show that the
2169             string has been truncated at the beginning. This
2170             should be used in preference to C<truncated_beginning>
2171             when the truncation occurs on a word boundary.
2172              
2173             =cut
2174              
2175             sub truncated_word_beginning {
2176 1     1 1 4 shift->_truncated('word-initial' => @_);
2177             }
2178              
2179             =item truncated_word_between($string, $string)
2180              
2181             Adds the locale specific marking to show that something
2182             has been truncated between the two strings. Returns a
2183             string comprising of the concatenation of the first string,
2184             the mark and the second string. This should be used in
2185             preference to C<truncated_between> when the truncation
2186             occurs on a word boundary.
2187              
2188             =cut
2189              
2190             sub truncated_word_between {
2191 1     1 1 4 shift->_truncated('word-medial' => @_);
2192             }
2193              
2194             =item truncated_word_end($string)
2195              
2196             Adds the locale specific marking to show that the
2197             string has been truncated at the end. This should be
2198             used in preference to C<truncated_end> when the
2199             truncation occurs on a word boundary.
2200              
2201             =cut
2202              
2203             sub truncated_word_end {
2204 1     1 1 4 shift->_truncated('word-final' => @_);
2205             }
2206              
2207             =back
2208              
2209             =head2 Quoting
2210              
2211             =over 4
2212              
2213             =item quote($string)
2214              
2215             Adds the locale's primary quotation marks to the ends of the string.
2216             Also scans the string for paired primary and auxiliary quotation
2217             marks and flips them.
2218              
2219             eg passing C<z “abc” z> to this method for the C<en_GB> locale
2220             gives C<“z ‘abc’ z”>
2221              
2222             =cut
2223              
2224             sub quote {
2225 3     3 1 967 my ($self, $text) = @_;
2226              
2227 3         4 my %quote;
2228 3         9 my @bundles = $self->_find_bundle('quote_start');
2229 3         7 foreach my $bundle (@bundles) {
2230 3         74 my $quote = $bundle->quote_start;
2231 3 50       6 next unless defined $quote;
2232 3         3 $quote{start} = $quote;
2233 3         5 last;
2234             }
2235              
2236 3         6 @bundles = $self->_find_bundle('quote_end');
2237 3         6 foreach my $bundle (@bundles) {
2238 3         67 my $quote = $bundle->quote_end;
2239 3 50       6 next unless defined $quote;
2240 3         4 $quote{end} = $quote;
2241 3         3 last;
2242             }
2243              
2244 3         7 @bundles = $self->_find_bundle('alternate_quote_start');
2245 3         6 foreach my $bundle (@bundles) {
2246 3         71 my $quote = $bundle->alternate_quote_start;
2247 3 50       8 next unless defined $quote;
2248 3         6 $quote{alternate_start} = $quote;
2249 3         4 last;
2250             }
2251              
2252 3         12 @bundles = $self->_find_bundle('alternate_quote_end');
2253 3         5 foreach my $bundle (@bundles) {
2254 3         67 my $quote = $bundle->alternate_quote_end;
2255 3 50       6 next unless defined $quote;
2256 3         4 $quote{alternate_end} = $quote;
2257 3         3 last;
2258             }
2259              
2260             # Check to see if we need to switch quotes
2261 3         4 foreach (qw( start end alternate_start alternate_end)) {
2262 12   50     18 $quote{$_} //= '';
2263             }
2264              
2265 3         7 my $from = join ' | ', map {quotemeta} @quote{qw( start end alternate_start alternate_end)};
  12         17  
2266 3         4 my %to;
2267 3         11 @to{@quote{qw( start end alternate_start alternate_end)}}
2268             = @quote{qw( alternate_start alternate_end start end)};
2269              
2270 3         6 my $outer = index($text, $quote{start});
2271 3         3 my $inner = index($text, $quote{alternate_start});
2272              
2273 3 50 33     18 if ($inner == -1 || ($outer > -1 && $inner > -1 && $outer < $inner)) {
      33        
      66        
2274 3         54 $text =~ s{ ( $from ) }{ $to{$1} }msxeg;
  6         14  
2275             }
2276              
2277 3         14 return "$quote{start}$text$quote{end}";
2278             }
2279              
2280             =back
2281              
2282             =head2 Miscellaneous
2283              
2284             =over 4
2285              
2286             =item more_information()
2287              
2288             The more information string is one that can be displayed
2289             in an interface to indicate that more information is
2290             available.
2291              
2292             =cut
2293              
2294             sub more_information {
2295 1     1 1 2 my $self = shift;
2296              
2297 1         4 my @bundles = $self->_find_bundle('more_information');
2298 1         3 foreach my $bundle (@bundles) {
2299 1         24 my $info = $bundle->more_information;
2300 1 50       2 next unless defined $info;
2301 1         5 return $info;
2302             }
2303 0         0 return '';
2304             }
2305              
2306              
2307             =item measurement()
2308              
2309             Returns the measurement type for the locale
2310              
2311             =cut
2312              
2313             sub measurement {
2314 1     1 1 19 my $self = shift;
2315            
2316 1         26 my $measurement_data = $self->measurement_system;
2317 1   50     3 my $territory = $self->territory_id || '001';
2318            
2319 1         3 my $data = $measurement_data->{$territory};
2320            
2321 1         4 until (defined $data) {
2322 0         0 $territory = $self->territory_contained_by->{$territory};
2323 0         0 $data = $measurement_data->{$territory};
2324             }
2325            
2326 1         9 return $data;
2327             }
2328              
2329             =item paper()
2330              
2331             Returns the paper type for the locale
2332              
2333             =cut
2334              
2335             sub paper {
2336 1     1 1 3 my $self = shift;
2337            
2338 1         33 my $paper_size = $self->paper_size;
2339 1   50     4 my $territory = $self->territory_id || '001';
2340            
2341 1         4 my $data = $paper_size->{$territory};
2342            
2343 1         4 until (defined $data) {
2344 0         0 $territory = $self->territory_contained_by->{$territory};
2345 0         0 $data = $paper_size->{$territory};
2346             }
2347            
2348 1         5 return $data;
2349             }
2350              
2351             =back
2352              
2353             =head2 Units
2354              
2355             =over 4
2356              
2357             =item all_units()
2358              
2359             Returns a list of all the unit identifiers for the locale
2360              
2361             =cut
2362              
2363             sub all_units {
2364 0     0 1 0 my $self = shift;
2365 0         0 my @bundles = $self->_find_bundle('units');
2366            
2367 0         0 my %units;
2368 0         0 foreach my $bundle (reverse @bundles) {
2369 0         0 %units = %units, $bundle->units;
2370             }
2371            
2372 0         0 return keys %units;
2373             }
2374              
2375             =item unit($number, $unit, $width)
2376              
2377             Returns the localised string for the given number and unit formatted for the
2378             required width. The number must not be the localized version of the number.
2379             The returned string will be in the locale's format, including the number.
2380              
2381             =cut
2382              
2383             sub unit {
2384 738     738 1 1453 my ($self, $number, $what, $type) = @_;
2385 738   100     1834 $type //= 'long';
2386            
2387 738         2057 my $plural = $self->plural($number);
2388            
2389 738         1350 my @bundles = $self->_find_bundle('units');
2390 738         758 my $format;
2391 738         869 foreach my $bundle (@bundles) {
2392 748 100       18445 if (exists $bundle->units()->{$type}{$what}{$plural}) {
2393 728         17080 $format = $bundle->units()->{$type}{$what}{$plural};
2394 728         858 last;
2395             }
2396            
2397 20 50       443 if (exists $bundle->units()->{$type}{$what}{other}) {
2398 0         0 $format = $bundle->units()->{$type}{$what}{other};
2399 0         0 last;
2400             }
2401             }
2402            
2403             # Check for aliases
2404 738 100       1126 unless ($format) {
2405 10         14 my $original_type = $type;
2406 10         19 my @aliases = $self->_find_bundle('unit_alias');
2407 10         13 foreach my $alias (@aliases) {
2408 10         244 $type = $alias->unit_alias()->{$original_type};
2409 10 100       20 next unless $type;
2410 8         11 foreach my $bundle (@bundles) {
2411 12 100       270 if (exists $bundle->units()->{$type}{$what}{$plural}) {
2412 4         90 $format = $bundle->units()->{$type}{$what}{$plural};
2413 4         10 last;
2414             }
2415            
2416 8 50       182 if (exists $bundle->units()->{$type}{$what}{other}) {
2417 0         0 $format = $bundle->units()->{$type}{$what}{other};
2418 0         0 last;
2419             }
2420             }
2421             }
2422 10         13 $type = $original_type;
2423             }
2424            
2425             # Check for a compound unit that we don't specifically have
2426 738 100 66     1245 if (! $format && (my ($dividend, $divisor) = $what =~ /^(.+)-per-(.+)$/)) {
2427 6         12 return $self->_unit_compound($number, $dividend, $divisor, $type);
2428             }
2429            
2430 732         1661 $number = $self->format_number($number);
2431 732 50       1250 return $number unless $format;
2432            
2433 732         1795 $format =~ s/\{0\}/$number/g;
2434            
2435 732         3491 return $format;
2436             }
2437              
2438             sub _unit_compound {
2439 6     6   45 my ($self, $number, $dividend_what, $divisor_what, $type) = @_;
2440            
2441 6   50     15 $type //= 'long';
2442            
2443 6         13 my $dividend = $self->unit($number, $dividend_what, $type);
2444 6         12 my $divisor = $self->_unit_per($divisor_what, $type);
2445 6 50       9 if ($divisor) {
2446 6         6 my $format = $divisor;
2447 6         12 $format =~ s/\{0\}/$dividend/;
2448 6         30 return $format;
2449             }
2450            
2451 0         0 $divisor = $self->unit(1, $divisor_what, $type);
2452            
2453 0         0 my $one = $self->format_number(1);
2454 0         0 $divisor =~ s/\s*$one\s*//;
2455            
2456 0         0 my @bundles = $self->_find_bundle('units');
2457 0         0 my $format;
2458 0         0 foreach my $bundle (@bundles) {
2459 0 0       0 if (exists $bundle->units()->{$type}{per}{''}) {
2460 0         0 $format = $bundle->units()->{$type}{per}{''};
2461 0         0 last;
2462             }
2463             }
2464              
2465             # Check for aliases
2466 0 0       0 unless ($format) {
2467 0         0 my $original_type = $type;
2468 0         0 my @aliases = $self->_find_bundle('unit_alias');
2469 0         0 foreach my $alias (@aliases) {
2470 0         0 $type = $alias->unit_alias()->{$original_type};
2471 0         0 foreach my $bundle (@bundles) {
2472 0 0       0 if (exists $bundle->units()->{$type}{per}{1}) {
2473 0         0 $format = $bundle->units()->{$type}{per}{1};
2474 0         0 last;
2475             }
2476             }
2477             }
2478             }
2479            
2480 0         0 $format =~ s/\{0\}/$dividend/g;
2481 0         0 $format =~ s/\{1\}/$divisor/g;
2482            
2483 0         0 return $format;
2484             }
2485              
2486             =item unit_name($unit_identifier)
2487              
2488             This method returns the localised name of the unit
2489              
2490             =cut
2491              
2492             sub unit_name {
2493 0     0 1 0 my ($self, $what) = @_;
2494            
2495 0         0 my @bundles = $self->_find_bundle('units');
2496 0         0 my $name;
2497 0         0 foreach my $bundle (@bundles) {
2498 0 0       0 if (exists $bundle->units()->{long}{$what}{name}) {
2499 0         0 return $bundle->units()->{long}{$what}{name};
2500             }
2501             }
2502            
2503             # Check for aliases
2504 0         0 my $type = 'long';
2505 0         0 my @aliases = $self->_find_bundle('unit_alias');
2506 0         0 foreach my $alias (@aliases) {
2507 0         0 $type = $alias->unit_alias()->{$type};
2508 0 0       0 next unless $type;
2509 0         0 foreach my $bundle (@bundles) {
2510 0 0       0 if (exists $bundle->units()->{$type}{$what}{name}) {
2511 0         0 return $bundle->units()->{$type}{$what}{name};
2512             }
2513             }
2514             }
2515            
2516 0         0 return '';
2517             }
2518              
2519             sub _unit_per {
2520 6     6   7 my ($self, $what, $type) = @_;
2521            
2522 6         10 my @bundles = $self->_find_bundle('units');
2523 6         8 my $name;
2524 6         7 foreach my $bundle (@bundles) {
2525 6 50       135 if (exists $bundle->units()->{$type}{$what}{per}) {
2526 6         131 return $bundle->units()->{$type}{$what}{per};
2527             }
2528             }
2529            
2530             # Check for aliases
2531 0         0 my @aliases = $self->_find_bundle('unit_alias');
2532 0         0 foreach my $alias (@aliases) {
2533 0         0 $type = $alias->unit_alias()->{$type};
2534 0 0       0 next unless $type;
2535 0         0 foreach my $bundle (@bundles) {
2536 0 0       0 if (exists $bundle->units()->{$type}{$what}{per}) {
2537 0         0 return $bundle->units()->{$type}{$what}{per};
2538             }
2539             }
2540             }
2541            
2542 0         0 return '';
2543             }
2544              
2545             sub _get_time_separator {
2546 12     12   12 my $self = shift;
2547              
2548 12         28 my @number_symbols_bundles = $self->_find_bundle('number_symbols');
2549 12         43 my $symbols_type = $self->default_numbering_system;
2550            
2551 12         22 foreach my $bundle (@number_symbols_bundles) {
2552 24 50       558 if (exists $bundle->number_symbols()->{$symbols_type}{alias}) {
2553 0         0 $symbols_type = $bundle->number_symbols()->{$symbols_type}{alias};
2554 0         0 redo;
2555             }
2556            
2557 24 100       531 return $bundle->number_symbols()->{$symbols_type}{timeSeparator}
2558             if exists $bundle->number_symbols()->{$symbols_type}{timeSeparator};
2559             }
2560 0         0 return ':';
2561             }
2562              
2563             =item duration_unit($format, @data)
2564              
2565             This method formats a duration. The format must be one of
2566             C<hm>, C<hms> or C<ms> corresponding to C<hour minute>,
2567             C<hour minute second> and C<minute second> respectively.
2568             The data must correspond to the given format.
2569              
2570             =cut
2571              
2572             sub duration_unit {
2573             # data in hh,mm; hh,mm,ss or mm,ss
2574 3     3 1 8 my ($self, $format, @data) = @_;
2575            
2576 3         6 my $bundle = $self->_find_bundle('duration_units');
2577 3         76 my $parsed = $bundle->duration_units()->{$format};
2578            
2579 3         4 my $num_format = '#';
2580 3         14 foreach my $entry ( qr/(hh?)/, qr/(mm?)/, qr/(ss?)/) {
2581 9 100       44 $num_format = '00' if $parsed =~ s/$entry/$self->format_number(shift(@data), $num_format)/e;
  7         24  
2582             }
2583            
2584 3         13 my $time_separator = $self->_get_time_separator;
2585            
2586 3         10 $parsed =~ s/:/$time_separator/g;
2587            
2588 3         17 return $parsed;
2589             }
2590              
2591             =back
2592              
2593             =head2 Yes or No?
2594              
2595             =over 4
2596              
2597             =item is_yes($string)
2598              
2599             Returns true if the passed in string matches the locale's
2600             idea of a string designating yes. Note that under POSIX
2601             rules unless the locale's word for yes starts with C<Y>
2602             (U+0079) then a single 'y' will also be accepted as yes.
2603             The string will be matched case insensitive.
2604              
2605             =cut
2606              
2607             sub is_yes {
2608 2     2 1 5 my ($self, $test_str) = @_;
2609            
2610 2         8 my $bundle = $self->_find_bundle('yesstr');
2611 2 100       49 return $test_str =~ $bundle->yesstr ? 1 : 0;
2612             }
2613              
2614             =item is_no($string)
2615              
2616             Returns true if the passed in string matches the locale's
2617             idea of a string designating no. Note that under POSIX
2618             rules unless the locale's word for no starts with C<n>
2619             (U+006E) then a single 'n' will also be accepted as no
2620             The string will be matched case insensitive.
2621              
2622             =cut
2623              
2624             sub is_no {
2625 2     2 1 5 my ($self, $test_str) = @_;
2626            
2627 2         7 my $bundle = $self->_find_bundle('nostr');
2628 2 100       51 return $test_str =~ $bundle->nostr ? 1 : 0;
2629             }
2630              
2631             =back
2632              
2633             =head2 Transliteration
2634              
2635             This method requires Perl version 5.18 or above to use and for you to have
2636             installed the optional C<Bundle::CLDR::Transformations>
2637              
2638             =over 4
2639              
2640             =item transform(from => $from, to => $to, variant => $variant, text => $text)
2641              
2642             This method returns the transliterated string of C<text> from script C<from>
2643             to script C<to> using variant C<variant>. If C<from> is not given then the
2644             current locale's script is used. If C<text> is not given then it defaults to an
2645             empty string. The C<variant> is optional.
2646              
2647             =cut
2648              
2649             sub transform {
2650 0     0 1 0 _new_perl();
2651            
2652 0         0 my ($self, %params) = @_;
2653            
2654 0   0     0 my $from = $params{from} // $self;
2655 0         0 my $to = $params{to};
2656 0   0     0 my $variant = $params{variant} // 'Any';
2657 0   0     0 my $text = $params{text} // '';
2658            
2659 0 0       0 ($from, $to) = map {ref $_ ? $_->likely_script() : $_} ($from, $to);
  0         0  
2660 0         0 $_ = ucfirst(lc $_) foreach ($from, $to, $variant);
2661            
2662 0         0 my $package = __PACKAGE__ . "::Transformations::${variant}::${from}::${to}";
2663 0         0 eval { Class::Load::load_class($package); };
  0         0  
2664 0 0       0 warn $@ if $@;
2665 0 0       0 return $text if $@; # Can't load transform module so return original text
2666 20     20   132 use feature 'state';
  20         26  
  20         119778  
2667 0         0 state $transforms;
2668 0   0     0 $transforms->{$variant}{$from}{$to} //= $package->new();
2669 0         0 my $rules = $transforms->{$variant}{$from}{$to}->transforms();
2670            
2671             # First get the filter rule
2672 0         0 my $filter = $rules->[0];
2673            
2674             # Break up the input on the filter
2675 0         0 my @text;
2676 0         0 pos($text) = 0;
2677 0         0 while (pos($text) < length($text)) {
2678 0         0 my $characters = '';
2679 0         0 while (my ($char) = $text =~ /($filter)/) {
2680 0         0 $characters .= $char;
2681 0         0 pos($text) = pos($text) + length $char;
2682             }
2683 0         0 push @text, $characters;
2684 0 0       0 last unless pos($text) < length $text;
2685            
2686 0         0 $characters = '';
2687 0         0 while ($text !~ /$filter/) {
2688 0         0 my ($char) = $text =~ /\G(\X)/;
2689 0         0 $characters .= $char;
2690 0         0 pos($text) = pos($text) + length $char;
2691             }
2692 0         0 push @text, $characters;
2693             }
2694            
2695 0         0 my $to_transform = 1;
2696            
2697 0         0 foreach my $characters (@text) {
2698 0 0       0 if ($to_transform) {
2699 0         0 foreach my $rule (@$rules[1 .. @$rules -1 ]) {
2700 0 0       0 if ($rule->{type} eq 'transform') {
2701 0         0 $characters = $self->_transformation_transform($characters, $rule->{data}, $variant);
2702             }
2703             else {
2704 0         0 $characters = $self->_transform_convert($characters, $rule->{data});
2705             }
2706             }
2707             }
2708 0         0 $to_transform = ! $to_transform;
2709             }
2710            
2711 0         0 return join '', @text;
2712             }
2713              
2714             sub _transformation_transform {
2715 0     0   0 my ($self, $text, $rules, $variant) = @_;
2716            
2717 0         0 foreach my $rule (@$rules) {
2718 0         0 for (lc $rule->{to}) {
2719 0 0       0 if ($_ eq 'nfc') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
2720 0         0 $text = Unicode::Normalize::NFC($text);
2721             }
2722             elsif($_ eq 'nfd') {
2723 0         0 $text = Unicode::Normalize::NFD($text);
2724             }
2725             elsif($_ eq 'nfkd') {
2726 0         0 $text = Unicode::Normalize::NFKD($text);
2727             }
2728             elsif($_ eq 'nfkc') {
2729 0         0 $text = Unicode::Normalize::NFKC($text);
2730             }
2731             elsif($_ eq 'lower') {
2732 0         0 $text = lc($text);
2733             }
2734             elsif($_ eq 'upper') {
2735 0         0 $text = uc($text);
2736             }
2737             elsif($_ eq 'title') {
2738 0         0 $text =~ s/(\X)/\u$1/g;
2739             }
2740             elsif($_ eq 'null') {
2741             }
2742             elsif($_ eq 'remove') {
2743 0         0 $text = '';
2744             }
2745             else {
2746 0         0 $text = $self->transform($text, $variant, $rule->{from}, $rule->to);
2747             }
2748             }
2749             }
2750 0         0 return $text;
2751             }
2752              
2753             sub _transform_convert {
2754 0     0   0 my ($self, $text, $rules) = @_;
2755            
2756 0         0 pos($text) = 0; # Make sure we start scanning at the beginning of the text
2757            
2758 0         0 CHARACTER: while (pos($text) < length($text)) {
2759 0         0 foreach my $rule (@$rules) {
2760 0 0 0     0 next if length $rule->{before} && $text !~ /$rule->{before}\G/;
2761 0         0 my $regex = $rule->{replace};
2762 0 0       0 $regex .= '(' . $rule->{after} . ')' if length $rule->{after};
2763 0         0 my $result = 'q(' . $rule->{result} . ')';
2764 0 0       0 $result .= '. $1' if length $rule->{after};
2765 0 0       0 if ($text =~ s/\G$regex/eval $result/e) {
  0         0  
2766 0         0 pos($text) += length($rule->{result}) - $rule->{revisit};
2767 0         0 next CHARACTER;
2768             }
2769             }
2770            
2771 0         0 pos($text)++;
2772             }
2773            
2774 0         0 return $text;
2775             }
2776              
2777             =back
2778              
2779             =head2 Lists
2780              
2781             =over 4
2782              
2783             =item list(@data)
2784              
2785             Returns C<data> as a string formatted by the locales idea of producing a list
2786             of elements. What is returned can be effected by the locale and the number
2787             of items in C<data>. Note that C<data> can contain 0 or more items.
2788              
2789             =cut
2790              
2791             sub list {
2792 5     5 1 46 my ($self, @data) = @_;
2793            
2794             # Short circuit on 0 or 1 entries
2795 5 100       17 return '' unless @data;
2796 4 100       13 return $data[0] if 1 == @data;
2797            
2798 3         12 my @bundles = $self->_find_bundle('listPatterns');
2799            
2800 3         5 my %list_data;
2801 3         5 foreach my $bundle (reverse @bundles) {
2802 6         3 my %listPatterns = %{$bundle->listPatterns};
  6         144  
2803 6         21 @list_data{keys %listPatterns} = values %listPatterns;
2804             }
2805            
2806 3 100       9 if (my $pattern = $list_data{scalar @data}) {
2807 1         7 $pattern=~s/\{([0-9]+)\}/$data[$1]/eg;
  2         12  
2808 1         9 return $pattern;
2809             }
2810            
2811 2         4 my ($start, $middle, $end) = @list_data{qw( start middle end )};
2812            
2813             # First do the end
2814 2         3 my $pattern = $end;
2815 2         6 $pattern=~s/\{1\}/pop @data/e;
  2         4  
2816 2         5 $pattern=~s/\{0\}/pop @data/e;
  2         3  
2817            
2818             # If there is any data left do the middle
2819 2         5 while (@data > 1) {
2820 1         2 my $current = $pattern;
2821 1         2 $pattern = $middle;
2822 1         2 $pattern=~s/\{1\}/$current/;
2823 1         3 $pattern=~s/\{0\}/pop @data/e;
  1         2  
2824             }
2825            
2826             # Now do the start
2827 2         3 my $current = $pattern;
2828 2         2 $pattern = $start;
2829 2         6 $pattern=~s/\{1\}/$current/;
2830 2         4 $pattern=~s/\{0\}/pop @data/e;
  2         3  
2831            
2832 2         9 return $pattern;
2833             }
2834              
2835             =back
2836              
2837             =head2 Pluralisation
2838              
2839             =over 4
2840              
2841             =item plural($number)
2842              
2843             This method takes a number and uses the locale's pluralisation
2844             rules to calculate the type of pluralisation required for
2845             units, currencies and other data that changes depending on
2846             the plural state of the number
2847              
2848             =item plural_range($start, $end)
2849              
2850             This method returns the plural type for the range $start to $end
2851             $start and $end can either be numbers or one of the plural types
2852             C<zero one two few many other>
2853              
2854             =cut
2855              
2856             sub _clear_calendar_data {
2857 0     0   0 my $self = shift;
2858              
2859 0         0 foreach my $property (qw(
2860             month_format_wide month_format_abbreviated month_format_narrow
2861             month_stand_alone_wide month_stand_alone_abbreviated
2862             month_stand_alone_narrow day_format_wide day_format_abbreviated
2863             day_format_narrow day_stand_alone_wide day_stand_alone_abreviated
2864             day_stand_alone_narrow quater_format_wide quater_format_abbreviated
2865             quater_format_narrow quater_stand_alone_wide
2866             quater_stand_alone_abreviated quater_stand_alone_narrow
2867             am_pm_wide am_pm_abbreviated am_pm_narrow am_pm_format_wide
2868             am_pm_format_abbreviated am_pm_format_narrow am_pm_stand_alone_wide
2869             am_pm_stand_alone_abbreviated am_pm_stand_alone_narrow era_wide
2870             era_abbreviated era_narrow date_format_full date_format_long date_format_medium
2871             date_format_short time_format_full
2872             time_format_long time_format_medium time_format_short
2873             datetime_format_full datetime_format_long
2874             datetime_format_medium datetime_format_short
2875             available_formats format_data
2876             )) {
2877 0         0 my $method = "_clear_$property";
2878 0         0 $self->$method;
2879             }
2880             }
2881              
2882             sub _build_any_month {
2883 8     8   14 my ($self, $type, $width) = @_;
2884 8         29 my $default_calendar = $self->default_calendar();
2885 8         25 my @bundles = $self->_find_bundle('calendar_months');
2886             BUNDLES: {
2887 8         11 foreach my $bundle (@bundles) {
  12         16  
2888 16         370 my $months = $bundle->calendar_months;
2889 16 50       34 if (exists $months->{$default_calendar}{alias}) {
2890 0         0 $default_calendar = $months->{$default_calendar}{alias};
2891 0         0 redo BUNDLES;
2892             }
2893              
2894 16 100       42 if (exists $months->{$default_calendar}{$type}{$width}{alias}) {
2895 4         5 ($type, $width) = @{$months->{$default_calendar}{$type}{$width}{alias}}{qw(context type)};
  4         12  
2896 4         11 redo BUNDLES;
2897             }
2898            
2899 12         20 my $result = $months->{$default_calendar}{$type}{$width}{nonleap};
2900 12 100       186 return $result if defined $result;
2901             }
2902 0 0       0 if ($default_calendar ne 'gregorian') {
2903 0         0 $default_calendar = 'gregorian';
2904 0         0 redo BUNDLES;
2905             }
2906             }
2907 0         0 return [];
2908             }
2909              
2910             sub _build_month_format_wide {
2911 2     2   3 my $self = shift;
2912 2         6 my ($type, $width) = (qw(format wide));
2913            
2914 2         8 return $self->_build_any_month($type, $width);
2915             }
2916              
2917             sub _build_month_format_abbreviated {
2918 1     1   2 my $self = shift;
2919 1         2 my ($type, $width) = (qw(format abbreviated));
2920            
2921 1         3 return $self->_build_any_month($type, $width);
2922             }
2923              
2924             sub _build_month_format_narrow {
2925 1     1   1 my $self = shift;
2926 1         3 my ($type, $width) = (qw(format narrow));
2927            
2928 1         3 return $self->_build_any_month($type, $width);
2929             }
2930              
2931             sub _build_month_stand_alone_wide {
2932 1     1   2 my $self = shift;
2933 1         2 my ($type, $width) = ('stand-alone', 'wide');
2934            
2935 1         3 return $self->_build_any_month($type, $width);
2936             }
2937              
2938             sub _build_month_stand_alone_abbreviated {
2939 2     2   4 my $self = shift;
2940 2         5 my ($type, $width) = ('stand-alone', 'abbreviated');
2941            
2942 2         6 return $self->_build_any_month($type, $width);
2943             }
2944              
2945             sub _build_month_stand_alone_narrow {
2946 1     1   2 my $self = shift;
2947 1         3 my ($type, $width) = ('stand-alone', 'narrow');
2948            
2949 1         3 return $self->_build_any_month($type, $width);
2950             }
2951              
2952             sub _build_any_day {
2953 7     7   9 my ($self, $type, $width) = @_;
2954            
2955 7         23 my $default_calendar = $self->default_calendar();
2956              
2957 7         17 my @bundles = $self->_find_bundle('calendar_days');
2958             BUNDLES: {
2959 7         8 foreach my $bundle (@bundles) {
  10         12  
2960 13         303 my $days= $bundle->calendar_days;
2961            
2962 13 50       29 if (exists $days->{$default_calendar}{alias}) {
2963 0         0 $default_calendar = $days->{$default_calendar}{alias};
2964 0         0 redo BUNDLES;
2965             }
2966              
2967 13 100       32 if (exists $days->{$default_calendar}{$type}{$width}{alias}) {
2968 3         2 ($type, $width) = @{$days->{$default_calendar}{$type}{$width}{alias}}{qw(context type)};
  3         10  
2969 3         6 redo BUNDLES;
2970             }
2971 10         13 my $result = $days->{$default_calendar}{$type}{$width};
2972 10 100       25 return [ @{$result}{qw( mon tue wed thu fri sat sun )} ] if keys %$result;
  7         171  
2973             }
2974 0 0       0 if ($default_calendar ne 'gregorian') {
2975 0         0 $default_calendar = 'gregorian';
2976 0         0 redo BUNDLES;
2977             }
2978             }
2979              
2980 0         0 return [];
2981             }
2982              
2983             sub _build_day_format_wide {
2984 2     2   4 my $self = shift;
2985 2         4 my ($type, $width) = (qw(format wide));
2986            
2987 2         9 return $self->_build_any_day($type, $width);
2988             }
2989              
2990             sub _build_day_format_abbreviated {
2991 1     1   1 my $self = shift;
2992 1         2 my ($type, $width) = (qw(format abbreviated));
2993            
2994 1         5 return $self->_build_any_day($type, $width);
2995             }
2996              
2997             sub _build_day_format_narrow {
2998 1     1   3 my $self = shift;
2999 1         2 my ($type, $width) = (qw(format narrow));
3000            
3001 1         2 return $self->_build_any_day($type, $width);
3002             }
3003              
3004             sub _build_day_stand_alone_wide {
3005 1     1   2 my $self = shift;
3006 1         2 my ($type, $width) = ('stand-alone', 'wide');
3007            
3008 1         3 return $self->_build_any_day($type, $width);
3009             }
3010              
3011             sub _build_day_stand_alone_abbreviated {
3012 1     1   2 my $self = shift;
3013 1         2 my ($type, $width) = ('stand-alone', 'abbreviated');
3014              
3015 1         3 return $self->_build_any_day($type, $width);
3016             }
3017              
3018             sub _build_day_stand_alone_narrow {
3019 1     1   2 my $self = shift;
3020 1         2 my ($type, $width) = ('stand-alone', 'narrow');
3021            
3022 1         3 return $self->_build_any_day($type, $width);
3023             }
3024              
3025             sub _build_any_quarter {
3026 6     6   7 my ($self, $type, $width) = @_;
3027            
3028 6         18 my $default_calendar = $self->default_calendar();
3029              
3030 6         14 my @bundles = $self->_find_bundle('calendar_quarters');
3031             BUNDLES: {
3032 6         7 foreach my $bundle (@bundles) {
  9         11  
3033 12         276 my $quarters= $bundle->calendar_quarters;
3034            
3035 12 50       23 if (exists $quarters->{$default_calendar}{alias}) {
3036 0         0 $default_calendar = $quarters->{$default_calendar}{alias};
3037 0         0 redo BUNDLES;
3038             }
3039              
3040 12 100       30 if (exists $quarters->{$default_calendar}{$type}{$width}{alias}) {
3041 3         4 ($type, $width) = @{$quarters->{$default_calendar}{$type}{$width}{alias}}{qw(context type)};
  3         14  
3042 3         6 redo BUNDLES;
3043             }
3044            
3045 9         11 my $result = $quarters->{$default_calendar}{$type}{$width};
3046 9 100       19 return [ @{$result}{qw( 0 1 2 3 )} ] if keys %$result;
  6         148  
3047             }
3048 0 0       0 if ($default_calendar ne 'gregorian') {
3049 0         0 $default_calendar = 'gregorian';
3050 0         0 redo BUNDLES;
3051             }
3052             }
3053              
3054 0         0 return [];
3055             }
3056              
3057             sub _build_quarter_format_wide {
3058 1     1   2 my $self = shift;
3059 1         3 my ($type, $width) = (qw( format wide ));
3060            
3061 1         3 return $self->_build_any_quarter($type, $width);
3062             }
3063              
3064             sub _build_quarter_format_abbreviated {
3065 1     1   2 my $self = shift;
3066 1         3 my ($type, $width) = (qw(format abbreviated));
3067              
3068 1         4 return $self->_build_any_quarter($type, $width);
3069             }
3070              
3071             sub _build_quarter_format_narrow {
3072 1     1   2 my $self = shift;
3073 1         2 my ($type, $width) = (qw(format narrow));
3074              
3075 1         3 return $self->_build_any_quarter($type, $width);
3076             }
3077              
3078             sub _build_quarter_stand_alone_wide {
3079 1     1   2 my $self = shift;
3080 1         2 my ($type, $width) = ('stand-alone', 'wide');
3081              
3082 1         2 return $self->_build_any_quarter($type, $width);
3083             }
3084              
3085             sub _build_quarter_stand_alone_abbreviated {
3086 1     1   2 my $self = shift;
3087 1         2 my ($type, $width) = ('stand-alone', 'abbreviated');
3088            
3089 1         4 return $self->_build_any_quarter($type, $width);
3090             }
3091              
3092             sub _build_quarter_stand_alone_narrow {
3093 1     1   2 my $self = shift;
3094 1         2 my ($type, $width) = ('stand-alone', 'narrow');
3095              
3096 1         6 return $self->_build_any_quarter($type, $width);
3097             }
3098              
3099             sub get_day_period {
3100             # Time in hhmm
3101 3     3 1 1547 my ($self, $time) = @_;
3102            
3103 3         13 my $default_calendar = $self->default_calendar();
3104            
3105 3         8 my $bundle = $self->_find_bundle('day_period_data');
3106            
3107 3         69 my $day_period = $bundle->day_period_data;
3108 3         8 $day_period = $self->$day_period($default_calendar, $time);
3109            
3110 3         69 my $am_pm = $self->am_pm_format_abbreviated;
3111            
3112 3         10 return $am_pm->{$day_period};
3113             }
3114              
3115             sub _build_any_am_pm {
3116 10     10   14 my ($self, $type, $width) = @_;
3117              
3118 10         30 my $default_calendar = $self->default_calendar();
3119 10         10 my @result;
3120 10         22 my @bundles = $self->_find_bundle('day_periods');
3121 10         39 my %return;
3122              
3123             BUNDLES: {
3124 10         8 foreach my $bundle (@bundles) {
  17         29  
3125 34         798 my $am_pm = $bundle->day_periods;
3126            
3127 34 50       66 if (exists $am_pm->{$default_calendar}{alias}) {
3128 0         0 $default_calendar = $am_pm->{$default_calendar}{alias};
3129 0         0 redo BUNDLES;
3130             }
3131              
3132 34 100       53 if (exists $am_pm->{$default_calendar}{$type}{alias}) {
3133 3         5 $type = $am_pm->{$default_calendar}{$type}{alias};
3134 3         6 redo BUNDLES;
3135             }
3136            
3137 31 100       60 if (exists $am_pm->{$default_calendar}{$type}{$width}{alias}) {
3138 4         8 $width = $am_pm->{$default_calendar}{$type}{$width}{alias};
3139 4         10 redo BUNDLES;
3140             }
3141            
3142 27         26 my $result = $am_pm->{$default_calendar}{$type}{$width};
3143            
3144 27         51 foreach (keys %$result) {
3145 60 100       116 $return{$_} = $result->{$_} unless exists $return{$_};
3146             }
3147             }
3148             }
3149              
3150 10         144 return \%return;
3151             }
3152              
3153             # The first 3 are to link in with Date::Time::Locale
3154             sub _build_am_pm_wide {
3155 1     1   1 my $self = shift;
3156 1         3 my ($type, $width) = (qw( format wide ));
3157            
3158 1         3 my $result = $self->_build_any_am_pm($type, $width);
3159            
3160 1         27 return [ @$result{qw( am pm )} ];
3161             }
3162              
3163             sub _build_am_pm_abbreviated {
3164 2     2   4 my $self = shift;
3165 2         5 my ($type, $width) = (qw( format abbreviated ));
3166              
3167 2         9 my $result = $self->_build_any_am_pm($type, $width);
3168            
3169 2         48 return [ @$result{qw( am pm )} ];
3170             }
3171              
3172             sub _build_am_pm_narrow {
3173 1     1   2 my $self = shift;
3174 1         2 my ($type, $width) = (qw( format narrow ));
3175            
3176 1         3 my $result = $self->_build_any_am_pm($type, $width);
3177            
3178 1         47 return [ @$result{qw( am pm )} ];
3179             }
3180              
3181             # Now we do the full set of data
3182             sub _build_am_pm_format_wide {
3183 1     1   2 my $self = shift;
3184 1         3 my ($type, $width) = (qw( format wide ));
3185            
3186 1         3 return $self->_build_any_am_pm($type, $width);
3187             }
3188              
3189             sub _build_am_pm_format_abbreviated {
3190 1     1   2 my $self = shift;
3191 1         3 my ($type, $width) = (qw( format abbreviated ));
3192              
3193 1         3 return $self->_build_any_am_pm($type, $width);
3194             }
3195              
3196             sub _build_am_pm_format_narrow {
3197 1     1   2 my $self = shift;
3198 1         3 my ($type, $width) = (qw( format narrow ));
3199            
3200 1         3 return $self->_build_any_am_pm($type, $width);
3201             }
3202              
3203             sub _build_am_pm_stand_alone_wide {
3204 1     1   1 my $self = shift;
3205 1         3 my ($type, $width) = ('stand-alone', 'wide');
3206            
3207 1         3 return $self->_build_any_am_pm($type, $width);
3208             }
3209              
3210             sub _build_am_pm_stand_alone_abbreviated {
3211 1     1   2 my $self = shift;
3212 1         2 my ($type, $width) = ('stand-alone', 'abbreviated');
3213              
3214 1         3 return $self->_build_any_am_pm($type, $width);
3215             }
3216              
3217             sub _build_am_pm_stand_alone_narrow {
3218 1     1   2 my $self = shift;
3219 1         2 my ($type, $width) = ('stand-alone', 'narrow');
3220            
3221 1         3 return $self->_build_any_am_pm($type, $width);
3222             }
3223              
3224             sub _build_any_era {
3225 9     9   9 my ($self, $width) = @_;
3226              
3227 9         25 my $default_calendar = $self->default_calendar();
3228 9         20 my @bundles = $self->_find_bundle('eras');
3229             BUNDLES: {
3230 9         8 foreach my $bundle (@bundles) {
  9         11  
3231 9         195 my $eras = $bundle->eras;
3232            
3233 9 50       23 if (exists $eras->{$default_calendar}{alias}) {
3234 0         0 $default_calendar = $eras->{$default_calendar}{alias};
3235 0         0 redo BUNDLES;
3236             }
3237              
3238 9 50       19 if (exists $eras->{$default_calendar}{$width}{alias}) {
3239 0         0 $width = $eras->{$default_calendar}{$width}{alias};
3240 0         0 redo BUNDLES;
3241             }
3242            
3243 9         9 my $result = $eras->{$default_calendar}{$width};
3244            
3245 9         9 my @result;
3246 9         41 @result[keys %$result] = values %$result;
3247            
3248 9 50       151 return \@result if keys %$result;
3249             }
3250 0 0       0 if ($default_calendar ne 'gregorian') {
3251 0         0 $default_calendar = 'gregorian';
3252 0         0 redo BUNDLES;
3253             }
3254             }
3255              
3256 0         0 return [];
3257             }
3258            
3259             # The next three are for DateDime::Locale
3260             sub _build_era_wide {
3261 1     1   2 my $self = shift;
3262 1         2 my ($width) = (qw( wide ));
3263              
3264 1         4 my $result = $self->_build_any_era($width);
3265            
3266 1         25 return [@$result[0, 1]];
3267             }
3268              
3269             sub _build_era_abbreviated {
3270 1     1   1 my $self = shift;
3271 1         2 my ($width) = (qw( abbreviated ));
3272              
3273 1         4 my $result = $self->_build_any_era($width);
3274            
3275 1         24 return [@$result[0, 1]];
3276             }
3277              
3278             sub _build_era_narrow {
3279 1     1   1 my $self = shift;
3280 1         3 my ($width) = (qw( narrow ));
3281              
3282 1         3 my $result = $self->_build_any_era($width);
3283            
3284 1         21 return [@$result[0, 1]];
3285             }
3286              
3287             # Now get all the era data
3288             sub _build_era_format_wide {
3289 2     2   2 my $self = shift;
3290 2         3 my ($width) = (qw( wide ));
3291              
3292 2         10 return $self->_build_any_era($width);
3293             }
3294              
3295             sub _build_era_format_abbreviated {
3296 2     2   4 my $self = shift;
3297 2         3 my ($width) = (qw( abbreviated ));
3298              
3299 2         4 return $self->_build_any_era($width);
3300             }
3301              
3302             sub _build_era_format_narrow {
3303 2     2   3 my $self = shift;
3304 2         4 my ($type, $width) = (qw( narrow ));
3305              
3306 2         5 return $self->_build_any_era($type, $width);
3307             }
3308              
3309             *_build_era_stand_alone_wide = \&_build_era_format_wide;
3310             *_build_era_stand_alone_abbreviated = \&_build_era_format_abbreviated;
3311             *_build_era_stand_alone_narrow = \&_build_era_format_narrow;
3312              
3313             sub _build_any_date_format {
3314 9     9   12 my ($self, $width) = @_;
3315 9         30 my $default_calendar = $self->default_calendar();
3316            
3317 9         22 my @bundles = $self->_find_bundle('date_formats');
3318              
3319             BUNDLES: {
3320 9         11 foreach my $bundle (@bundles) {
  9         19  
3321 9         230 my $date_formats = $bundle->date_formats;
3322 9 50       23 if (exists $date_formats->{alias}) {
3323 0         0 $default_calendar = $date_formats->{alias};
3324 0         0 redo BUNDLES;
3325             }
3326            
3327 9         21 my $result = $date_formats->{$default_calendar}{$width};
3328 9 50       111 return $result if $result;
3329             }
3330 0 0       0 if ($default_calendar ne 'gregorian') {
3331 0         0 $default_calendar = 'gregorian';
3332 0         0 redo BUNDLES;
3333             }
3334             }
3335            
3336 0         0 return '';
3337             }
3338              
3339             sub _build_date_format_full {
3340 1     1   1 my $self = shift;
3341            
3342 1         3 my ($width) = ('full');
3343 1         5 return $self->_build_any_date_format($width);
3344             }
3345              
3346             sub _build_date_format_long {
3347 1     1   2 my $self = shift;
3348            
3349 1         2 my ($width) = ('long');
3350 1         4 return $self->_build_any_date_format($width);
3351             }
3352              
3353             sub _build_date_format_medium {
3354 1     1   2 my $self = shift;
3355            
3356 1         2 my ($width) = ('medium');
3357 1         2 return $self->_build_any_date_format($width);
3358             }
3359              
3360             sub _build_date_format_short {
3361 1     1   2 my $self = shift;
3362            
3363 1         1 my ($width) = ('short');
3364 1         3 return $self->_build_any_date_format($width);
3365             }
3366              
3367             sub _build_any_time_format {
3368 9     9   20 my ($self, $width) = @_;
3369 9         27 my $default_calendar = $self->default_calendar();
3370            
3371 9         28 my @bundles = $self->_find_bundle('time_formats');
3372              
3373             BUNDLES: {
3374 9         12 foreach my $bundle (@bundles) {
  9         15  
3375 9         205 my $time_formats = $bundle->time_formats;
3376 9 50       25 if (exists $time_formats->{$default_calendar}{alias}) {
3377 0         0 $default_calendar = $time_formats->{$default_calendar}{alias};
3378 0         0 redo BUNDLES;
3379             }
3380            
3381 9         17 my $result = $time_formats->{$default_calendar}{$width};
3382 9 50       18 if ($result) {
3383 9         26 my $time_separator = $self->_get_time_separator;
3384 9         30 $result =~ s/:/$time_separator/g;
3385 9         102 return $result;
3386             }
3387             }
3388 0 0       0 if ($default_calendar ne 'gregorian') {
3389 0         0 $default_calendar = 'gregorian';
3390 0         0 redo BUNDLES;
3391             }
3392             }
3393 0         0 return '';
3394             }
3395              
3396             sub _build_time_format_full {
3397 1     1   1 my $self = shift;
3398 1         2 my $width = 'full';
3399            
3400 1         3 return $self->_build_any_time_format($width);
3401             }
3402              
3403             sub _build_time_format_long {
3404 1     1   1 my $self = shift;
3405            
3406 1         3 my $width = 'long';
3407 1         3 return $self->_build_any_time_format($width);
3408             }
3409              
3410             sub _build_time_format_medium {
3411 1     1   2 my $self = shift;
3412            
3413 1         2 my $width = 'medium';
3414 1         3 return $self->_build_any_time_format($width);
3415             }
3416              
3417             sub _build_time_format_short {
3418 1     1   2 my $self = shift;
3419            
3420 1         1 my $width = 'short';
3421 1         7 return $self->_build_any_time_format($width);
3422             }
3423              
3424             sub _build_any_datetime_format {
3425 5     5   8 my ($self, $width) = @_;
3426 5         18 my $default_calendar = $self->default_calendar();
3427            
3428 5         14 my @bundles = $self->_find_bundle('datetime_formats');
3429              
3430             BUNDLES: {
3431 5         9 foreach my $bundle (@bundles) {
  5         9  
3432 5         121 my $datetime_formats = $bundle->datetime_formats;
3433 5 50       18 if (exists $datetime_formats->{$default_calendar}{alias}) {
3434 0         0 $default_calendar = $datetime_formats->{$default_calendar}{alias};
3435 0         0 redo BUNDLES;
3436             }
3437            
3438 5         9 my $result = $datetime_formats->{$default_calendar}{$width};
3439 5 50       17 return $result if $result;
3440             }
3441 0 0       0 if ($default_calendar ne 'gregorian') {
3442 0         0 $default_calendar = 'gregorian';
3443 0         0 redo BUNDLES;
3444             }
3445             }
3446            
3447 0         0 return '';
3448             }
3449              
3450             sub _build_datetime_format_full {
3451 2     2   4 my $self = shift;
3452            
3453 2         5 my $width = 'full';
3454 2         7 my $format = $self->_build_any_datetime_format($width);
3455            
3456 2         15 my $date = $self->_build_any_date_format($width);
3457 2         13 my $time = $self->_build_any_time_format($width);
3458            
3459 2         10 $format =~ s/\{0\}/$time/;
3460 2         6 $format =~ s/\{1\}/$date/;
3461            
3462 2         46 return $format;
3463             }
3464              
3465             sub _build_datetime_format_long {
3466 1     1   2 my $self = shift;
3467            
3468 1         2 my $width = 'long';
3469 1         3 my $format = $self->_build_any_datetime_format($width);
3470            
3471 1         2 my $date = $self->_build_any_date_format($width);
3472 1         4 my $time = $self->_build_any_time_format($width);
3473            
3474 1         3 $format =~ s/\{0\}/$time/;
3475 1         4 $format =~ s/\{1\}/$date/;
3476            
3477 1         22 return $format;
3478             }
3479              
3480             sub _build_datetime_format_medium {
3481 1     1   2 my $self = shift;
3482            
3483 1         2 my $width = 'medium';
3484 1         2 my $format = $self->_build_any_datetime_format($width);
3485            
3486 1         5 my $date = $self->_build_any_date_format($width);
3487 1         2 my $time = $self->_build_any_time_format($width);
3488            
3489 1         4 $format =~ s/\{0\}/$time/;
3490 1         3 $format =~ s/\{1\}/$date/;
3491            
3492 1         20 return $format;
3493             }
3494              
3495             sub _build_datetime_format_short {
3496 1     1   2 my $self = shift;
3497            
3498 1         1 my $width = 'short';
3499 1         2 my $format = $self->_build_any_datetime_format($width);
3500            
3501 1         3 my $date = $self->_build_any_date_format($width);
3502 1         4 my $time = $self->_build_any_time_format($width);
3503            
3504 1         5 $format =~ s/\{0\}/$time/;
3505 1         3 $format =~ s/\{1\}/$date/;
3506            
3507 1         22 return $format;
3508             }
3509              
3510             sub _build_format_data {
3511 0     0   0 my $self = shift;
3512 0         0 my $default_calendar = $self->default_calendar();
3513              
3514 0         0 my @bundles = $self->_find_bundle('datetime_formats_available_formats');
3515 0         0 foreach my $calendar ($default_calendar, 'gregorian') {
3516 0         0 foreach my $bundle (@bundles) {
3517 0         0 my $datetime_formats_available_formats = $bundle->datetime_formats_available_formats;
3518 0         0 my $result = $datetime_formats_available_formats->{$calendar};
3519 0 0       0 return $result if $result;
3520             }
3521             }
3522              
3523 0         0 return {};
3524             }
3525              
3526             sub format_for {
3527 0     0 1 0 my ($self, $format) = @_;
3528              
3529 0         0 my $format_data = $self->format_data;
3530              
3531 0   0     0 return $format_data->{$format} // '';
3532             }
3533              
3534             sub _build_available_formats {
3535 0     0   0 my $self = shift;
3536              
3537 0         0 my $format_data = $self->format_data;
3538              
3539 0         0 return [keys %$format_data];
3540             }
3541              
3542             sub _build_default_date_format_length {
3543 0     0   0 my $self = shift;
3544            
3545 0         0 my $default_calendar = $self->default_calendar();
3546              
3547 0         0 my @bundles = $self->_find_bundle('date_formats');
3548 0         0 foreach my $calendar ($default_calendar, 'gregorian') {
3549 0         0 foreach my $bundle (@bundles) {
3550 0         0 my $date_formats = $bundle->date_formats;
3551 0         0 my $result = $date_formats->{$calendar}{default};
3552 0 0       0 return $result if $result;
3553             }
3554             }
3555             }
3556              
3557             sub _build_default_time_format_length {
3558 0     0   0 my $self = shift;
3559            
3560 0         0 my $default_calendar = $self->default_calendar();
3561              
3562 0         0 my @bundles = $self->_find_bundle('time_formats');
3563 0         0 foreach my $calendar ($default_calendar, 'gregorian') {
3564 0         0 foreach my $bundle (@bundles) {
3565 0         0 my $time_formats = $bundle->time_formats;
3566 0         0 my $result = $time_formats->{$calendar}{default};
3567 0 0       0 return $result if $result;
3568             }
3569             }
3570             }
3571              
3572             sub _build_prefers_24_hour_time {
3573 1     1   2 my $self = shift;
3574              
3575 1 50       23 return $self->time_format_short() =~ /h|K/ ? 0 : 1;
3576             }
3577              
3578             {
3579             my %days_2_number = (
3580             mon => 1,
3581             tue => 2,
3582             wen => 3,
3583             thu => 4,
3584             fri => 5,
3585             sat => 6,
3586             sun => 7,
3587             );
3588              
3589             sub _build_first_day_of_week {
3590              
3591 1     1   2 my $self = shift;
3592              
3593 1         8 my $first_day = $self->week_data_first_day;
3594            
3595 1         21 return $days_2_number{$first_day};
3596             }
3597             }
3598              
3599             # Sub to mangle Unicode regex to Perl regex
3600             # Backwards compatibility hack
3601 20 50   20   144 *_unicode_to_perl = eval <<'EOT' || \&_new_perl;
  20     20   31  
  20     161   876  
  20         74  
  20         29  
  20         719  
  161         189  
  161         322  
  161         516  
  98         1378  
  161         1416  
3602             sub {
3603             my $regex = shift;
3604              
3605             return '' unless length $regex;
3606             $regex =~ s/
3607             (?:\\\\)*+ # Pairs of \
3608             (?!\\) # Not followed by \
3609             \K # But we don't want to keep that
3610             (?<set> # Capture this
3611             \[ # Start a set
3612             (?:
3613             [^\[\]\\]+ # One or more of not []\
3614             | # or
3615             (?:
3616             (?:\\\\)*+ # One or more pairs of \ without back tracking
3617             \\. # Followed by an escaped character
3618             )
3619             | # or
3620             (?&set) # An inner set
3621             )++ # Do the inside set stuff one or more times without backtracking
3622             \] # End the set
3623             )
3624             / _convert($1) /xeg;
3625             no warnings "experimental::regex_sets";
3626             no warnings "deprecated"; # Because CLDR uses surrogates
3627             return qr/$regex/x;
3628             };
3629              
3630             EOT
3631              
3632             # Backwards compatibility hack
3633 98 50   98   130 *_convert = eval <<'EOT' || \&_new_perl;
  98 50       154  
  98         119  
  0         0  
  98         73  
  98         631  
  98         113  
  98         116  
  98         1778  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
3634             sub {
3635             my $set = shift;
3636            
3637             # Some definitions
3638             my $posix = qr/(?(DEFINE)
3639             (?<posix> (?> \[: .+? :\] ) )
3640             )/x;
3641            
3642             # Convert Unicode escapes \u1234 to characters
3643             $set =~ s/\\u(\p{Ahex}+)/chr(hex($1))/egx;
3644            
3645             # Check to see if this is a normal character set
3646             my $normal = 0;
3647            
3648             $normal = 1 if $set =~ /^
3649             \s* # Possible white space
3650             \[ # Opening set
3651             ^? # Possible negation
3652             (?: # One of
3653             [^\[\]]++ # Not an open or close set
3654             | # Or
3655             (?<=\\)[\[\]] # An open or close set preceded by \
3656             | # Or
3657             (?:
3658             \s* # Possible white space
3659             (?&posix) # A posix class
3660             (?! # Not followed by
3661             \s* # Possible white space
3662             [&-] # A Unicode regex op
3663             \s* # Possible white space
3664             \[ # A set opener
3665             )
3666             )
3667             )+
3668             \] # Close the set
3669             \s* # Possible white space
3670             $
3671             $posix
3672             /x;
3673            
3674             # Convert posix to perl
3675             $set =~ s/\[:(.*?):\]/\\p{$1}/g;
3676            
3677             if ($normal) {
3678             return "$set";
3679             }
3680            
3681             # Fix up [abc[de]] to [[abc][de]]
3682             $set =~ s/\[ ( (?>\^? \s*) [^\]]+? ) \s* \[/[[$1][/gx;
3683            
3684             # Fix up [[ab]cde] to [[ab][cde]]
3685             $set =~ s/\[ \^?+ \s* \[ [^\]]+? \] \K \s* ( [^\[]+ ) \]/[$1]]/gx;
3686            
3687             # Unicode uses ^ to compliment the set where as Perl uses !
3688             $set =~ s/\[ \^ \s*/[!/gx;
3689            
3690             # The above can leave us with empty sets. Strip them out
3691             $set =~ s/\[\]//g;
3692            
3693             # Fixup inner sets with no operator
3694             1 while $set =~ s/ \] \s* \[ /] + [/gx;
3695             1 while $set =~ s/ \] \s * (\\p\{.*?\}) /] + $1/xg;
3696             1 while $set =~ s/ \\p\{.*?\} \s* \K \[ / + [/xg;
3697             1 while $set =~ s/ \\p\{.*?\} \s* \K (\\p\{.*?\}) / + $1/xg;
3698            
3699             # Unicode uses [] for grouping as well as starting an inner set
3700             # Perl uses ( ) So fix that up now
3701            
3702             $set =~ s/. \K \[ (?> (!?) \s*) \[ /($1\[/gx;
3703             $set =~ s/ \] \s* \] (.) /])$1/gx;
3704            
3705             return "(?$set)";
3706             }
3707              
3708             EOT
3709              
3710             # The following pod is for methods defined in the Moose Role
3711             # files that are automatically generated from the data
3712             =back
3713              
3714             =head2 Valid codes
3715              
3716             =over 4
3717              
3718             =item valid_languages()
3719              
3720             This method returns a list containing all the valid language codes
3721              
3722             =item valid_scripts()
3723              
3724             This method returns a list containing all the valid script codes
3725              
3726             =item valid_territories()
3727              
3728             This method returns a list containing all the valid territory codes
3729              
3730             =item valid_variants()
3731              
3732             This method returns a list containing all the valid variant codes
3733              
3734             =item key_aliases()
3735              
3736             This method returns a hash that maps valid keys to their valid aliases
3737              
3738             =item key_names()
3739              
3740             This method returns a hash that maps valid key aliases to their valid keys
3741              
3742             =item valid_keys()
3743              
3744             This method returns a hash of valid keys and the valid type codes you
3745             can have with each key
3746              
3747             =item language_aliases()
3748              
3749             This method returns a hash that maps valid language codes to their valid aliases
3750              
3751             =item territory_aliases()
3752              
3753             This method returns a hash that maps valid territory codes to their valid aliases
3754              
3755             =item variant_aliases()
3756              
3757             This method returns a hash that maps valid variant codes to their valid aliases
3758              
3759             =back
3760              
3761             =head2 Information about weeks
3762              
3763             There are no standard codes for the days of the weeks so CLDR uses the following
3764             three letter codes to represent unlocalised days
3765              
3766             =over 4
3767              
3768             =item sun
3769              
3770             Sunday
3771              
3772             =item mon
3773              
3774             Monday
3775              
3776             =item tue
3777              
3778             Tuesday
3779              
3780             =item wed
3781              
3782             Wednesday
3783              
3784             =item thu
3785              
3786             Thursday
3787              
3788             =item fri
3789              
3790             Friday
3791              
3792             =item sat
3793              
3794             Saturday
3795              
3796             =back
3797              
3798             =cut
3799              
3800             sub _week_data {
3801 5     5   7 my ($self, $territory_id, $week_data_hash) = @_;
3802            
3803 5   33     21 $territory_id //= ( $self->territory_id || $self->likely_subtag->territory_id );
      33        
3804            
3805 5 100       17 return $week_data_hash->{$territory_id} if exists $week_data_hash->{$territory_id};
3806            
3807 2         2 while (1) {
3808 8         178 $territory_id = $self->territory_contained_by()->{$territory_id};
3809 8 50       11 return unless defined $territory_id;
3810 8 100       18 return $week_data_hash->{$territory_id} if exists $week_data_hash->{$territory_id};
3811             }
3812             }
3813              
3814             =over 4
3815              
3816             =item week_data_min_days($territory_id)
3817              
3818             This method takes an optional territory id and returns a the minimum number of days
3819             a week must have to count as the starting week of the new year. It uses the current
3820             locale's territory if no territory id is passed in.
3821              
3822             =cut
3823              
3824             sub week_data_min_days {
3825 1     1 1 2 my ($self, $territory_id) = @_;
3826            
3827 1         30 my $week_data_hash = $self->_week_data_min_days();
3828 1         3 return _week_data($self, $territory_id, $week_data_hash);
3829             }
3830              
3831             =item week_data_first_day($territory_id)
3832              
3833             This method takes an optional territory id and returns the three letter code of the
3834             first day of the week for that territory. If no territory id is passed in then it
3835             uses the current locale's territory.
3836              
3837             =cut
3838              
3839             sub week_data_first_day {
3840 2     2 1 2 my ($self, $territory_id) = @_;
3841            
3842 2         55 my $week_data_hash = $self->_week_data_first_day();
3843 2         9 return _week_data($self, $territory_id, $week_data_hash);
3844             }
3845              
3846             =item week_data_weekend_start()
3847              
3848             This method takes an optional territory id and returns the three letter code of the
3849             first day of the week end for that territory. If no territory id is passed in then it
3850             uses the current locale's territory.
3851              
3852             =cut
3853              
3854             sub week_data_weekend_start {
3855 1     1 1 2 my ($self, $territory_id) = @_;
3856 1         31 my $week_data_hash = $self->_week_data_weekend_start();
3857            
3858 1         3 return _week_data($self, $territory_id, $week_data_hash);
3859             }
3860              
3861             =item week_data_weekend_end()
3862              
3863             This method takes an optional territory id and returns the three letter code of the
3864             first day of the week end for that territory. If no territory id is passed in then it
3865             uses the current locale's territory.
3866              
3867             =cut
3868              
3869             sub week_data_weekend_end {
3870 1     1 1 3 my ($self, $territory_id) = @_;
3871 1         32 my $week_data_hash = $self->_week_data_weekend_end();
3872            
3873 1         3 return _week_data($self, $territory_id, $week_data_hash);
3874             }
3875              
3876             =item month_patterns($context, $width, $type)
3877              
3878             The Chinese lunar calendar can insert a leap month after nearly any month of its year;
3879             when this happens, the month takes the name of the preceding month plus a special marker.
3880             The Hindu lunar calendars can insert a leap month before any one or two months of the year;
3881             when this happens, not only does the leap month take the name of the following month plus a
3882             special marker, the following month also takes a special marker. Moreover, in the Hindu
3883             calendar sometimes a month is skipped, in which case the preceding month takes a special marker
3884             plus the names of both months. The monthPatterns() method returns an array ref of month names
3885             with the marker added.
3886              
3887             =cut
3888              
3889             my %month_functions = (
3890             format => {
3891             wide => 'month_format_wide',
3892             abbreviated => 'month_format_abbreviated',
3893             narrow => 'month_format_narrow',
3894             },
3895             'stand-alone' => {
3896             wide => 'month_stand_alone_wide',
3897             abbreviated => 'month_stand_alone_abbreviated',
3898             narrow => 'month_stand_alone_narrow',
3899             }
3900             );
3901              
3902             sub month_patterns {
3903 1     1 1 4 my ($self, $context, $width, $type) = @_;
3904            
3905 1         2 my @months;
3906 1 50       4 if ($context eq 'numeric') {
3907 0         0 @months = ( 1 .. 14 );
3908             }
3909             else {
3910 1         5 my $months_method = $month_functions{$context}{$width};
3911 1         31 my $months = $self->$months_method;
3912 1         4 @months = @$months;
3913             }
3914            
3915 1         4 my $default_calendar = $self->default_calendar();
3916            
3917 1         3 my @bundles = $self->_find_bundle('month_patterns');
3918              
3919 1         2 my $result;
3920             BUNDLES: {
3921 1         2 foreach my $bundle (@bundles) {
  2         3  
3922 2         51 my $month_patterns = $bundle->month_patterns;
3923 2 50       6 if (exists $month_patterns->{$default_calendar}{alias}) {
3924 0         0 $default_calendar = $month_patterns->{$default_calendar}{alias};
3925 0         0 redo BUNDLES;
3926             }
3927            
3928             # Check for width alias
3929 2 100       7 if (exists $month_patterns->{$default_calendar}{$context}{$width}{alias}) {
3930 1         3 $context = $month_patterns->{$default_calendar}{$context}{$width}{alias}{context};
3931 1         3 $width = $month_patterns->{$default_calendar}{$context}{$width}{alias}{width};
3932 1         3 redo BUNDLES;
3933             }
3934            
3935 1         2 $result = $month_patterns->{$default_calendar}{$context}{$width}{$type};
3936 1 50       4 last BUNDLES if $result;
3937             }
3938 0 0       0 if ($default_calendar ne 'gregorian') {
3939 0         0 $default_calendar = 'gregorian';
3940 0         0 redo BUNDLES;
3941             }
3942             }
3943            
3944 1 50       3 if ($result) {
3945 1         2 foreach my $month (@months) {
3946 12         14 (my $fixed_month = $result) =~ s/\{0\}/$month/g;
3947 12         12 $month = $fixed_month;
3948             }
3949             }
3950            
3951 1         12 return \@months;
3952             }
3953              
3954             =item cyclic_name_sets($context, $width, $type)
3955              
3956             This method returns an arrayref containing the cyclic names for the locale's
3957             default calendar using the given context, width and type.
3958              
3959             Context can can currently only be c<format>
3960              
3961             Width is one of C<abbreviated>, C<narrow> or C<wide>
3962              
3963             Type is one of C<dayParts>, C<days>, C<months>, C<solarTerms>, C<years> or C<zodiacs>
3964              
3965             =cut
3966              
3967             sub cyclic_name_sets {
3968 1     1 1 3 my ($self, $context, $width, $type) = @_;
3969            
3970 1         4 my @bundles = $self->_find_bundle('cyclic_name_sets');
3971 1         8 my $default_calendar = $self->default_calendar();
3972 1         3 foreach my $bundle (@bundles) {
3973 2         53 my $cyclic_name_set = $bundle->cyclic_name_sets();
3974             NAME_SET: {
3975 2 50       2 if (my $alias_calendar = $cyclic_name_set->{$default_calendar}{alias}) {
  3         9  
3976 0         0 $default_calendar = $alias_calendar;
3977 0         0 redo NAME_SET;
3978             }
3979            
3980 3 50       8 if (my $type_alias = $cyclic_name_set->{$default_calendar}{$type}{alias}) {
3981 0         0 $type = $type_alias;
3982 0         0 redo NAME_SET;
3983             }
3984            
3985 3 100       8 if (my $width_alias = $cyclic_name_set->{$default_calendar}{$type}{$context}{$width}{alias}) {
3986 1         2 $context = $width_alias->{context};
3987 1         2 $type = $width_alias->{name_set};
3988 1         3 $width = $width_alias->{type};
3989 1         3 redo NAME_SET;
3990             }
3991            
3992 2         7 my $return = [
3993 31         22 @{ $cyclic_name_set->{$default_calendar}{$type}{$context}{$width} }
3994 2         4 {sort { $a <=> $b } keys %{ $cyclic_name_set->{$default_calendar}{$type}{$context}{$width} }}
  2         13  
3995             ];
3996            
3997 2 100       14 return $return if @$return;
3998             }
3999             }
4000 0         0 return [];
4001             }
4002              
4003             =back
4004              
4005             =head2 Territory Containment
4006              
4007             =over 4
4008              
4009             =item territory_contains()
4010              
4011             This method returns a hash ref keyed on territory id. The value is an array ref.
4012             Each element of the array ref is a territory id of a territory immediately
4013             contained in the territory used as the key
4014              
4015             =item territory_contained_by()
4016              
4017             This method returns a hash ref keyed on territory id. The value of the hash
4018             is the territory id of the immediately containing territory.
4019              
4020             =back
4021              
4022             =head2 Numbering Systems
4023              
4024             =over 4
4025              
4026             =item numbering_system()
4027              
4028             This method returns a hash ref keyed on numbering system id which, for a given
4029             locale, can be got by calling the default_numbering_system() method. The values
4030             of the hash are a two element hash ref the keys being C<type> and C<data>. If the
4031             type is C<numeric> then the data is an array ref of characters. The position in the
4032             array matches the numeric value of the character. If the type is C<algorithmic>
4033             then data is the name of the algorithm used to display numbers in that format.
4034              
4035             =back
4036              
4037             =head2 Number Formatting
4038              
4039             =over 4
4040              
4041             =item format_number($number, $format, $currency, $for_cash)
4042              
4043             This method formats the number $number using the format $format. If the format contains
4044             the currency symbol C<¤> then the currency symbol for the currency code in $currency
4045             will be used. If $currency is undef() then the default currency code for the locale
4046             will be used.
4047              
4048             Note that currency codes are based on territory so if you do not pass in a currency
4049             and your locale did not get passed a territory in the constructor you are going
4050             to end up with the L<likely sub tag's|/likely_subtags> idea of the currency. This
4051             functionality may be removed or at least changed to emit a warning in future
4052             releases.
4053              
4054             $for_cash is only used during currency formatting. If true then cash rounding
4055             will be used otherwise financial rounding will be used.
4056              
4057             This function also handles rule based number formatting. If $format is string equivalent
4058             to one of the current locale's public rule based number formats then $number will be
4059             formatted according to that rule.
4060              
4061             =item add_currency_symbol($format, $symbol)
4062              
4063             This method returns the format with the currency symbol $symbol correctly inserted
4064             into the format
4065              
4066             =item parse_number_format($format, $currency, $currency_data, $for_cash)
4067              
4068             This method parses a CLDR numeric format string into a hash ref containing data used to
4069             format a number. If a currency is being formatted then $currency contains the
4070             currency code, $currency_data is a hashref containing the currency rounding
4071             information and $for_cash is a flag to signal cash or financial rounding.
4072              
4073             This should probably be a private function.
4074              
4075             =item round($number, $increment, $decimal_digits)
4076              
4077             This method returns $number rounded to the nearest $increment with $decimal_digits
4078             digits after the decimal point
4079              
4080             =item get_formatted_number($number, $format, $currency_data, $for_cash)
4081              
4082             This method takes the $format produced by parse_number_format() and uses it to
4083             parse $number. It returns a string containing the parsed number. If a currency
4084             is being formatted then $currency_data is a hashref containing the currency
4085             rounding information and $for_cash is a flag to signal cash or financial rounding.
4086              
4087             =item get_digits()
4088              
4089             This method returns an array containing the digits used by the locale, The order of the
4090             array is the order of the digits. It the locale's numbering system is C<algorithmic> it
4091             will return C<[0,1,2,3,4,5,6,7,8,9]>
4092              
4093             =item default_numbering_system()
4094              
4095             This method returns the numbering system id for the locale.
4096              
4097             =back
4098              
4099             =head2 Measurement Information
4100              
4101             =over 4
4102              
4103             =item measurement_system()
4104              
4105             This method returns a hash ref keyed on territory, the value being the measurement system
4106             id for the territory. If the territory you are interested in is not listed use the
4107             territory_contained_by() method until you find an entry.
4108              
4109             =item paper_size()
4110              
4111             This method returns a hash ref keyed on territory, the value being the paper size used
4112             in that territory. If the territory you are interested in is not listed use the
4113             territory_contained_by() method until you find an entry.
4114              
4115             =back
4116              
4117             =head2 Likely Tags
4118              
4119             =over 4
4120              
4121             =item likely_subtags()
4122              
4123             A full locale tag requires, as a minimum, a language, script and territory code. However for
4124             some locales it is possible to infer the missing element if the other two are given, e.g.
4125             given C<en_GB> you can infer the script will be latn. It is also possible to fill in the
4126             missing elements of a locale with sensible defaults given sufficient knowledge of the layout
4127             of the CLDR data and usage patterns of locales around the world.
4128              
4129             This function returns a hash ref keyed on partial locale id's with the value being the locale
4130             id for the most likely language, script and territory code for the key.
4131              
4132             =back
4133              
4134             =head2 Currency Information
4135              
4136             =over 4
4137              
4138             =item currency_fractions()
4139              
4140             This method returns a hash ref keyed on currency id. The value is a hash ref containing four keys.
4141             The keys are
4142              
4143             =over 8
4144              
4145             =item digits
4146              
4147             The number of decimal digits normally formatted.
4148              
4149             =item rounding
4150              
4151             The rounding increment, in units of 10^-digits.
4152              
4153             =item cashdigits
4154              
4155             The number of decimal digits to be used when formatting quantities used in cash transactions (as opposed
4156             to a quantity that would appear in a more formal setting, such as on a bank statement).
4157              
4158             =item cashrounding
4159              
4160             The cash rounding increment, in units of 10^-cashdigits.
4161              
4162             =back
4163              
4164             =item default_currency($territory_id)
4165              
4166             This method returns the default currency id for the territory id.
4167             If no territory id is given then the current locale's is used
4168              
4169             =cut
4170              
4171             sub default_currency {
4172 1     1 1 2 my ($self, $territory_id) = @_;
4173            
4174 1   33     6 $territory_id //= $self->territory_id;
4175            
4176 1 50       3 if (! $territory_id) {
4177 0         0 $territory_id = $self->likely_subtag->territory_id;
4178 0         0 warn "Locale::CLDR::default_currency:- No territory given using $territory_id at ";
4179             }
4180            
4181 1         25 my $default_currencies = $self->_default_currency;
4182            
4183 1 50       5 return $default_currencies->{$territory_id} if exists $default_currencies->{$territory_id};
4184            
4185 0         0 while (1) {
4186 0         0 $territory_id = $self->territory_contained_by($territory_id);
4187 0 0       0 last unless $territory_id;
4188 0 0       0 return $default_currencies->{$territory_id} if exists $default_currencies->{$territory_id};
4189             }
4190             }
4191              
4192             =item currency_symbol($currency_id)
4193              
4194             This method returns the currency symbol for the given currency id in the current locale.
4195             If no currency id is given it uses the locale's default currency
4196              
4197             =cut
4198              
4199             sub currency_symbol {
4200 1     1 1 1 my ($self, $currency_id) = @_;
4201            
4202 1   33     3 $currency_id //= $self->default_currency;
4203            
4204 1         4 my @bundles = reverse $self->_find_bundle('curriencies');
4205 1         3 foreach my $bundle (@bundles) {
4206 1         23 my $symbol = $bundle->curriencies()->{$currency_id}{symbol};
4207 1 50       7 return $symbol if $symbol;
4208             }
4209            
4210 0           return '';
4211             }
4212              
4213             =back
4214              
4215             =head2 Calendar Information
4216              
4217             =over 4
4218              
4219             =item calendar_preferences()
4220              
4221             This method returns a hash ref keyed on territory id. The values are array refs containing the preferred
4222             calendar id's in order of preference.
4223              
4224             =item default_calendar($territory)
4225              
4226             This method returns the default calendar id for the given territory. If no territory id given it
4227             used the territory of the current locale.
4228              
4229             =back
4230              
4231             =begin comment
4232              
4233             =head2 Collation
4234              
4235             =over 4
4236              
4237             =item collation()
4238              
4239             This method returns a Locale::CLDR::Collator object. This is still in development. Future releases will
4240             try and match the API from L<Unicode::Collate> as much as possible and add tailoring for locales.
4241              
4242             =back
4243              
4244             =end comment
4245              
4246             =cut
4247              
4248             =begin comment
4249              
4250             sub collation {
4251             my ($self, %params) = @_;
4252            
4253             $params{type} //= $self->_default_collation;
4254             $params{strength} //= $self->_default_collation_strength;
4255            
4256             return Locale::CLDR::Collator->new(locale => $self, %params);
4257             }
4258              
4259             sub collation_overrides {
4260             my ($self, $type) = @_;
4261            
4262             my @bundles = reverse $self->_find_bundle('collation');
4263            
4264             my $override = '';
4265             foreach my $bundle (@bundles) {
4266             last if $override = $bundle->collation()->{$type};
4267             }
4268            
4269             if ($type ne 'standard' && ! $override) {
4270             foreach my $bundle (@bundles) {
4271             last if $override = $bundle->collation()->{standard};
4272             }
4273             }
4274            
4275             return $override || [];
4276             }
4277            
4278             sub _default_collation {
4279             return 'standard';
4280             }
4281              
4282             sub _default_collation_strength {
4283             return 3;
4284             }
4285              
4286             =end comment
4287              
4288             =head1 Locales
4289              
4290             Other locales can be found on CPAN. You can install Language packs from the
4291             Locale::CLDR::Locales::* packages. You will in future be able to install language
4292             packs for a given territory by looking for a Bundle::Locale::CLDR::* package.
4293              
4294             If you are looking for a language pack that is not yet published then get hold of
4295             the version 0.25.4 from http://search.cpan.org/CPAN/authors/id/J/JG/JGNI/Locale-CLDR-v0.25.4.tar.gz
4296             which has data for all locals alternatively you can get hold of the latest version of the
4297             code from git hub at https://github.com/ThePilgrim/perlcldr
4298              
4299             =head1 AUTHOR
4300              
4301             John Imrie, C<< <JGNI at cpan dot org> >>
4302              
4303             =head1 BUGS
4304              
4305             Please report any bugs or feature requests to C<bug-locale-cldr at rt.cpan.org>, or through
4306             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Locale-CLDR>. I will be notified, and then you'll
4307             automatically be notified of progress on your bug as I make changes.
4308              
4309             =head1 SUPPORT
4310              
4311             You can find documentation for this module with the perldoc command.
4312              
4313             perldoc Locale::CLDR
4314              
4315             You can also look for information at:
4316              
4317             =over 4
4318              
4319             =item * RT: CPAN's request tracker
4320              
4321             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Locale-CLDR>
4322              
4323             =item * AnnoCPAN: Annotated CPAN documentation
4324              
4325             L<http://annocpan.org/dist/Locale-CLDR>
4326              
4327             =item * CPAN Ratings
4328              
4329             L<http://cpanratings.perl.org/d/Locale-CLDR>
4330              
4331             =item * Search CPAN
4332              
4333             L<http://search.cpan.org/dist/Locale-CLDR/>
4334              
4335             =back
4336              
4337              
4338             =head1 ACKNOWLEDGEMENTS
4339              
4340             Everyone at the Unicode Consortium for providing the data.
4341              
4342             Karl Williams for his tireless work on Unicode in the Perl
4343             regex engine.
4344              
4345             =head1 COPYRIGHT & LICENSE
4346              
4347             Copyright 2009-2015 John Imrie.
4348              
4349             This program is free software; you can redistribute it and/or modify it
4350             under the terms of either: the GNU General Public License as published
4351             by the Free Software Foundation; or the Artistic License.
4352              
4353             See http://dev.perl.org/licenses/ for more information.
4354              
4355             =cut
4356              
4357             1; # End of Locale::CLDR