File Coverage

blib/lib/DateTimeX/Lite/Locale.pm
Criterion Covered Total %
statement 149 199 74.8
branch 38 60 63.3
condition 4 6 66.6
subroutine 39 62 62.9
pod 0 41 0.0
total 230 368 62.5


line stmt bran cond sub pod time code
1             # $Id: Locale.pm 30361 2009-02-20 08:13:39Z tokuhirom $
2              
3             package DateTimeX::Lite::Locale;
4 62     62   213718 use strict;
  62         139  
  62         8313  
5 62     62   345 use warnings;
  62         183  
  62         2509  
6 62     62   22330 use File::ShareDir qw(dist_file);
  62         191519  
  62         4134  
7 62     62   458 use File::Spec;
  62         135  
  62         1607  
8 62     62   342 use Carp ();
  62         275  
  62         35286  
9              
10             our %CachedLocales;
11             our %Aliases;
12              
13             {
14             my $db = dist_file('DateTimeX-Lite', 'DateTimeX/Lite/Locale/Aliases.dat');
15             my $aliases = do $db
16             or die "cannot load alias database";
17             %Aliases = %$aliases;
18             }
19              
20             sub _load_locale {
21 508     508   1894 my $name = shift;
22              
23             # XXX - original comment as follows:
24             # Support RFC 3066 language tags, which use '-' instead of '_'
25 508         2172 $name =~ tr/-/_/;
26              
27             # Strip off charset for LC_* ids : en_GB.UTF-8 etc
28 508         1673 $name =~ s/\..*$//;
29              
30 508         1189 my $original = $name;
31 508         2826 while (exists $Aliases{$name}) {
32 10         37 $name = $Aliases{$name};
33             }
34              
35 508         2213 my ($language, $script, $territory, $variant ) = _parse_id($name);
36              
37 508         1168 my @guesses;
38              
39 508 100       1682 if ( defined $script )
40             {
41 61         416 my $guess = join '_', lc $language, ucfirst lc $script;
42              
43 61         170 push @guesses, $guess;
44              
45 61 100       303 $guess .= '_' . uc $territory if defined $territory;
46              
47             # version with script comes first
48 61         241 unshift @guesses, $guess;
49             }
50              
51 508 100       1590 if ( defined $variant )
52             {
53 5         29 push @guesses,
54             join '_', lc $language, uc $territory, uc $variant;
55             }
56              
57 508 100       1770 if ( defined $territory )
58             {
59 333         1904 push @guesses,
60             join '_', lc $language, uc $territory;
61             }
62              
63 508         1725 push @guesses, lc $language;
64              
65 508         1712 foreach my $id (@guesses) {
66 508         801 my $h;
67 508         1713332 $h = do "DateTimeX/Lite/Locale/$id.dat";
68 508 100 66     29512 if (! $@ && $h) {
69 506 100       2347 $h->{id} = $original if $original ne $name;
70 506         2638 return $h;
71             }
72             }
73 2         11 return ();
74             }
75              
76             sub load {
77 4828     4828 0 320613 my ($class, $name) = @_;
78              
79 4828 100       29610 return $CachedLocales{$name} if $CachedLocales{$name};
80              
81 508         16952 my $conf = _load_locale($name);
82 508 100       2342 if (! $conf) {
83 2         682 Carp::croak("Invalid locale name or id: locale $name not found");
84             }
85 506         10798 return $CachedLocales{$name} = $class->new(%$conf);
86             }
87              
88 62     62   87671 use List::MoreUtils ();
  62         737735  
  62         6611  
