File Coverage

blib/lib/Locale/CLDR.pm
Criterion Covered Total %
statement 957 1282 74.6
branch 228 402 56.7
condition 75 152 49.3
subroutine 144 172 83.7
pod 50 50 100.0
total 1454 2058 70.6


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.27.1
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   535178 use v5.10;
  20         67  
  20         907  
41 20     20   9902 use version;
  20         39115  
  20         280  
42             our $VERSION = version->declare('v0.27.2');
43              
44 20     20   12456 use open ':encoding(utf8)';
  20         22823  
  20         197  
45 20     20   244768 use utf8;
  20         60  
  20         125  
46 20     20   1380 use if ($^V ge v5.12.0), (feature => 'unicode_strings');
  20         48  
  20         1076  
47              
48 20     20   14818 use Moose;
  20         8844368  
  20         199  
49 20     20   154187 use MooseX::ClassAttribute;
  20         1754995  
  20         121  
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   5511295 use Class::Load;
  20         44  
  20         1031  
56 20     20   100 use namespace::autoclean;
  20         29  
  20         206  
57 20     20   1919 use List::Util qw(first);
  20         28  
  20         1315  
58 20     20   91 use Class::MOP;
  20         27  
  20         417  
59 20     20   14400 use DateTime::Locale;
  20         1086318  
  20         720  
60 20     20   16902 use Unicode::Normalize();
  20         39744  
  20         713  
61 20     20   9873 use Locale::CLDR::Collator();
  20         73  
  20         763  
62 20     20   215 use File::Spec();
  20         32  
  20         2632  
