File Coverage

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