89              
90             BEGIN
91             {
92 62     62   287 foreach my $field ( qw( id en_complete_name native_complete_name
93             en_language en_script en_territory en_variant
94             native_language native_script native_territory native_variant
95             )
96             )
97             {
98             # remove leading 'en_' for method name
99 682         1766 (my $meth_name = $field) =~ s/^en_//;
100              
101             # also remove 'complete_'
102 682         1189 $meth_name =~ s/complete_//;
103              
104 62     62   473 no strict 'refs';
  62         129  
  62         4040  
105 682     9606   2222 *{$meth_name} = sub { $_[0]->{$field} } }
  682         95094  
  9606         575842  
106             }
107              
108             sub new
109             {
110 506     506 0 2109 my $class = shift;
111              
112             # By making the default format lengths part of the object's hash
113             # key, it allows them to be settable.
114 506         14655 my $self = bless { @_,
115             default_date_format_length => 'medium',
116             default_time_format_length => 'medium',
117             }, $class;
118              
119 506 100       5468 $self->{native_language} = $self->{en_language}
120             unless exists $self->{native_language};
121            
122 506         1145 my @en_pieces;
123             my @native_pieces;
124 506         3073 foreach my $p ( qw( language script territory variant ) )
125             {
126 2024 100       13631 push @en_pieces, $self->{"en_$p"} if exists $self->{"en_$p"};
127 2024 100       8028 push @native_pieces, $self->{"native_$p"} if exists $self->{"native_$p"};
128             }
129              
130 506         3255 $self->{en_complete_name} = join ' ', @en_pieces;
131 506         2318 $self->{native_complete_name} = join ' ', @native_pieces;
132              
133 506         4011 return $self;
134             }
135              
136 3     3 0 26 sub language_id { ( DateTimeX::Lite::Locale::_parse_id( $_[0]->id ) )[0] }
137 1     1 0 6 sub script_id { ( DateTimeX::Lite::Locale::_parse_id( $_[0]->id ) )[1] }
138 4     4 0 193 sub territory_id { ( DateTimeX::Lite::Locale::_parse_id( $_[0]->id ) )[2] }
139 3     3 0 23 sub variant_id { ( DateTimeX::Lite::Locale::_parse_id( $_[0]->id ) )[3] }
140             sub _parse_id
141             {
142 519     519   3647 $_[0] =~ /([a-z]+) # id
143             (?: _([A-Z][a-z]+) )? # script - Title Case - optional
144             (?: _([A-Z]+) )? # territory - ALL CAPS - optional
145             (?: _([A-Z]+) )? # variant - ALL CAPS - optional
146             /x;
147              
148 519         3947 return $1, $2, $3, $4;
149             }
150              
151              
152             my @FormatLengths = qw( short medium long full );
153              
154             sub date_format_default {
155 3     3 0 15 my $default = $_[0]->default_date_format_length();
156 3 50       14 if (! $default) {
157 0         0 die sprintf("DateTimeX::Lite::Locale %s did not return a proper value from default_date_format_length()", $_[0]->{id});
158             }
159 3         10 my $meth = "date_format_$default";
160 3         20 $_[0]->$meth();
161             }
162              
163             sub date_formats
164             {
165             return
166 448     448 0 1901 { map { my $meth = 'date_format_' . $_;
  1792         3964  
167 1792         7362 $_ => $_[0]->$meth() } @FormatLengths }
168             }
169              
170             sub time_format_default
171             {
172 3     3 0 16 my $default = $_[0]->default_time_format_length();
173 3 50       12 if (! $default) {
174 0         0 die sprintf("DateTimeX::Lite::Locale %s did not return a proper value from default_time_format_length()", $_[0]->{name});
175             }
176 3         11 my $meth = "time_format_$default";
177 3         17 $_[0]->$meth();
178             }
179              
180             sub time_formats
181             {
182             return
183 448     448 0 1211 { map { my $meth = 'time_format_' . $_;
  1792         3696  
184 1792         17533 $_ => $_[0]->$meth() } @FormatLengths }
185             }
186              
187             sub format_for
188             {
189 44     44 0 1327 my $self = shift;
190 44         50 my $for = shift;
191              
192 44         92 my $meth = '_format_for_' . $for;
193              
194 44 50       198 return unless $self->can($meth);
195              
196 44         140 return $self->$meth();
197             }
198              
199             sub available_formats
200             {
201 0     0 0 0 my $self = shift;
202              
203             # The various parens seem to be necessary to force uniq() to see
204             # the caller's list context. Go figure.
205 0 0       0 my @uniq = List::MoreUtils::uniq( map { keys %{ $_->_available_formats() || {} } }
  0         0  
  0         0  
206             Class::ISA::self_and_super_path( ref $self )
207             );
208              
209             # Doing the sort in the same expression doesn't work under 5.6.x.
210 0         0 return sort @uniq;
211             }
212              
213             # Just needed for the above method.
214 0     0   0 sub _available_formats { }
215              
216 8     8 0 56 sub default_date_format_length { $_[0]->{default_date_format_length} }
217              
218             sub set_default_date_format_length
219             {
220 1     1 0 4 my ($self, $l) = @_;
221 1 50       10 die unless $l =~ /^(?:full|long|medium|short)$/i;
222              
223 1         5 $self->{default_date_format_length} = lc $l;
224             }
225              
226 8     8 0 33 sub default_time_format_length { $_[0]->{default_time_format_length} }
227              
228             sub set_default_time_format_length
229             {
230 1     1 0 3 my ($self, $l) = @_;
231 1 50       48 die unless $l =~ /^(?:full|long|medium|short)$/i;
232              
233 1         6 $self->{default_time_format_length} = lc $l;
234             }
235              
236             for my $length ( qw( full long medium short ) )
237             {
238             my $key = 'datetime_format_' . $length;
239              
240             my $sub =
241 4     4   38 sub { my $self = shift;
242              
243 4 50       16 return $self->{$key} if exists $self->{$key};
244              
245 4         11 my $date_meth = 'date_format_' . $length;
246 4         9 my $time_meth = 'time_format_' . $length;
247              
248 4         14 return $self->{$key} = $self->_make_datetime_format( $date_meth, $time_meth );
249             };
250              
251 62     62   513 no strict 'refs';
  62         384  
  62         120896  
252             *{$key} = $sub;
253             }
254              
255             sub datetime_format_default
256             {
257 3     3 0 24 my $self = shift;
258              
259 3         14 my $date_meth = 'date_format_' . $self->default_date_format_length();
260 3         14 my $time_meth = 'time_format_' . $self->default_time_format_length();
261              
262 3         14 return $self->_make_datetime_format( $date_meth, $time_meth );
263             }
264              
265             sub _make_datetime_format
266             {
267 7     7   11 my $self = shift;
268 7         18 my $date_meth = shift;
269 7         15 my $time_meth = shift;
270              
271 7         23 my $dt_format = $self->datetime_format();
272              
273 7         30 my $time = $self->$time_meth();
274 7         66 my $date = $self->$date_meth();
275              
276 7         32 $dt_format =~ s/\{0\}/$time/g;
277 7         25 $dt_format =~ s/\{1\}/$date/g;
278              
279 7         44 return $dt_format;
280             }
281              
282             sub prefers_24_hour_time
283             {
284 3     3 0 17 my $self = shift;
285              
286 3 100       21 return $self->{prefers_24_hour_time}
287             if exists $self->{prefers_24_hour_time};
288              
289 2 100       11 $self->{prefers_24_hour_time} =
290             $self->time_format_short() =~ /h|K/ ? 0 : 1;
291             }
292              
293             sub date_before_time
294             {
295 0     0 0 0 my $self = shift;
296              
297 0         0 my $dt_format = $self->datetime_format();
298              
299 0 0       0 return $dt_format =~ /\{1\}.*\{0\}/ ? 1 : 0;
300             }
301              
302             sub date_parts_order
303             {
304 0     0 0 0 my $self = shift;
305              
306 0         0 my $short = $self->date_format_short();
307              
308 0         0 $short =~ tr{dmyDMY}{}cd;
309 0         0 $short =~ tr{dmyDMY}{dmydmy}s;
310              
311 0         0 return $short;
312             }
313              
314 0     0 0 0 sub full_date_format { $_[0]->_convert_to_strftime( $_[0]->date_format_full() ) }
315 0     0 0 0 sub long_date_format { $_[0]->_convert_to_strftime( $_[0]->date_format_long() ) }
316 0     0 0 0 sub medium_date_format { $_[0]->_convert_to_strftime( $_[0]->date_format_medium() ) }
317 0     0 0 0 sub short_date_format { $_[0]->_convert_to_strftime( $_[0]->date_format_short() ) }
318 0     0 0 0 sub default_date_format { $_[0]->_convert_to_strftime( $_[0]->date_format_default() ) }
319              
320 0     0 0 0 sub full_time_format { $_[0]->_convert_to_strftime( $_[0]->time_format_full() ) }
321 0     0 0 0 sub long_time_format { $_[0]->_convert_to_strftime( $_[0]->time_format_long() ) }
322 0     0 0 0 sub medium_time_format { $_[0]->_convert_to_strftime( $_[0]->time_format_medium() ) }
323 0     0 0 0 sub short_time_format { $_[0]->_convert_to_strftime( $_[0]->time_format_short() ) }
324 0     0 0 0 sub default_time_format { $_[0]->_convert_to_strftime( $_[0]->time_format_default() ) }
325              
326 0     0 0 0 sub full_datetime_format { $_[0]->_convert_to_strftime( $_[0]->datetime_format_full() ) }
327 0     0 0 0 sub long_datetime_format { $_[0]->_convert_to_strftime( $_[0]->datetime_format_long() ) }
328 0     0 0 0 sub medium_datetime_format { $_[0]->_convert_to_strftime( $_[0]->datetime_format_medium() ) }
329 0     0 0 0 sub short_datetime_format { $_[0]->_convert_to_strftime( $_[0]->datetime_format_short() ) }
330 0     0 0 0 sub default_datetime_format { $_[0]->_convert_to_strftime( $_[0]->datetime_format_default() ) }
331              
332             # Older versions of DateTime.pm will not pass in the $cldr_ok flag, so
333             # we will give them the converted-to-strftime pattern (bugs and all).
334             sub _convert_to_strftime
335             {
336 0     0   0 my $self = shift;
337 0         0 my $pattern = shift;
338 0         0 my $cldr_ok = shift;
339              
340 0 0       0 return $pattern if $cldr_ok;
341              
342 0 0       0 return $self->{_converted_patterns}{$pattern}
343             if exists $self->{_converted_patterns}{$pattern};
344              
345 0         0 return $self->{_converted_patterns}{$pattern} = $self->_cldr_to_strftime($pattern);
346             }
347              
348             {
349             my @JavaPatterns =
350             ( qr/G/ => '{era}',
351             qr/yyyy/ => '{ce_year}',
352             qr/y/ => 'y',
353             qr/u/ => 'Y',
354             qr/MMMM/ => 'B',
355             qr/MMM/ => 'b',
356             qr/MM/ => 'm',
357             qr/M/ => '{month}',
358             qr/dd/ => 'd',
359             qr/d/ => '{day}',
360             qr/hh/ => 'l',
361             qr/h/ => '{hour_12}',
362             qr/HH/ => 'H',
363             qr/H/ => '{hour}',
364             qr/mm/ => 'M',
365             qr/m/ => '{minute}',
366             qr/ss/ => 'S',
367             qr/s/ => '{second}',
368             qr/S/ => 'N',
369             qr/EEEE/ => 'A',
370             qr/E/ => 'a',
371             qr/D/ => 'j',
372             qr/F/ => '{weekday_of_month}',
373             qr/w/ => 'V',
374             qr/W/ => '{week_month}',
375             qr/a/ => 'p',
376             qr/k/ => '{hour_1}',
377             qr/K/ => '{hour_12_0}',
378             qr/z/ => '{time_zone_long_name}',
379             );
380              
381             sub _cldr_to_strftime
382             {
383 0     0   0 shift;
384 0         0 my $simple = shift;
385              
386 0         0 $simple =~
387             s/(G+|y+|u+|M+|d+|h+|H+|m+|s+|S+|E+|D+|F+|w+|W+|a+|k+|K+|z+)|'((?:[^']|'')*)'/
388 0 0       0 $2 ? _stringify($2) : $1 ? _convert($1) : "'"/eg;
    0          