63              
64             # Backwards compatibility
65             BEGIN {
66 20 50   20   102 if (defined &CORE::fc) { #v5.16
67 20         26434 *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 101     101   220 my $self = shift;
613            
614 303 100       795 my @path = map { ucfirst lc }
  303         879  
615 101         572 map { $_ ? $_ : 'Any' } (
616             $self->language_id,
617             $self->script_id,
618             $self->territory_id,
619             );
620              
621 303         806 my @likely_path =
622 101 100       3996 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 101         559 for (my $i = 0; $i < @path; $i++) {
629 303 100 66     1744 $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 101         479 @path = join '::', @likely_path;
634 101         345 push @path, join '::', $likely_path[0], 'Any', $likely_path[2];
635 101         331 push @path, join '::', @likely_path[0 .. 1];
636 101         228 push @path, join '::', $likely_path[0];
637            
638             # Now we go through the path loading each module
639             # And calling new on it.
640 101         163 my $module;
641 101         251 foreach my $module_name (@path) {
642 268         670 $module_name = "Locale::CLDR::Locales::$module_name";
643 268 100       1814 if (Class::Load::try_load_class($module_name, { -version => $VERSION})) {
644 81         11006 Class::Load::load_class($module_name, { -version => $VERSION});
645             }
646             else {
647 186         74752 next;
648             }
649 81         11221 $module = $module_name->new;
650 81         270 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 100 50       538 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 100         3168 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   212 no strict 'refs';
  20         41  
  20         16000  
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, $type = 'default')
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   10 my ($self, $what) = @_;
1078              
1079 4         20 my $vars = $self->_build_break_vars($what);
1080 4         21 my $rules = $self->_build_break_rules($vars, $what);
1081 4         189 return $rules;
1082             }
1083              
1084             sub _build_break_vars {
1085 4     4   9 my ($self, $what) = @_;
1086              
1087 4         11 my $name = "${what}_variables";
1088 4         23 my @bundles = $self->_find_bundle($name);
1089 4         7 my @vars;
1090 4         14 foreach my $bundle (reverse @bundles) {
1091 4         5 push @vars, @{$bundle->$name};
  4         167  
1092             }
1093              
1094 4         13 my %vars = ();
1095 4         20 while (my ($name, $value) = (shift @vars, shift @vars)) {
1096 146 100       191 last unless defined $name;
1097 142 50       176 if (! defined $value) {
1098 0         0 delete $vars{$name};
1099 0         0 next;
1100             }
1101              
1102 142         217 $value =~ s{ ( \$ \p{ID_START} \p{ID_CONTINUE}* ) }{$vars{$1}}msxeg;
  148         298  
1103 142         367 $vars{$name} = $value;
1104             }
1105              
1106 4         16 return \%vars;
1107             }
1108              
1109             sub _build_break_rules {
1110 4     4   9 my ($self, $vars, $what) = @_;
1111              
1112 4         11 my $name = "${what}_rules";
1113 4         18 my @bundles = $self->_find_bundle($name);
1114              
1115 4         10 my %rules;
1116 4         11 foreach my $bundle (reverse @bundles) {
1117 4         7 %rules = (%rules, %{$bundle->$name});
  4         158  
1118             }
1119              
1120 4         9 my @rules;
1121 4         34 foreach my $rule_number ( sort { $a <=> $b } keys %rules ) {
  376         313  
1122             # Test for deleted rules
1123 97 50       283 next unless defined $rules{$rule_number};
1124              
1125 97         636 $rules{$rule_number} =~ s{ ( \$ \p{ID_START} \p{ID_CONTINUE}* ) }{$vars->{$1}}msxeg;
  290         1032  
1126 97         774 my ($first, $opp, $second) = split /(×|÷)/, $rules{$rule_number};
1127              
1128 97         130 foreach my $operand ($first, $second) {
1129 194 100       50884 if ($operand =~ m{ \S }msx) {
1130 161         4005 $operand = _unicode_to_perl($operand);
1131             }
1132             else {
1133 33         66 $operand = '.';
1134             }
1135             }
1136            
1137 20     20   47061 no warnings 'deprecated';
  20         43  
  20         32697  
1138 97 100       50295 push @rules, [qr{$first}msx, qr{$second}msx, ($opp eq '×' ? 1 : 0)];
1139             }
1140              
1141 4         27 push @rules, [ '.', '.', 0 ];
1142              
1143 4         72 return \@rules;
1144             }
1145              
1146             sub BUILDARGS {
1147 92     92 1 1595 my $self = shift;
1148 92         205 my %args;
1149              
1150             # Used for arguments when we call new from our own code
1151 92         288 my %internal_args = ();
1152 92 50 66     644 if (@_ > 1 && ref $_[-1] eq 'HASH') {
1153 0         0 %internal_args = %{pop @_};
  0         0  
1154             }
1155              
1156 92 100 66     709 if (1 == @_ && ! ref $_[0]) {
1157 71         830 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 71         215 foreach ($language, $script, $territory, $variant) {
1167 284 100       672 $_ = '' unless defined $_;
1168             }
1169              
1170             %args = (
1171 71         599 language_id => $language,
1172             script_id => $script,
1173             territory_id => $territory,
1174             variant_id => $variant,
1175             extensions => $extensions,
1176             );
1177             }
1178              
1179 92 100       398 if (! keys %args ) {
1180 0         0 %args = ref $_[0]
1181 21 50       119 ? %{$_[0]}
1182             : @_
1183             }
1184              
1185             # Split up the extensions
1186 92 100 66     467 if ( defined $args{extensions} && ! ref $args{extensions} ) {
1187 2         7 $args{extensions} = {
1188 1         5 map {lc}
1189             split /[_-]/, $args{extensions}
1190             };
1191             }
1192              
1193             # Fix casing of args
1194 92 100       620 $args{language_id} = lc $args{language_id} if defined $args{language_id};
1195 92 100       500 $args{script_id} = ucfirst lc $args{script_id} if defined $args{script_id};
1196 92 100       544 $args{territory_id} = uc $args{territory_id} if defined $args{territory_id};
1197 92 100       469 $args{variant_id} = uc $args{variant_id} if defined $args{variant_id};
1198            
1199             # Set up undefined language
1200 92   100     359 $args{language_id} //= 'und';
1201              
1202 92         881 $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   141 'bool' => sub { 1 },
1315 20     20   165 '""' => sub {shift->id};
  20     0   30  
  20         305  
  0         0  
1316              
1317             sub _build_id {
1318 29     29   59 my $self = shift;
1319 29         131 my $string = lc $self->language_id;
1320              
1321 29 100       791 if ($self->script_id) {
1322 22         561 $string.= '_' . ucfirst lc $self->script_id;
1323             }
1324              
1325 29 100       126 if ($self->territory_id) {
1326 22         100 $string.= '_' . uc $self->territory_id;
1327             }
1328              
1329 29 100       876 if ($self->variant_id) {
1330 3         86 $string.= '_' . uc $self->variant_id;
1331             }
1332              
1333 29 50       774 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         861 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 3193     3193   4095 my ($self, $method_name) = @_;
1421 3193 50       106822 my $id = $self->has_likely_subtag()
1422             ? $self->likely_subtag()->id()
1423             : $self->id();
1424            
1425            
1426 3193 100       86303 if ($self->method_cache->{$id}{$method_name}) {
1427             return wantarray
1428 3111 100       24532 ? @{$self->method_cache->{$id}{$method_name}}
  2361         60677  
1429             : $self->method_cache->{$id}{$method_name}[0];
1430             }
1431              
1432 82         3122 foreach my $module ($self->module->meta->linearized_isa) {
1433 410 100       17077 last if $module eq 'Moose::Object';
1434 328 100       2019 if ($module->meta->has_method($method_name)) {
1435 116         6381 push @{$self->method_cache->{$id}{$method_name}}, $module->new;
  116         4091  
1436             }
1437             }
1438              
1439 82 100       3047 return unless $self->method_cache->{$id}{$method_name};
1440             return wantarray
1441 77 100       563 ? @{$self->method_cache->{$id}{$method_name}}
  64         1939  
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 3657 my ($self, $name) = @_;
1465 6   66     29 $name //= $self;
1466              
1467 6 50       26 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         15 foreach my $bundle (@bundles) {
1474 6         203 my $display_name = $bundle->display_name_language->($code);
1475 6 100       44 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         19 $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         46 my $language = $self->language_name($name);
1486 2         10 my $script = $self->script_name($name);
1487 2         15 my $territory = $self->territory_name($name);
1488 2         12 my $variant = $self->variant_name($name);
1489              
1490 2         8 my $bundle = $self->_find_bundle('display_name_pattern');
1491 2         15 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 6113 my ($self, $name) = @_;
1505              
1506 8   66     45 $name //= $self;
1507              
1508 8 100       103 my $code = ref $name ? $name->language_id : eval { Locale::CLDR->new(language_id => $name)->language_id };
  3         32  
1509              
1510 8         1623 my $language = undef;
1511 8         3932 my @bundles = $self->_find_bundle('display_name_language');
1512 8 100       26 if ($code) {
1513 7         23 foreach my $bundle (@bundles) {
1514 7         328 my $display_name = $bundle->display_name_language->($code);
1515 7 50       35 if (defined $display_name) {
1516 7         15 $language = $display_name;
1517 7         20 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       31 if (! defined $language ) {
1524 1         3 foreach my $bundle (@bundles) {
1525 1         32 my $display_name = $bundle->display_name_language->('und');
1526 1 50       6 if (defined $display_name) {
1527 1         2 $language = $display_name;
1528 1         2 last;
1529             }
1530             }
1531             }
1532              
1533 8         52 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 3 my $self = shift;
1545              
1546 1         3 my @bundles = $self->_find_bundle('display_name_language');
1547 1         3 my %languages;
1548 1         3 foreach my $bundle (@bundles) {
1549 1         51 my $languages = $bundle->display_name_language->();
1550              
1551             # Remove existing languages
1552 1         4 delete @{$languages}{keys %languages};
  1         2  
1553              
1554             # Assign new ones to the hash
1555 1         465 @languages{keys %$languages} = values %$languages;
1556             }
1557              
1558 1         9 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 4570 my ($self, $name) = @_;
1571 7   66     33 $name //= $self;
1572              
1573 7 100       30 if (! ref $name ) {
1574 3         4 $name = eval {__PACKAGE__->new(script_id => $name)};
  3         27  
1575             }
1576              
1577 7 100 100     2297 if ( ref $name && ! $name->script_id ) {
1578 3         15 return '';
1579             }
1580              
1581 4         11 my $script = undef;
1582 4         28 my @bundles = $self->_find_bundle('display_name_script');
1583 4 100       25 if ($name) {
1584 3         10 foreach my $bundle (@bundles) {
1585 3         106 $script = $bundle->display_name_script->($name->script_id);
1586 3 50       13 if (defined $script) {
1587 3         8 last;
1588             }
1589             }
1590             }
1591              
1592 4 100       16 if (! $script) {
1593 1         5 foreach my $bundle (@bundles) {
1594 1         32 $script = $bundle->display_name_script->('Zzzz');
1595 1 50       5 if (defined $script) {
1596 1         3 last;
1597             }
1598             }
1599             }
1600              
1601 4         33 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 5030 my $self = shift;
1613              
1614 1         8 my @bundles = $self->_find_bundle('display_name_script');
1615 1         3 my %scripts;
1616 1         3 foreach my $bundle (@bundles) {
1617 1         68 my $scripts = $bundle->display_name_script->();
1618              
1619             # Remove existing scripts
1620 1         5 delete @{$scripts}{keys %scripts};
  1         4  
1621              
1622             # Assign new ones to the hash
1623 1         162 @scripts{keys %$scripts} = values %$scripts;
1624             }
1625              
1626 1         11 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 7986 my ($self, $name) = @_;
1639 9   66     43 $name //= $self;
1640              
1641 9 100       37 if (! ref $name ) {
1642 5         13 $name = eval { __PACKAGE__->new(language_id => 'und', territory_id => $name); };
  5         42  
1643             }
1644              
1645 9 50 66     3859 if ( ref $name && ! $name->territory_id) {
1646 0         0 return '';
1647             }
1648              
1649 9         23 my $territory = undef;
1650 9         43 my @bundles = $self->_find_bundle('display_name_territory');
1651 9 100       139 if ($name) {
1652 7         26 foreach my $bundle (@bundles) {
1653 7         327 $territory = $bundle->display_name_territory->{$name->territory_id};
1654 7 50       41 if (defined $territory) {
1655 7         17 last;
1656             }
1657             }
1658             }
1659              
1660 9 100       35 if (! defined $territory) {
1661 2         5 foreach my $bundle (@bundles) {
1662 2         66 $territory = $bundle->display_name_territory->{'ZZ'};
1663 2 50       7 if (defined $territory) {
1664 2         4 last;
1665             }
1666             }
1667             }
1668              
1669 9         55 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 3860 my $self = shift;
1681              
1682 1         4 my @bundles = $self->_find_bundle('display_name_territory');
1683 1         2 my %territories;
1684 1         3 foreach my $bundle (@bundles) {
1685 1         29 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         193 @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 4181 my ($self, $name) = @_;
1707 7   66     29 $name //= $self;
1708              
1709 7 100       24 if (! ref $name ) {
1710 4         40 $name = __PACKAGE__->new(language_id=> 'und', variant_id => $name);
1711             }
1712              
1713 6 100       216 return '' unless $name->variant_id;
1714 3         10 my $variant = undef;
1715 3 50       88 if ($name->has_variant) {
1716 3         15 my @bundles = $self->_find_bundle('display_name_variant');
1717 3         10 foreach my $bundle (@bundles) {
1718 3         115 $variant= $bundle->display_name_variant->{$name->variant_id};
1719 3 100       13 if (defined $variant) {
1720 2         6 last;
1721             }
1722             }
1723             }
1724              
1725 3   100     33 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 8544 my ($self, $key) = @_;
1737              
1738 3         12 $key = lc $key;
1739            
1740 3         138 my %key_aliases = $self->key_aliases;
1741 3         114 my %key_names = $self->key_names;
1742 3         119 my %valid_keys = $self->valid_keys;
1743              
1744 3   100     27 my $alias = $key_aliases{$key} // '';
1745 3   100     14 my $name = $key_names{$key} // '';
1746              
1747 3 50 66     28 return '' unless exists $valid_keys{$key} || exists $valid_keys{$alias} || exists $valid_keys{$name};
      66        
1748 3         15 my @bundles = $self->_find_bundle('display_name_key');
1749 3         8 foreach my $bundle (@bundles) {
1750 3         110 my $return = $bundle->display_name_key->{$key};
1751 3   66     39 $return //= $bundle->display_name_key->{$alias};
1752 3   33     9 $return //= $bundle->display_name_key->{$name};
1753              
1754 3 50 33     86 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 9 my ($self, $key, $type) = @_;
1769              
1770 3         10 $key = lc $key;
1771 3         7 $type = lc $type;
1772              
1773 3         127 my %key_aliases = $self->key_aliases;
1774 3         107 my %valid_keys = $self->valid_keys;
1775 3         103 my %key_names = $self->key_names;
1776              
1777 3   100     23 my $alias = $key_aliases{$key} // '';
1778 3   100     16 my $name = $key_names{$key} // '';
1779              
1780 3 50 66     27 return '' unless exists $valid_keys{$key} || $valid_keys{$alias} || $valid_keys{$name};
      66        
1781 3 100   20   16 return '' unless first { $_ eq $type } @{$valid_keys{$key} || []}, @{$valid_keys{$alias} || []}, @{$valid_keys{$name} || []};
  20 50       27  
  3 100       20  
  3 50       20  
  3         23  
1782              
1783 3         17 my @bundles = $self->_find_bundle('display_name_type');
1784 3         10 foreach my $bundle (@bundles) {
1785 3   66     110 my $types = $bundle->display_name_type->{$key} // $bundle->display_name_type->{$alias} // $bundle->display_name_type->{$name};
      33        
1786 3         11 my $type = $types->{$type};
1787 3 50       77 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 40 my ($self, $name) = @_;
1802              
1803             # Fix case of code
1804 6         19 $name = uc $name;
1805 6 100       25 $name = 'metric' if $name eq 'METRIC';
1806              
1807 6         25 my @bundles = $self->_find_bundle('display_name_measurement_system');
1808 6         19 foreach my $bundle (@bundles) {
1809 6         247 my $system = $bundle->display_name_measurement_system->{$name};
1810 6 50       50 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 4 my ($self, $name) = @_;
1825              
1826 1         5 $name = lc $name;
1827              
1828 1         5 my @bundles = $self->_find_bundle('display_name_transform_name');
1829 1         5 foreach my $bundle (@bundles) {
1830 1         59 my $key = $bundle->display_name_transform_name->{$name};
1831 1 50       16 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 45 my ($self, $type, $locale) = @_;
1847 3         11 $type = lc $type;
1848              
1849             # If locale is not passed in then we are using ourself
1850 3   33     15 $locale //= $self;
1851              
1852             # If locale is not an object then inflate it
1853 3 50       23 $locale = __PACKAGE__->new($locale) unless blessed $locale;
1854              
1855 3 50       28 return '' unless $type =~ m{ \A (?: language | script | territory ) \z }xms;
1856              
1857 3         9 my $method = $type . '_name';
1858 3         21 my $substitute = $self->$method($locale);
1859              
1860 3         18 my @bundles = $self->_find_bundle('display_name_code_patterns');
1861 3         10 foreach my $bundle (@bundles) {
1862 3         96 my $text = $bundle->display_name_code_patterns->{$type};
1863 3 50       11 next unless defined $text;
1864 3         14 my $match = qr{ \{ 0 \} }xms;
1865 3         46 $text=~ s{ $match }{$substitute}gxms;
1866 3         33 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 24 my $self = shift;
1881 2         5 my $type = shift;
1882              
1883 2         10 my @bundles = $self->_find_bundle('text_orientation');
1884 2         6 foreach my $bundle (@bundles) {
1885 2         76 my $orientation = $bundle->text_orientation;
1886 2 50       5 next unless defined $orientation;
1887 2         17 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   134 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 65 _new_perl();
1940            
1941 1         6 my ($self, $string) = @_;
1942              
1943 1         51 my $rules = $self->break_grapheme_cluster;
1944 1         9 my @clusters = $self->_split($rules, $string, 1);
1945              
1946 1         13 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 1097 _new_perl();
1958            
1959 1         4 my ($self, $string) = @_;
1960              
1961 1         45 my $rules = $self->break_word;
1962 1         5 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 839 _new_perl();
1978            
1979 1         3 my ($self, $string) = @_;
1980              
1981 1         45 my $rules = $self->break_sentence;
1982 1         6 my @sentences = $self->_split($rules, $string);
1983              
1984 1         8 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 851 _new_perl();
1998            
1999 1         3 my ($self, $string) = @_;
2000              
2001 1         45 my $rules = $self->break_line;
2002 1         7 my @lines = $self->_split($rules, $string);
2003              
2004 1         9 return @lines;
2005             }
2006              
2007             sub _split {
2008 4     4   10 my ($self, $rules, $string, $grapheme_split) = @_;
2009              
2010 4         28 my @split = (scalar @$rules) x (length($string) - 1);
2011              
2012 4         14 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   94360 no warnings 'deprecated';
  20         70  
  20         82045  
2016 4         18 while (length($string) -1 != pos $string) {
2017 161         174 my $rule_number = 0;
2018 161         134 my $first;
2019 161         307 foreach my $rule (@$rules) {
2020 2656 100       46127 unless( ($first) = $string =~ m{
2021             \G
2022             ($rule->[0])
2023             $rule->[1]
2024             }msx) {
2025 2495         1779253 $rule_number++;
2026 2495         21059 next;
2027             }
2028 161         143538 my $location = pos($string) + length($first) -1;
2029 161         272 $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         211 my $length = length $first;
2034 161         748 my ($gc) = $string =~ /\G(\X)/;
2035 161 100 66     2642 $length = (! $grapheme_split && length($gc)) > $length ? length($gc) : $length;
2036 161         484 pos($string)+= $length;
2037 161         834 last;
2038             }
2039             }
2040              
2041 4         15 push @$rules,[undef,undef,1];
2042 4 100       11 @split = map {$rules->[$_][2] ? 1 : 0} @split;
  164         264  
2043 4         13 my $count = 0;
2044 4         10 my @sections = ('.');
2045 4         13 foreach my $split (@split) {
2046 164 100       224 $count++ unless $split;
2047 164         164 $sections[$count] .= '.';
2048             }
2049            
2050 4         26 my $regex = '(' . join(')(', @sections) . ')';
2051 4         99 $regex = qr{ \A $regex \z}msx;
2052 4         56 @split = $string =~ $regex;
2053              
2054 4         39 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 61 my ($self, @parameters) = @_;
2077 6 100       22 unshift @parameters, 'main' if @parameters == 1;
2078              
2079 6 50       28 _new_perl() unless $parameters[0] eq 'index';
2080            
2081 6         23 my @bundles = $self->_find_bundle('characters');
2082 6         13 foreach my $bundle (@bundles) {
2083 9         239 my $characters = $bundle->characters->{lc $parameters[0]};
2084 9 100       20 next unless defined $characters;
2085 7 100       54 return 1 if fc($parameters[1])=~$characters;
2086             }
2087              
2088 3         16 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 378 my $self = shift;
2100              
2101 1         5 my @bundles = $self->_find_bundle('characters');
2102 1         3 foreach my $bundle (@bundles) {
2103 1         28 my $characters = $bundle->characters->{index};
2104 1 50       3 next unless defined $characters;
2105 1         14 return $characters;
2106             }
2107 0         0 return [];
2108             }
2109              
2110             sub _truncated {
2111 6     6   21 my ($self, $type, @params) = @_;
2112              
2113 6         20 my @bundles = $self->_find_bundle('ellipsis');
2114 6         16 foreach my $bundle (@bundles) {
2115 6         283 my $ellipsis = $bundle->ellipsis->{$type};
2116 6 50       18 next unless defined $ellipsis;
2117 6         45 $ellipsis=~s{ \{ 0 \} }{$params[0]}msx;
2118 6         20 $ellipsis=~s{ \{ 1 \} }{$params[1]}msx;
2119 6         55 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 28 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 7 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 6 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 5 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 5 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 5 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 1622 my ($self, $text) = @_;
2226              
2227 3         8 my %quote;
2228 3         15 my @bundles = $self->_find_bundle('quote_start');
2229 3         11 foreach my $bundle (@bundles) {
2230 3         129 my $quote = $bundle->quote_start;
2231 3 50       9 next unless defined $quote;
2232 3         8 $quote{start} = $quote;
2233 3         7 last;
2234             }
2235              
2236 3         11 @bundles = $self->_find_bundle('quote_end');
2237 3         12 foreach my $bundle (@bundles) {
2238 3         152 my $quote = $bundle->quote_end;
2239 3 50       13 next unless defined $quote;
2240 3         9 $quote{end} = $quote;
2241 3         8 last;
2242             }
2243              
2244 3         13 @bundles = $self->_find_bundle('alternate_quote_start');
2245 3         10 foreach my $bundle (@bundles) {
2246 3         133 my $quote = $bundle->alternate_quote_start;
2247 3 50       12 next unless defined $quote;
2248 3         8 $quote{alternate_start} = $quote;
2249 3         7 last;
2250             }
2251              
2252 3         13 @bundles = $self->_find_bundle('alternate_quote_end');
2253 3         8 foreach my $bundle (@bundles) {
2254 3         140 my $quote = $bundle->alternate_quote_end;
2255 3 50       12 next unless defined $quote;
2256 3         8 $quote{alternate_end} = $quote;
2257 3         6 last;
2258             }
2259              
2260             # Check to see if we need to switch quotes
2261 3         9 foreach (qw( start end alternate_start alternate_end)) {
2262 12   50     34 $quote{$_} //= '';
2263             }
2264              
2265 3         13 my $from = join ' | ', map {quotemeta} @quote{qw( start end alternate_start alternate_end)};
  12         33  
2266 3         6 my %to;
2267 3         37 @to{@quote{qw( start end alternate_start alternate_end)}}
2268             = @quote{qw( alternate_start alternate_end start end)};
2269              
2270 3         14 my $outer = index($text, $quote{start});
2271 3         10 my $inner = index($text, $quote{alternate_start});
2272              
2273 3 50 33     31 if ($inner == -1 || ($outer > -1 && $inner > -1 && $outer < $inner)) {
      33        
      66        
2274 3         109 $text =~ s{ ( $from ) }{ $to{$1} }msxeg;
  6         33  
2275             }
2276              
2277 3         37 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 3 my $self = shift;
2296              
2297 1         5 my @bundles = $self->_find_bundle('more_information');
2298 1         4 foreach my $bundle (@bundles) {
2299 1         48 my $info = $bundle->more_information;
2300 1 50       5 next unless defined $info;
2301 1         13 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 29 my $self = shift;
2315            
2316 1         51 my $measurement_data = $self->measurement_system;
2317 1   50     4 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         7 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         38 my $paper_size = $self->paper_size;
2339 1   50     5 my $territory = $self->territory_id || '001';
2340            
2341 1         3 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         4 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 1904 my ($self, $number, $what, $type) = @_;
2385 738   100     2864 $type //= 'long';
2386            
2387 738         3164 my $plural = $self->plural($number);
2388            
2389 738         2217 my @bundles = $self->_find_bundle('units');
2390 738         1110 my $format;
2391 738         1187 foreach my $bundle (@bundles) {
2392 748 100       22812 if (exists $bundle->units()->{$type}{$what}{$plural}) {
2393 728         20678 $format = $bundle->units()->{$type}{$what}{$plural};
2394 728         1215 last;
2395             }
2396            
2397 20 50       496 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       1481 unless ($format) {
2405 10         19 my $original_type = $type;
2406 10         28 my @aliases = $self->_find_bundle('unit_alias');
2407 10         24 foreach my $alias (@aliases) {
2408 10         303 $type = $alias->unit_alias()->{$original_type};
2409 10 100       25 next unless $type;
2410 8         16 foreach my $bundle (@bundles) {
2411 12 100       395 if (exists $bundle->units()->{$type}{$what}{$plural}) {
2412 4         145 $format = $bundle->units()->{$type}{$what}{$plural};
2413 4         11 last;
2414             }
2415            
2416 8 50       215 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         24 $type = $original_type;
2423             }
2424            
2425             # Check for a compound unit that we don't specifically have
2426 738 100 66     2166 if (! $format && (my ($dividend, $divisor) = $what =~ /^(.+)-per-(.+)$/)) {
2427 6         20 return $self->_unit_compound($number, $dividend, $divisor, $type);
2428             }
2429            
2430 732         2998 $number = $self->format_number($number);
2431 732 50       1589 return $number unless $format;
2432            
2433 732         2641 $format =~ s/\{0\}/$number/g;
2434            
2435 732         5630 return $format;
2436             }
2437              
2438             sub _unit_compound {
2439 6     6   9 my ($self, $number, $dividend_what, $divisor_what, $type) = @_;
2440            
2441 6   50     13 $type //= 'long';
2442            
2443 6         21 my $dividend = $self->unit($number, $dividend_what, $type);
2444 6         25 my $divisor = $self->_unit_per($divisor_what, $type);
2445 6 50       14 if ($divisor) {
2446 6         5 my $format = $divisor;
2447 6         18 $format =~ s/\{0\}/$dividend/;
2448 6         47 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   9 my ($self, $what, $type) = @_;
2521            
2522 6         13 my @bundles = $self->_find_bundle('units');
2523 6         8 my $name;
2524 6         8 foreach my $bundle (@bundles) {
2525 6 50       156 if (exists $bundle->units()->{$type}{$what}{per}) {
2526 6         147 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   18 my $self = shift;
2547              
2548 12         42 my @number_symbols_bundles = $self->_find_bundle('number_symbols');
2549 12         66 my $symbols_type = $self->default_numbering_system;
2550            
2551 12         26 foreach my $bundle (@number_symbols_bundles) {
2552 24 50       654 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       604 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 11 my ($self, $format, @data) = @_;
2575            
2576 3         11 my $bundle = $self->_find_bundle('duration_units');
2577 3         85 my $parsed = $bundle->duration_units()->{$format};
2578            
2579 3         7 my $num_format = '#';
2580 3         17 foreach my $entry ( qr/(hh?)/, qr/(mm?)/, qr/(ss?)/) {
2581 9 100       48 $num_format = '00' if $parsed =~ s/$entry/$self->format_number(shift(@data), $num_format)/e;
  7         31  
2582             }
2583            
2584 3         17 my $time_separator = $self->_get_time_separator;
2585            
2586 3         41 $parsed =~ s/:/$time_separator/g;
2587            
2588 3         26 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 7 my ($self, $test_str) = @_;
2609            
2610 2         7 my $bundle = $self->_find_bundle('yesstr');
2611 2 100       58 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 6 my ($self, $test_str) = @_;
2626            
2627 2         9 my $bundle = $self->_find_bundle('nostr');
2628 2 100       76 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   222 use feature 'state';
  20         35  
  20         179151  
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 38 my ($self, @data) = @_;
2793            
2794             # Short circuit on 0 or 1 entries
2795 5 100       18 return '' unless @data;
2796 4 100       16 return $data[0] if 1 == @data;
2797            
2798 3         13 my @bundles = $self->_find_bundle('listPatterns');
2799            
2800 3         5 my %list_data;
2801 3         6 foreach my $bundle (reverse @bundles) {
2802 6         4 my %listPatterns = %{$bundle->listPatterns};
  6         168  
2803 6         27 @list_data{keys %listPatterns} = values %listPatterns;
2804             }
2805            
2806 3 100       9 if (my $pattern = $list_data{scalar @data}) {
2807 1         8 $pattern=~s/\{([0-9]+)\}/$data[$1]/eg;
  2         8  
2808 1         10 return $pattern;
2809             }
2810            
2811 2         5 my ($start, $middle, $end) = @list_data{qw( start middle end )};
2812            
2813             # First do the end
2814 2         3 my $pattern = $end;
2815 2         7 $pattern=~s/\{1\}/pop @data/e;
  2         5  
2816 2         5 $pattern=~s/\{0\}/pop @data/e;
  2         4  
2817            
2818             # If there is any data left do the middle
2819 2         5 while (@data > 1) {
2820 1         3 my $current = $pattern;
2821 1         1 $pattern = $middle;
2822 1         3 $pattern=~s/\{1\}/$current/;
2823 1         3 $pattern=~s/\{0\}/pop @data/e;
  1         4  
2824             }
2825            
2826             # Now do the start
2827 2         3 my $current = $pattern;
2828 2         2 $pattern = $start;
2829 2         5 $pattern=~s/\{1\}/$current/;
2830 2         5 $pattern=~s/\{0\}/pop @data/e;
  2         3  
2831            
2832 2         12 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   16 my ($self, $type, $width) = @_;
2884 8         45 my $default_calendar = $self->default_calendar();
2885 8         31 my @bundles = $self->_find_bundle('calendar_months');
2886             BUNDLES: {
2887 8         12 foreach my $bundle (@bundles) {
  12         20  
2888 16         472 my $months = $bundle->calendar_months;
2889 16 50       47 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       52 if (exists $months->{$default_calendar}{$type}{$width}{alias}) {
2895 4         6 ($type, $width) = @{$months->{$default_calendar}{$type}{$width}{alias}}{qw(context type)};
  4         17  
2896 4         11 redo BUNDLES;
2897             }
2898            
2899 12         20 my $result = $months->{$default_calendar}{$type}{$width}{nonleap};
2900 12 100       229 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   4 my $self = shift;
2912 2         7 my ($type, $width) = (qw(format wide));
2913            
2914 2         10 return $self->_build_any_month($type, $width);
2915             }
2916              
2917             sub _build_month_format_abbreviated {
2918 1     1   2 my $self = shift;
2919 1         4 my ($type, $width) = (qw(format abbreviated));
2920            
2921 1         4 return $self->_build_any_month($type, $width);
2922             }
2923              
2924             sub _build_month_format_narrow {
2925 1     1   2 my $self = shift;
2926 1         3 my ($type, $width) = (qw(format narrow));
2927            
2928 1         4 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         3 my ($type, $width) = ('stand-alone', 'wide');
2934            
2935 1         4 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         4 my ($type, $width) = ('stand-alone', 'abbreviated');
2941            
2942 2         11 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         2 my ($type, $width) = ('stand-alone', 'narrow');
2948            
2949 1         4 return $self->_build_any_month($type, $width);
2950             }
2951              
2952             sub _build_any_day {
2953 7     7   17 my ($self, $type, $width) = @_;
2954            
2955 7         31 my $default_calendar = $self->default_calendar();
2956              
2957 7         23 my @bundles = $self->_find_bundle('calendar_days');
2958             BUNDLES: {
2959 7         12 foreach my $bundle (@bundles) {
  10         17  
2960 13         352 my $days= $bundle->calendar_days;
2961            
2962 13 50       69 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       45 if (exists $days->{$default_calendar}{$type}{$width}{alias}) {
2968 3         6 ($type, $width) = @{$days->{$default_calendar}{$type}{$width}{alias}}{qw(context type)};
  3         12  
2969 3         10 redo BUNDLES;
2970             }
2971 10         20 my $result = $days->{$default_calendar}{$type}{$width};
2972 10 100       31 return [ @{$result}{qw( mon tue wed thu fri sat sun )} ] if keys %$result;
  7         208  
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         7 my ($type, $width) = (qw(format wide));
2986            
2987 2         11 return $self->_build_any_day($type, $width);
2988             }
2989              
2990             sub _build_day_format_abbreviated {
2991 1     1   5 my $self = shift;
2992 1         3 my ($type, $width) = (qw(format abbreviated));
2993            
2994 1         6 return $self->_build_any_day($type, $width);
2995             }
2996              
2997             sub _build_day_format_narrow {
2998 1     1   3 my $self = shift;
2999 1         4 my ($type, $width) = (qw(format narrow));
3000            
3001 1         5 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         3 my ($type, $width) = ('stand-alone', 'wide');
3007            
3008 1         4 return $self->_build_any_day($type, $width);
3009             }
3010              
3011             sub _build_day_stand_alone_abbreviated {
3012 1     1   1 my $self = shift;
3013 1         3 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   1 my $self = shift;
3020 1         3 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   9 my ($self, $type, $width) = @_;
3027            
3028 6         21 my $default_calendar = $self->default_calendar();
3029              
3030 6         18 my @bundles = $self->_find_bundle('calendar_quarters');
3031             BUNDLES: {
3032 6         9 foreach my $bundle (@bundles) {
  9         11  
3033 12         325 my $quarters= $bundle->calendar_quarters;
3034            
3035 12 50       25 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       32 if (exists $quarters->{$default_calendar}{$type}{$width}{alias}) {
3041 3         4 ($type, $width) = @{$quarters->{$default_calendar}{$type}{$width}{alias}}{qw(context type)};
  3         10  
3042 3         7 redo BUNDLES;
3043             }
3044            
3045 9         14 my $result = $quarters->{$default_calendar}{$type}{$width};
3046 9 100       22 return [ @{$result}{qw( 0 1 2 3 )} ] if keys %$result;
  6         167  
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         6 return $self->_build_any_quarter($type, $width);
3062             }
3063              
3064             sub _build_quarter_format_abbreviated {
3065 1     1   3 my $self = shift;
3066 1         3 my ($type, $width) = (qw(format abbreviated));
3067              
3068 1         5 return $self->_build_any_quarter($type, $width);
3069             }
3070              
3071             sub _build_quarter_format_narrow {
3072 1     1   2 my $self = shift;
3073 1         3 my ($type, $width) = (qw(format narrow));
3074              
3075 1         4 return $self->_build_any_quarter($type, $width);
3076             }
3077              
3078             sub _build_quarter_stand_alone_wide {
3079 1     1   3 my $self = shift;
3080 1         3 my ($type, $width) = ('stand-alone', 'wide');
3081              
3082 1         4 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         3 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         4 return $self->_build_any_quarter($type, $width);
3097             }
3098              
3099             sub get_day_period {
3100             # Time in hhmm
3101 3     3 1 1336 my ($self, $time, $type) = @_;
3102 3   50     14 $type //= 'default';
3103            
3104 3         12 my $default_calendar = $self->default_calendar();
3105            
3106 3         9 my $bundle = $self->_find_bundle('day_period_data');
3107            
3108 3         85 my $day_period = $bundle->day_period_data;
3109 3         10 $day_period = $self->$day_period($default_calendar, $time, $type);
3110            
3111 3         78 my $am_pm = $self->am_pm_format_abbreviated;
3112            
3113 3         12 return $am_pm->{$day_period};
3114             }
3115              
3116             sub _build_any_am_pm {
3117 10     10   17 my ($self, $type, $width) = @_;
3118              
3119 10         41 my $default_calendar = $self->default_calendar();
3120 10         14 my @result;
3121 10         27 my @bundles = $self->_find_bundle('day_periods');
3122 10         13 my %return;
3123              
3124             BUNDLES: {
3125 10         8 foreach my $bundle (@bundles) {
  17         23  
3126 34         880 my $am_pm = $bundle->day_periods;
3127            
3128 34 50       73 if (exists $am_pm->{$default_calendar}{alias}) {
3129 0         0 $default_calendar = $am_pm->{$default_calendar}{alias};
3130 0         0 redo BUNDLES;
3131             }
3132              
3133 34 100       67 if (exists $am_pm->{$default_calendar}{$type}{alias}) {
3134 3         6 $type = $am_pm->{$default_calendar}{$type}{alias};
3135 3         6 redo BUNDLES;
3136             }
3137            
3138 31 100       67 if (exists $am_pm->{$default_calendar}{$type}{$width}{alias}) {
3139 4         14 $width = $am_pm->{$default_calendar}{$type}{$width}{alias};
3140 4         11 redo BUNDLES;
3141             }
3142            
3143 27         37 my $result = $am_pm->{$default_calendar}{$type}{$width};
3144            
3145 27         59 foreach (keys %$result) {
3146 60 100       142 $return{$_} = $result->{$_} unless exists $return{$_};
3147             }
3148             }
3149             }
3150              
3151 10         168 return \%return;
3152             }
3153              
3154             # The first 3 are to link in with Date::Time::Locale
3155             sub _build_am_pm_wide {
3156 1     1   2 my $self = shift;
3157 1         3 my ($type, $width) = (qw( format wide ));
3158            
3159 1         6 my $result = $self->_build_any_am_pm($type, $width);
3160            
3161 1         31 return [ @$result{qw( am pm )} ];
3162             }
3163              
3164             sub _build_am_pm_abbreviated {
3165 2     2   5 my $self = shift;
3166 2         6 my ($type, $width) = (qw( format abbreviated ));
3167              
3168 2         9 my $result = $self->_build_any_am_pm($type, $width);
3169            
3170 2         63 return [ @$result{qw( am pm )} ];
3171             }
3172              
3173             sub _build_am_pm_narrow {
3174 1     1   1 my $self = shift;
3175 1         5 my ($type, $width) = (qw( format narrow ));
3176            
3177 1         2 my $result = $self->_build_any_am_pm($type, $width);
3178            
3179 1         25 return [ @$result{qw( am pm )} ];
3180             }
3181              
3182             # Now we do the full set of data
3183             sub _build_am_pm_format_wide {
3184 1     1   3 my $self = shift;
3185 1         2 my ($type, $width) = (qw( format wide ));
3186            
3187 1         3 return $self->_build_any_am_pm($type, $width);
3188             }
3189              
3190             sub _build_am_pm_format_abbreviated {
3191 1     1   2 my $self = shift;
3192 1         2 my ($type, $width) = (qw( format abbreviated ));
3193              
3194 1         3 return $self->_build_any_am_pm($type, $width);
3195             }
3196              
3197             sub _build_am_pm_format_narrow {
3198 1     1   2 my $self = shift;
3199 1         3 my ($type, $width) = (qw( format narrow ));
3200            
3201 1         3 return $self->_build_any_am_pm($type, $width);
3202             }
3203              
3204             sub _build_am_pm_stand_alone_wide {
3205 1     1   2 my $self = shift;
3206 1         3 my ($type, $width) = ('stand-alone', 'wide');
3207            
3208 1         2 return $self->_build_any_am_pm($type, $width);
3209             }
3210              
3211             sub _build_am_pm_stand_alone_abbreviated {
3212 1     1   3 my $self = shift;
3213 1         2 my ($type, $width) = ('stand-alone', 'abbreviated');
3214              
3215 1         2 return $self->_build_any_am_pm($type, $width);
3216             }
3217              
3218             sub _build_am_pm_stand_alone_narrow {
3219 1     1   2 my $self = shift;
3220 1         2 my ($type, $width) = ('stand-alone', 'narrow');
3221            
3222 1         3 return $self->_build_any_am_pm($type, $width);
3223             }
3224              
3225             sub _build_any_era {
3226 9     9   10 my ($self, $width) = @_;
3227              
3228 9         27 my $default_calendar = $self->default_calendar();
3229 9         20 my @bundles = $self->_find_bundle('eras');
3230             BUNDLES: {
3231 9         9 foreach my $bundle (@bundles) {
  9         14  
3232 9         215 my $eras = $bundle->eras;
3233            
3234 9 50       22 if (exists $eras->{$default_calendar}{alias}) {
3235 0         0 $default_calendar = $eras->{$default_calendar}{alias};
3236 0         0 redo BUNDLES;
3237             }
3238              
3239 9 50       25 if (exists $eras->{$default_calendar}{$width}{alias}) {
3240 0         0 $width = $eras->{$default_calendar}{$width}{alias};
3241 0         0 redo BUNDLES;
3242             }
3243            
3244 9         10 my $result = $eras->{$default_calendar}{$width};
3245            
3246 9         8 my @result;
3247 9         36 @result[keys %$result] = values %$result;
3248            
3249 9 50       172 return \@result if keys %$result;
3250             }
3251 0 0       0 if ($default_calendar ne 'gregorian') {
3252 0         0 $default_calendar = 'gregorian';
3253 0         0 redo BUNDLES;
3254             }
3255             }
3256              
3257 0         0 return [];
3258             }
3259            
3260             # The next three are for DateDime::Locale
3261             sub _build_era_wide {
3262 1     1   1 my $self = shift;
3263 1         3 my ($width) = (qw( wide ));
3264              
3265 1         4 my $result = $self->_build_any_era($width);
3266            
3267 1         32 return [@$result[0, 1]];
3268             }
3269              
3270             sub _build_era_abbreviated {
3271 1     1   2 my $self = shift;
3272 1         2 my ($width) = (qw( abbreviated ));
3273              
3274 1         7 my $result = $self->_build_any_era($width);
3275            
3276 1         25 return [@$result[0, 1]];
3277             }
3278              
3279             sub _build_era_narrow {
3280 1     1   3 my $self = shift;
3281 1         2 my ($width) = (qw( narrow ));
3282              
3283 1         4 my $result = $self->_build_any_era($width);
3284            
3285 1         24 return [@$result[0, 1]];
3286             }
3287              
3288             # Now get all the era data
3289             sub _build_era_format_wide {
3290 2     2   3 my $self = shift;
3291 2         2 my ($width) = (qw( wide ));
3292              
3293 2         5 return $self->_build_any_era($width);
3294             }
3295              
3296             sub _build_era_format_abbreviated {
3297 2     2   3 my $self = shift;
3298 2         9 my ($width) = (qw( abbreviated ));
3299              
3300 2         7 return $self->_build_any_era($width);
3301             }
3302              
3303             sub _build_era_format_narrow {
3304 2     2   2 my $self = shift;
3305 2         4 my ($type, $width) = (qw( narrow ));
3306              
3307 2         6 return $self->_build_any_era($type, $width);
3308             }
3309              
3310             *_build_era_stand_alone_wide = \&_build_era_format_wide;
3311             *_build_era_stand_alone_abbreviated = \&_build_era_format_abbreviated;
3312             *_build_era_stand_alone_narrow = \&_build_era_format_narrow;
3313              
3314             sub _build_any_date_format {
3315 9     9   19 my ($self, $width) = @_;
3316 9         43 my $default_calendar = $self->default_calendar();
3317            
3318 9         23 my @bundles = $self->_find_bundle('date_formats');
3319              
3320             BUNDLES: {
3321 9         11 foreach my $bundle (@bundles) {
  9         16  
3322 9         245 my $date_formats = $bundle->date_formats;
3323 9 50       26 if (exists $date_formats->{alias}) {
3324 0         0 $default_calendar = $date_formats->{alias};
3325 0         0 redo BUNDLES;
3326             }
3327            
3328 9         21 my $result = $date_formats->{$default_calendar}{$width};
3329 9 50       121 return $result if $result;
3330             }
3331 0 0       0 if ($default_calendar ne 'gregorian') {
3332 0         0 $default_calendar = 'gregorian';
3333 0         0 redo BUNDLES;
3334             }
3335             }
3336            
3337 0         0 return '';
3338             }
3339              
3340             sub _build_date_format_full {
3341 1     1   7 my $self = shift;
3342            
3343 1         2 my ($width) = ('full');
3344 1         5 return $self->_build_any_date_format($width);
3345             }
3346              
3347             sub _build_date_format_long {
3348 1     1   2 my $self = shift;
3349            
3350 1         3 my ($width) = ('long');
3351 1         4 return $self->_build_any_date_format($width);
3352             }
3353              
3354             sub _build_date_format_medium {
3355 1     1   3 my $self = shift;
3356            
3357 1         2 my ($width) = ('medium');
3358 1         2 return $self->_build_any_date_format($width);
3359             }
3360              
3361             sub _build_date_format_short {
3362 1     1   2 my $self = shift;
3363            
3364 1         2 my ($width) = ('short');
3365 1         3 return $self->_build_any_date_format($width);
3366             }
3367              
3368             sub _build_any_time_format {
3369 9     9   18 my ($self, $width) = @_;
3370 9         35 my $default_calendar = $self->default_calendar();
3371            
3372 9         28 my @bundles = $self->_find_bundle('time_formats');
3373              
3374             BUNDLES: {
3375 9         13 foreach my $bundle (@bundles) {
  9         21  
3376 9         246 my $time_formats = $bundle->time_formats;
3377 9 50       33 if (exists $time_formats->{$default_calendar}{alias}) {
3378 0         0 $default_calendar = $time_formats->{$default_calendar}{alias};
3379 0         0 redo BUNDLES;
3380             }
3381            
3382 9         23 my $result = $time_formats->{$default_calendar}{$width};
3383 9 50       18 if ($result) {
3384 9         35 my $time_separator = $self->_get_time_separator;
3385 9         33 $result =~ s/:/$time_separator/g;
3386 9         126 return $result;
3387             }
3388             }
3389 0 0       0 if ($default_calendar ne 'gregorian') {
3390 0         0 $default_calendar = 'gregorian';
3391 0         0 redo BUNDLES;
3392             }
3393             }
3394 0         0 return '';
3395             }
3396              
3397             sub _build_time_format_full {
3398 1     1   2 my $self = shift;
3399 1         2 my $width = 'full';
3400            
3401 1         4 return $self->_build_any_time_format($width);
3402             }
3403              
3404             sub _build_time_format_long {
3405 1     1   3 my $self = shift;
3406            
3407 1         2 my $width = 'long';
3408 1         5 return $self->_build_any_time_format($width);
3409             }
3410              
3411             sub _build_time_format_medium {
3412 1     1   2 my $self = shift;
3413            
3414 1         2 my $width = 'medium';
3415 1         3 return $self->_build_any_time_format($width);
3416             }
3417              
3418             sub _build_time_format_short {
3419 1     1   1 my $self = shift;
3420            
3421 1         2 my $width = 'short';
3422 1         11 return $self->_build_any_time_format($width);
3423             }
3424              
3425             sub _build_any_datetime_format {
3426 5     5   10 my ($self, $width) = @_;
3427 5         20 my $default_calendar = $self->default_calendar();
3428            
3429 5         17 my @bundles = $self->_find_bundle('datetime_formats');
3430              
3431             BUNDLES: {
3432 5         8 foreach my $bundle (@bundles) {
  5         9  
3433 5         145 my $datetime_formats = $bundle->datetime_formats;
3434 5 50       19 if (exists $datetime_formats->{$default_calendar}{alias}) {
3435 0         0 $default_calendar = $datetime_formats->{$default_calendar}{alias};
3436 0         0 redo BUNDLES;
3437             }
3438            
3439 5         12 my $result = $datetime_formats->{$default_calendar}{$width};
3440 5 50       21 return $result if $result;
3441             }
3442 0 0       0 if ($default_calendar ne 'gregorian') {
3443 0         0 $default_calendar = 'gregorian';
3444 0         0 redo BUNDLES;
3445             }
3446             }
3447            
3448 0         0 return '';
3449             }
3450              
3451             sub _build_datetime_format_full {
3452 2     2   4 my $self = shift;
3453            
3454 2         5 my $width = 'full';
3455 2         8 my $format = $self->_build_any_datetime_format($width);
3456            
3457 2         13 my $date = $self->_build_any_date_format($width);
3458 2         14 my $time = $self->_build_any_time_format($width);
3459            
3460 2         9 $format =~ s/\{0\}/$time/;
3461 2         9 $format =~ s/\{1\}/$date/;
3462            
3463 2         55 return $format;
3464             }
3465              
3466             sub _build_datetime_format_long {
3467 1     1   3 my $self = shift;
3468            
3469 1         1 my $width = 'long';
3470 1         6 my $format = $self->_build_any_datetime_format($width);
3471            
3472 1         4 my $date = $self->_build_any_date_format($width);
3473 1         4 my $time = $self->_build_any_time_format($width);
3474            
3475 1         5 $format =~ s/\{0\}/$time/;
3476 1         5 $format =~ s/\{1\}/$date/;
3477            
3478 1         25 return $format;
3479             }
3480              
3481             sub _build_datetime_format_medium {
3482 1     1   3 my $self = shift;
3483            
3484 1         2 my $width = 'medium';
3485 1         3 my $format = $self->_build_any_datetime_format($width);
3486            
3487 1         4 my $date = $self->_build_any_date_format($width);
3488 1         4 my $time = $self->_build_any_time_format($width);
3489            
3490 1         4 $format =~ s/\{0\}/$time/;
3491 1         3 $format =~ s/\{1\}/$date/;
3492            
3493 1         25 return $format;
3494             }
3495              
3496             sub _build_datetime_format_short {
3497 1     1   3 my $self = shift;
3498            
3499 1         2 my $width = 'short';
3500 1         3 my $format = $self->_build_any_datetime_format($width);
3501            
3502 1         4 my $date = $self->_build_any_date_format($width);
3503 1         4 my $time = $self->_build_any_time_format($width);
3504            
3505 1         4 $format =~ s/\{0\}/$time/;
3506 1         4 $format =~ s/\{1\}/$date/;
3507            
3508 1         26 return $format;
3509             }
3510              
3511             sub _build_format_data {
3512 0     0   0 my $self = shift;
3513 0         0 my $default_calendar = $self->default_calendar();
3514              
3515 0         0 my @bundles = $self->_find_bundle('datetime_formats_available_formats');
3516 0         0 foreach my $calendar ($default_calendar, 'gregorian') {
3517 0         0 foreach my $bundle (@bundles) {
3518 0         0 my $datetime_formats_available_formats = $bundle->datetime_formats_available_formats;
3519 0         0 my $result = $datetime_formats_available_formats->{$calendar};
3520 0 0       0 return $result if $result;
3521             }
3522             }
3523              
3524 0         0 return {};
3525             }
3526              
3527             sub format_for {
3528 0     0 1 0 my ($self, $format) = @_;
3529              
3530 0         0 my $format_data = $self->format_data;
3531              
3532 0   0     0 return $format_data->{$format} // '';
3533             }
3534              
3535             sub _build_available_formats {
3536 0     0   0 my $self = shift;
3537              
3538 0         0 my $format_data = $self->format_data;
3539              
3540 0         0 return [keys %$format_data];
3541             }
3542              
3543             sub _build_default_date_format_length {
3544 0     0   0 my $self = shift;
3545            
3546 0         0 my $default_calendar = $self->default_calendar();
3547              
3548 0         0 my @bundles = $self->_find_bundle('date_formats');
3549 0         0 foreach my $calendar ($default_calendar, 'gregorian') {
3550 0         0 foreach my $bundle (@bundles) {
3551 0         0 my $date_formats = $bundle->date_formats;
3552 0         0 my $result = $date_formats->{$calendar}{default};
3553 0 0       0 return $result if $result;
3554             }
3555             }
3556             }
3557              
3558             sub _build_default_time_format_length {
3559 0     0   0 my $self = shift;
3560            
3561 0         0 my $default_calendar = $self->default_calendar();
3562              
3563 0         0 my @bundles = $self->_find_bundle('time_formats');
3564 0         0 foreach my $calendar ($default_calendar, 'gregorian') {
3565 0         0 foreach my $bundle (@bundles) {
3566 0         0 my $time_formats = $bundle->time_formats;
3567 0         0 my $result = $time_formats->{$calendar}{default};
3568 0 0       0 return $result if $result;
3569             }
3570             }
3571             }
3572              
3573             sub _build_prefers_24_hour_time {
3574 1     1   5 my $self = shift;
3575              
3576 1 50       28 return $self->time_format_short() =~ /h|K/ ? 0 : 1;
3577             }
3578              
3579             {
3580             my %days_2_number = (
3581             mon => 1,
3582             tue => 2,
3583             wen => 3,
3584             thu => 4,
3585             fri => 5,
3586             sat => 6,
3587             sun => 7,
3588             );
3589              
3590             sub _build_first_day_of_week {
3591              
3592 1     1   2 my $self = shift;
3593              
3594 1         9 my $first_day = $self->week_data_first_day;
3595            
3596 1         26 return $days_2_number{$first_day};
3597             }
3598             }
3599              
3600             # Sub to mangle Unicode regex to Perl regex
3601             # Backwards compatibility hack
3602 20 50   20   178 *_unicode_to_perl = eval <<'EOT' || \&_new_perl;
  20     20   34  
  20     161   1053  
  20         92  
  20         52  
  20         912  
  161         244  
  161         455  
  161         698  
  98         1843  
  161         1831  
3603             sub {
3604             my $regex = shift;
3605              
3606             return '' unless length $regex;
3607             $regex =~ s/
3608             (?:\\\\)*+ # Pairs of \
3609             (?!\\) # Not followed by \
3610             \K # But we don't want to keep that
3611             (?<set> # Capture this
3612             \[ # Start a set
3613             (?:
3614             [^\[\]\\]+ # One or more of not []\
3615             | # or
3616             (?:
3617             (?:\\\\)*+ # One or more pairs of \ without back tracking
3618             \\. # Followed by an escaped character
3619             )
3620             | # or
3621             (?&set) # An inner set
3622             )++ # Do the inside set stuff one or more times without backtracking
3623             \] # End the set
3624             )
3625             / _convert($1) /xeg;
3626             no warnings "experimental::regex_sets";
3627             no warnings "deprecated"; # Because CLDR uses surrogates
3628             return qr/$regex/x;
3629             };
3630              
3631             EOT
3632              
3633             # Backwards compatibility hack
3634 98 50   98   166 *_convert = eval <<'EOT' || \&_new_perl;
  98 50       187  
  98         164  
  0         0  
  98         91  
  98         782  
  98         135  
  98         153  
  98         2235  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
3635             sub {
3636             my $set = shift;
3637            
3638             # Some definitions
3639             my $posix = qr/(?(DEFINE)
3640             (?<posix> (?> \[: .+? :\] ) )
3641             )/x;
3642            
3643             # Convert Unicode escapes \u1234 to characters
3644             $set =~ s/\\u(\p{Ahex}+)/chr(hex($1))/egx;
3645            
3646             # Check to see if this is a normal character set
3647             my $normal = 0;
3648            
3649             $normal = 1 if $set =~ /^
3650             \s* # Possible white space
3651             \[ # Opening set
3652             ^? # Possible negation
3653             (?: # One of
3654             [^\[\]]++ # Not an open or close set
3655             | # Or
3656             (?<=\\)[\[\]] # An open or close set preceded by \
3657             | # Or
3658             (?:
3659             \s* # Possible white space
3660             (?&posix) # A posix class
3661             (?! # Not followed by
3662             \s* # Possible white space
3663             [&-] # A Unicode regex op
3664             \s* # Possible white space
3665             \[ # A set opener
3666             )
3667             )
3668             )+
3669             \] # Close the set
3670             \s* # Possible white space
3671             $
3672             $posix
3673             /x;
3674            
3675             # Convert posix to perl
3676             $set =~ s/\[:(.*?):\]/\\p{$1}/g;
3677            
3678             if ($normal) {
3679             return "$set";
3680             }
3681            
3682             # Fix up [abc[de]] to [[abc][de]]
3683             $set =~ s/\[ ( (?>\^? \s*) [^\]]+? ) \s* \[/[[$1][/gx;
3684            
3685             # Fix up [[ab]cde] to [[ab][cde]]
3686             $set =~ s/\[ \^?+ \s* \[ [^\]]+? \] \K \s* ( [^\[]+ ) \]/[$1]]/gx;
3687            
3688             # Unicode uses ^ to compliment the set where as Perl uses !
3689             $set =~ s/\[ \^ \s*/[!/gx;
3690            
3691             # The above can leave us with empty sets. Strip them out
3692             $set =~ s/\[\]//g;
3693            
3694             # Fixup inner sets with no operator
3695             1 while $set =~ s/ \] \s* \[ /] + [/gx;
3696             1 while $set =~ s/ \] \s * (\\p\{.*?\}) /] + $1/xg;
3697             1 while $set =~ s/ \\p\{.*?\} \s* \K \[ / + [/xg;
3698             1 while $set =~ s/ \\p\{.*?\} \s* \K (\\p\{.*?\}) / + $1/xg;
3699            
3700             # Unicode uses [] for grouping as well as starting an inner set
3701             # Perl uses ( ) So fix that up now
3702            
3703             $set =~ s/. \K \[ (?> (!?) \s*) \[ /($1\[/gx;
3704             $set =~ s/ \] \s* \] (.) /])$1/gx;
3705            
3706             return "(?$set)";
3707             }
3708              
3709             EOT
3710              
3711             # The following pod is for methods defined in the Moose Role
3712             # files that are automatically generated from the data
3713             =back
3714              
3715             =head2 Valid codes
3716              
3717             =over 4
3718              
3719             =item valid_languages()
3720              
3721             This method returns a list containing all the valid language codes
3722              
3723             =item valid_scripts()
3724              
3725             This method returns a list containing all the valid script codes
3726              
3727             =item valid_territories()
3728              
3729             This method returns a list containing all the valid territory codes
3730              
3731             =item valid_variants()
3732              
3733             This method returns a list containing all the valid variant codes
3734              
3735             =item key_aliases()
3736              
3737             This method returns a hash that maps valid keys to their valid aliases
3738              
3739             =item key_names()
3740              
3741             This method returns a hash that maps valid key aliases to their valid keys
3742              
3743             =item valid_keys()
3744              
3745             This method returns a hash of valid keys and the valid type codes you
3746             can have with each key
3747              
3748             =item language_aliases()
3749              
3750             This method returns a hash that maps valid language codes to their valid aliases
3751              
3752             =item territory_aliases()
3753              
3754             This method returns a hash that maps valid territory codes to their valid aliases
3755              
3756             =item variant_aliases()
3757              
3758             This method returns a hash that maps valid variant codes to their valid aliases
3759              
3760             =back
3761              
3762             =head2 Information about weeks
3763              
3764             There are no standard codes for the days of the weeks so CLDR uses the following
3765             three letter codes to represent unlocalised days
3766              
3767             =over 4
3768              
3769             =item sun
3770              
3771             Sunday
3772              
3773             =item mon
3774              
3775             Monday
3776              
3777             =item tue
3778              
3779             Tuesday
3780              
3781             =item wed
3782              
3783             Wednesday
3784              
3785             =item thu
3786              
3787             Thursday
3788              
3789             =item fri
3790              
3791             Friday
3792              
3793             =item sat
3794              
3795             Saturday
3796              
3797             =back
3798              
3799             =cut
3800              
3801             sub _week_data {
3802 5     5   7 my ($self, $territory_id, $week_data_hash) = @_;
3803            
3804 5   33     24 $territory_id //= ( $self->territory_id || $self->likely_subtag->territory_id );
      33        
3805            
3806 5 100       24 return $week_data_hash->{$territory_id} if exists $week_data_hash->{$territory_id};
3807            
3808 2         3 while (1) {
3809 8         199 $territory_id = $self->territory_contained_by()->{$territory_id};
3810 8 50       13 return unless defined $territory_id;
3811 8 100       23 return $week_data_hash->{$territory_id} if exists $week_data_hash->{$territory_id};
3812             }
3813             }
3814              
3815             =over 4
3816              
3817             =item week_data_min_days($territory_id)
3818              
3819             This method takes an optional territory id and returns a the minimum number of days
3820             a week must have to count as the starting week of the new year. It uses the current
3821             locale's territory if no territory id is passed in.
3822              
3823             =cut
3824              
3825             sub week_data_min_days {
3826 1     1 1 3 my ($self, $territory_id) = @_;
3827            
3828 1         37 my $week_data_hash = $self->_week_data_min_days();
3829 1         4 return _week_data($self, $territory_id, $week_data_hash);
3830             }
3831              
3832             =item week_data_first_day($territory_id)
3833              
3834             This method takes an optional territory id and returns the three letter code of the
3835             first day of the week for that territory. If no territory id is passed in then it
3836             uses the current locale's territory.
3837              
3838             =cut
3839              
3840             sub week_data_first_day {
3841 2     2 1 4 my ($self, $territory_id) = @_;
3842            
3843 2         69 my $week_data_hash = $self->_week_data_first_day();
3844 2         6 return _week_data($self, $territory_id, $week_data_hash);
3845             }
3846              
3847             =item week_data_weekend_start()
3848              
3849             This method takes an optional territory id and returns the three letter code of the
3850             first day of the week end for that territory. If no territory id is passed in then it
3851             uses the current locale's territory.
3852              
3853             =cut
3854              
3855             sub week_data_weekend_start {
3856 1     1 1 3 my ($self, $territory_id) = @_;
3857 1         38 my $week_data_hash = $self->_week_data_weekend_start();
3858            
3859 1         4 return _week_data($self, $territory_id, $week_data_hash);
3860             }
3861              
3862             =item week_data_weekend_end()
3863              
3864             This method takes an optional territory id and returns the three letter code of the
3865             first day of the week end for that territory. If no territory id is passed in then it
3866             uses the current locale's territory.
3867              
3868             =cut
3869              
3870             sub week_data_weekend_end {
3871 1     1 1 3 my ($self, $territory_id) = @_;
3872 1         37 my $week_data_hash = $self->_week_data_weekend_end();
3873            
3874 1         3 return _week_data($self, $territory_id, $week_data_hash);
3875             }
3876              
3877             =item month_patterns($context, $width, $type)
3878              
3879             The Chinese lunar calendar can insert a leap month after nearly any month of its year;
3880             when this happens, the month takes the name of the preceding month plus a special marker.
3881             The Hindu lunar calendars can insert a leap month before any one or two months of the year;
3882             when this happens, not only does the leap month take the name of the following month plus a
3883             special marker, the following month also takes a special marker. Moreover, in the Hindu
3884             calendar sometimes a month is skipped, in which case the preceding month takes a special marker
3885             plus the names of both months. The monthPatterns() method returns an array ref of month names
3886             with the marker added.
3887              
3888             =cut
3889              
3890             my %month_functions = (
3891             format => {
3892             wide => 'month_format_wide',
3893             abbreviated => 'month_format_abbreviated',
3894             narrow => 'month_format_narrow',
3895             },
3896             'stand-alone' => {
3897             wide => 'month_stand_alone_wide',
3898             abbreviated => 'month_stand_alone_abbreviated',
3899             narrow => 'month_stand_alone_narrow',
3900             }
3901             );
3902              
3903             sub month_patterns {
3904 1     1 1 2217 my ($self, $context, $width, $type) = @_;
3905            
3906 1         3 my @months;
3907 1 50       5 if ($context eq 'numeric') {
3908 0         0 @months = ( 1 .. 14 );
3909             }
3910             else {
3911 1         6 my $months_method = $month_functions{$context}{$width};
3912 1         53 my $months = $self->$months_method;
3913 1         6 @months = @$months;
3914             }
3915            
3916 1         5 my $default_calendar = $self->default_calendar();
3917            
3918 1         4 my @bundles = $self->_find_bundle('month_patterns');
3919              
3920 1         1 my $result;
3921             BUNDLES: {
3922 1         2 foreach my $bundle (@bundles) {
  2         5  
3923 2         56 my $month_patterns = $bundle->month_patterns;
3924 2 50       6 if (exists $month_patterns->{$default_calendar}{alias}) {
3925 0         0 $default_calendar = $month_patterns->{$default_calendar}{alias};
3926 0         0 redo BUNDLES;
3927             }
3928            
3929             # Check for width alias
3930 2 100       9 if (exists $month_patterns->{$default_calendar}{$context}{$width}{alias}) {
3931 1         3 $context = $month_patterns->{$default_calendar}{$context}{$width}{alias}{context};
3932 1         4 $width = $month_patterns->{$default_calendar}{$context}{$width}{alias}{width};
3933 1         4 redo BUNDLES;
3934             }
3935            
3936 1         5 $result = $month_patterns->{$default_calendar}{$context}{$width}{$type};
3937 1 50       3 last BUNDLES if $result;
3938             }
3939 0 0       0 if ($default_calendar ne 'gregorian') {
3940 0         0 $default_calendar = 'gregorian';
3941 0         0 redo BUNDLES;
3942             }
3943             }
3944            
3945 1 50       4 if ($result) {
3946 1         3 foreach my $month (@months) {
3947 12         21 (my $fixed_month = $result) =~ s/\{0\}/$month/g;
3948 12         15 $month = $fixed_month;
3949             }
3950             }
3951            
3952 1         14 return \@months;
3953             }
3954              
3955             =item cyclic_name_sets($context, $width, $type)
3956              
3957             This method returns an arrayref containing the cyclic names for the locale's
3958             default calendar using the given context, width and type.
3959              
3960             Context can can currently only be c<format>
3961              
3962             Width is one of C<abbreviated>, C<narrow> or C<wide>
3963              
3964             Type is one of C<dayParts>, C<days>, C<months>, C<solarTerms>, C<years> or C<zodiacs>
3965              
3966             =cut
3967              
3968             sub cyclic_name_sets {
3969 1     1 1 3 my ($self, $context, $width, $type) = @_;
3970            
3971 1         4 my @bundles = $self->_find_bundle('cyclic_name_sets');
3972 1         8 my $default_calendar = $self->default_calendar();
3973 1         3 foreach my $bundle (@bundles) {
3974 2         65 my $cyclic_name_set = $bundle->cyclic_name_sets();
3975             NAME_SET: {
3976 2 50       3 if (my $alias_calendar = $cyclic_name_set->{$default_calendar}{alias}) {
  3         8  
3977 0         0 $default_calendar = $alias_calendar;
3978 0         0 redo NAME_SET;
3979             }
3980            
3981 3 50       7 if (my $type_alias = $cyclic_name_set->{$default_calendar}{$type}{alias}) {
3982 0         0 $type = $type_alias;
3983 0         0 redo NAME_SET;
3984             }
3985            
3986 3 100       10 if (my $width_alias = $cyclic_name_set->{$default_calendar}{$type}{$context}{$width}{alias}) {
3987 1         3 $context = $width_alias->{context};
3988 1         3 $type = $width_alias->{name_set};
3989 1         2 $width = $width_alias->{type};
3990 1         4 redo NAME_SET;
3991             }
3992            
3993 2         7 my $return = [
3994 30         27 @{ $cyclic_name_set->{$default_calendar}{$type}{$context}{$width} }
3995 2         2 {sort { $a <=> $b } keys %{ $cyclic_name_set->{$default_calendar}{$type}{$context}{$width} }}
  2         14  
3996             ];
3997            
3998 2 100       18 return $return if @$return;
3999             }
4000             }
4001 0         0 return [];
4002             }
4003              
4004             =back
4005              
4006             =head2 Territory Containment
4007              
4008             =over 4
4009              
4010             =item territory_contains()
4011              
4012             This method returns a hash ref keyed on territory id. The value is an array ref.
4013             Each element of the array ref is a territory id of a territory immediately
4014             contained in the territory used as the key
4015              
4016             =item territory_contained_by()
4017              
4018             This method returns a hash ref keyed on territory id. The value of the hash
4019             is the territory id of the immediately containing territory.
4020              
4021             =back
4022              
4023             =head2 Numbering Systems
4024              
4025             =over 4
4026              
4027             =item numbering_system()
4028              
4029             This method returns a hash ref keyed on numbering system id which, for a given
4030             locale, can be got by calling the default_numbering_system() method. The values
4031             of the hash are a two element hash ref the keys being C<type> and C<data>. If the
4032             type is C<numeric> then the data is an array ref of characters. The position in the
4033             array matches the numeric value of the character. If the type is C<algorithmic>
4034             then data is the name of the algorithm used to display numbers in that format.
4035              
4036             =back
4037              
4038             =head2 Number Formatting
4039              
4040             =over 4
4041              
4042             =item format_number($number, $format, $currency, $for_cash)
4043              
4044             This method formats the number $number using the format $format. If the format contains
4045             the currency symbol C<¤> then the currency symbol for the currency code in $currency
4046             will be used. If $currency is undef() then the default currency code for the locale
4047             will be used.
4048              
4049             Note that currency codes are based on territory so if you do not pass in a currency
4050             and your locale did not get passed a territory in the constructor you are going
4051             to end up with the L<likely sub tag's|/likely_subtags> idea of the currency. This
4052             functionality may be removed or at least changed to emit a warning in future
4053             releases.
4054              
4055             $for_cash is only used during currency formatting. If true then cash rounding
4056             will be used otherwise financial rounding will be used.
4057              
4058             This function also handles rule based number formatting. If $format is string equivalent
4059             to one of the current locale's public rule based number formats then $number will be
4060             formatted according to that rule.
4061              
4062             =item add_currency_symbol($format, $symbol)
4063              
4064             This method returns the format with the currency symbol $symbol correctly inserted
4065             into the format
4066              
4067             =item parse_number_format($format, $currency, $currency_data, $for_cash)
4068              
4069             This method parses a CLDR numeric format string into a hash ref containing data used to
4070             format a number. If a currency is being formatted then $currency contains the
4071             currency code, $currency_data is a hashref containing the currency rounding
4072             information and $for_cash is a flag to signal cash or financial rounding.
4073              
4074             This should probably be a private function.
4075              
4076             =item round($number, $increment, $decimal_digits)
4077              
4078             This method returns $number rounded to the nearest $increment with $decimal_digits
4079             digits after the decimal point
4080              
4081             =item get_formatted_number($number, $format, $currency_data, $for_cash)
4082              
4083             This method takes the $format produced by parse_number_format() and uses it to
4084             parse $number. It returns a string containing the parsed number. If a currency
4085             is being formatted then $currency_data is a hashref containing the currency
4086             rounding information and $for_cash is a flag to signal cash or financial rounding.
4087              
4088             =item get_digits()
4089              
4090             This method returns an array containing the digits used by the locale, The order of the
4091             array is the order of the digits. It the locale's numbering system is C<algorithmic> it
4092             will return C<[0,1,2,3,4,5,6,7,8,9]>
4093              
4094             =item default_numbering_system()
4095              
4096             This method returns the numbering system id for the locale.
4097              
4098             =back
4099              
4100             =head2 Measurement Information
4101              
4102             =over 4
4103              
4104             =item measurement_system()
4105              
4106             This method returns a hash ref keyed on territory, the value being the measurement system
4107             id for the territory. If the territory you are interested in is not listed use the
4108             territory_contained_by() method until you find an entry.
4109              
4110             =item paper_size()
4111              
4112             This method returns a hash ref keyed on territory, the value being the paper size used
4113             in that territory. If the territory you are interested in is not listed use the
4114             territory_contained_by() method until you find an entry.
4115              
4116             =back
4117              
4118             =head2 Likely Tags
4119              
4120             =over 4
4121              
4122             =item likely_subtags()
4123              
4124             A full locale tag requires, as a minimum, a language, script and territory code. However for
4125             some locales it is possible to infer the missing element if the other two are given, e.g.
4126             given C<en_GB> you can infer the script will be latn. It is also possible to fill in the
4127             missing elements of a locale with sensible defaults given sufficient knowledge of the layout
4128             of the CLDR data and usage patterns of locales around the world.
4129              
4130             This function returns a hash ref keyed on partial locale id's with the value being the locale
4131             id for the most likely language, script and territory code for the key.
4132              
4133             =back
4134              
4135             =head2 Currency Information
4136              
4137             =over 4
4138              
4139             =item currency_fractions()
4140              
4141             This method returns a hash ref keyed on currency id. The value is a hash ref containing four keys.
4142             The keys are
4143              
4144             =over 8
4145              
4146             =item digits
4147              
4148             The number of decimal digits normally formatted.
4149              
4150             =item rounding
4151              
4152             The rounding increment, in units of 10^-digits.
4153              
4154             =item cashdigits
4155              
4156             The number of decimal digits to be used when formatting quantities used in cash transactions (as opposed
4157             to a quantity that would appear in a more formal setting, such as on a bank statement).
4158              
4159             =item cashrounding
4160              
4161             The cash rounding increment, in units of 10^-cashdigits.
4162              
4163             =back
4164              
4165             =item default_currency($territory_id)
4166              
4167             This method returns the default currency id for the territory id.
4168             If no territory id is given then the current locale's is used
4169              
4170             =cut
4171              
4172             sub default_currency {
4173 1     1 1 3 my ($self, $territory_id) = @_;
4174            
4175 1   33     11 $territory_id //= $self->territory_id;
4176            
4177 1 50       3 if (! $territory_id) {
4178 0         0 $territory_id = $self->likely_subtag->territory_id;
4179 0         0 warn "Locale::CLDR::default_currency:- No territory given using $territory_id at ";
4180             }
4181            
4182 1         35 my $default_currencies = $self->_default_currency;
4183            
4184 1 50       6 return $default_currencies->{$territory_id} if exists $default_currencies->{$territory_id};
4185            
4186 0         0 while (1) {
4187 0         0 $territory_id = $self->territory_contained_by($territory_id);
4188 0 0       0 last unless $territory_id;
4189 0 0       0 return $default_currencies->{$territory_id} if exists $default_currencies->{$territory_id};
4190             }
4191             }
4192              
4193             =item currency_symbol($currency_id)
4194              
4195             This method returns the currency symbol for the given currency id in the current locale.
4196             If no currency id is given it uses the locale's default currency
4197              
4198             =cut
4199              
4200             sub currency_symbol {
4201 1     1 1 3 my ($self, $currency_id) = @_;
4202            
4203 1   33     3 $currency_id //= $self->default_currency;
4204            
4205 1         4 my @bundles = reverse $self->_find_bundle('curriencies');
4206 1         5 foreach my $bundle (@bundles) {
4207 1         29 my $symbol = $bundle->curriencies()->{$currency_id}{symbol};
4208 1 50       8 return $symbol if $symbol;
4209             }
4210            
4211 0         0 return '';
4212             }
4213              
4214             =back
4215              
4216             =head2 Calendar Information
4217              
4218             =over 4
4219              
4220             =item calendar_preferences()
4221              
4222             This method returns a hash ref keyed on territory id. The values are array refs containing the preferred
4223             calendar id's in order of preference.
4224              
4225             =item default_calendar($territory)
4226              
4227             This method returns the default calendar id for the given territory. If no territory id given it
4228             used the territory of the current locale.
4229              
4230             =back
4231              
4232             =head2 Collation
4233              
4234             =over 4
4235              
4236             =item collation()
4237              
4238             This method returns a Locale::CLDR::Collator object. This is still in development. Future releases will
4239             try and match the API from L<Unicode::Collate> as much as possible and add tailoring for locales.
4240             There are currently two named Parameters, more will be added as the functionality increases. They are C<type>
4241             which is currently ignored but will be used in future to select which collation type of the locale you want.
4242             E.G. I<standard> or I<phonebook> for German. The second is C<strenth> which selects which of the collation
4243             strength's you want.
4244              
4245             =back
4246              
4247             =cut
4248              
4249             sub collation {
4250 5     5 1 329735 my ($self, %params) = @_;
4251            
4252 5   33     81 $params{type} //= $self->_default_collation;
4253 5   66     36 $params{strength} //= $self->_default_collation_strength;
4254            
4255 5         105 return Locale::CLDR::Collator->new(locale => $self, %params);
4256             }
4257              
4258             sub _collation_overrides {
4259 5     5   14 my ($self, $type) = @_;
4260            
4261 5         37 my @bundles = reverse $self->_find_bundle('collation');
4262            
4263 5         14 my $override = '';
4264 5         16 foreach my $bundle (@bundles) {
4265 0 0       0 last if $override = $bundle->collation()->{$type};
4266             }
4267            
4268 5 50 33     30 if ($type ne 'standard' && ! $override) {
4269 0         0 foreach my $bundle (@bundles) {
4270 0 0       0 last if $override = $bundle->collation()->{standard};
4271             }
4272             }
4273            
4274 5   50     55 return $override || [];
4275             }
4276            
4277             sub _default_collation {
4278 5     5   36 return 'standard';
4279             }
4280              
4281             sub _default_collation_strength {
4282 1     1   4 return 3;
4283             }
4284              
4285             =head1 Locales
4286              
4287             Other locales can be found on CPAN. You can install Language packs from the
4288             Locale::CLDR::Locales::* packages. You will in future be able to install language
4289             packs for a given territory by looking for a Bundle::Locale::CLDR::* package.
4290              
4291             If you are looking for a language pack that is not yet published then get hold of
4292             the version 0.25.4 from http://search.cpan.org/CPAN/authors/id/J/JG/JGNI/Locale-CLDR-v0.25.4.tar.gz
4293             which has data for all locals alternatively you can get hold of the latest version of the
4294             code from git hub at https://github.com/ThePilgrim/perlcldr
4295              
4296             =head1 AUTHOR
4297              
4298             John Imrie, C<< <JGNI at cpan dot org> >>
4299              
4300             =head1 BUGS
4301              
4302             Please report any bugs or feature requests to C<bug-locale-cldr at rt.cpan.org>, or through
4303             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Locale-CLDR>. I will be notified, and then you'll
4304             automatically be notified of progress on your bug as I make changes.
4305              
4306             =head1 SUPPORT
4307              
4308             You can find documentation for this module with the perldoc command.
4309              
4310             perldoc Locale::CLDR
4311              
4312             You can also look for information at:
4313              
4314             =over 4
4315              
4316             =item * RT: CPAN's request tracker
4317              
4318             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Locale-CLDR>
4319              
4320             =item * AnnoCPAN: Annotated CPAN documentation
4321              
4322             L<http://annocpan.org/dist/Locale-CLDR>
4323              
4324             =item * CPAN Ratings
4325              
4326             L<http://cpanratings.perl.org/d/Locale-CLDR>
4327              
4328             =item * Search CPAN
4329              
4330             L<http://search.cpan.org/dist/Locale-CLDR/>
4331              
4332             =back
4333              
4334              
4335             =head1 ACKNOWLEDGEMENTS
4336              
4337             Everyone at the Unicode Consortium for providing the data.
4338              
4339             Karl Williams for his tireless work on Unicode in the Perl
4340             regex engine.
4341              
4342             =head1 COPYRIGHT & LICENSE
4343              
4344             Copyright 2009-2015 John Imrie.
4345              
4346             This program is free software; you can redistribute it and/or modify it
4347             under the terms of either: the GNU General Public License as published
4348             by the Free Software Foundation; or the Artistic License.
4349              
4350             See http://dev.perl.org/licenses/ for more information.
4351              
4352             =cut
4353              
4354             1; # End of Locale::CLDR