389              
390 0         0 return $simple;
391             }
392              
393             sub _convert
394             {
395 0     0   0 my $simple = shift;
396              
397 0         0 for ( my $x = 0; $x < @JavaPatterns; $x += 2 )
398             {
399 0 0       0 return '%' . $JavaPatterns[ $x + 1 ] if $simple =~ /$JavaPatterns[$x]/;
400             }
401              
402 0         0 die "**Dont know $simple***";
403             }
404              
405             sub _stringify
406             {
407 0     0   0 my $string = shift;
408              
409 0         0 $string =~ s/%(?:[^%])/%%/g;
410 0         0 $string =~ s/\'\'/\'/g;
411              
412 0         0 return $string;
413             }
414             }
415              
416             foreach my $field (qw(
417             am_pm_abbreviated
418             date_format_full
419             date_format_long
420             date_format_medium
421             date_format_short
422             datetime_format
423             day_format_abbreviated
424             day_format_narrow
425             day_format_wide
426             day_stand_alone_abbreviated
427             day_stand_alone_narrow
428             day_stand_alone_wide
429             era_abbreviated
430             era_narrow
431             era_wide
432             first_day_of_week
433             month_format_abbreviated
434             month_format_narrow
435             month_format_wide
436             month_stand_alone_abbreviated
437             month_stand_alone_narrow
438             month_stand_alone_wide
439             quarter_format_abbreviated
440             quarter_format_narrow
441             quarter_format_wide
442             quarter_stand_alone_abbreviated
443             quarter_stand_alone_narrow
444             quarter_stand_alone_wide
445             time_format_full
446             time_format_long
447             time_format_medium
448             time_format_short
449             _format_for_Hm
450             _format_for_Hms
451             _format_for_M
452             _format_for_MEd
453             _format_for_MMM
454             _format_for_MMMEd
455             _format_for_MMMMEd
456             _format_for_MMMMd
457             _format_for_MMMd
458             _format_for_MMdd
459             _format_for_Md
460             _format_for_d
461             _format_for_hm
462             _format_for_ms
463             _format_for_y
464             _format_for_yM
465             _format_for_yMEd
466             _format_for_yMMM
467             _format_for_yMMMEd
468             _format_for_yMMMM
469             _format_for_yQ
470             _format_for_yQQQ
471             _format_for_yyMMM
472             _format_for_yyyyMM
473             _format_for_yyyyMMMM
474             )) {
475 62     62   500 no strict 'refs';
  62         152  
  62         55422  
476             *{$field} = sub {
477 31383     31383   3587084 my $v = $_[0]->{$field};
478             # XXX - This SUCKS. I need to fix up update-locale.pl to return
479             # the value from the other aliases method
480 31383 100 66     220368 if (defined $v && $v =~ /^alias:([^:]+)$/) {
481 1117         6676 return $_[0]->$1;
482             }
483 30266         151269 return $v;
484             }
485             }
486              
487 5376     5376 0 35653 sub month_name { $_[0]->month_format_wide()->[ $_[1]->month - 1 ] }
488 5376     5376 0 36885 sub month_abbreviation { $_[0]->month_format_abbreviated()->[ $_[1]->month - 1 ] }
489 3136     3136 0 19389 sub day_name { $_[0]->day_format_wide()->[ $_[1]->day_of_week - 1 ] }
490 3136     3136 0 18647 sub day_abbreviation { $_[0]->day_format_abbreviated->[ $_[1]->day_of_week - 1 ] }
491              
492              
493             sub add_aliases {
494 4     4 0 29 my $self = shift;
495 4 50       18 my $aliases = ref $_[0] ? $_[0] : {@_};
496              
497 4         18 while ( my ( $alias, $id ) = each %$aliases )
498             {
499 4 50       12 die "Can't alias an id to itself"
500             if $alias eq $id;
501              
502             # check for overwrite?
503              
504 4         14 my %seen = ( $alias => 1, $id => 1 );
505 4         6 my $copy = $id;
506 4         13 while ( $copy = $Aliases{$copy} )
507             {
508 4 100       19 die "Creating an alias from $alias to $id would create a loop.\n"
509             if $seen{$copy};
510              
511 3         10 $seen{$copy} = 1;
512             }
513 3         45 $Aliases{$alias} = $id;
514             }
515             }
516              
517             sub remove_alias {
518 1     1 0 2 my ($self, $id) = @_;
519 1         4 delete $CachedLocales{$id};
520 1         5 delete $Aliases{$id};
521             }
522              
523              
524             1;
525              
526             __END__