File Coverage

blib/lib/HTML/CalendarMonth/Locale.pm
Criterion Covered Total %
statement 110 170 64.7
branch 29 54 53.7
condition 5 15 33.3
subroutine 24 33 72.7
pod 23 23 100.0
total 191 295 64.7


line stmt bran cond sub pod time code
1             package HTML::CalendarMonth::Locale;
2             {
3             $HTML::CalendarMonth::Locale::VERSION = '2.00';
4             }
5              
6             # Front end class around DateTime::Locale. In addition to providing
7             # access to the DT::Locale class and locale-specific instance, this
8             # class prepares some other hashes and lookups utilized by
9             # HTML::CalendarMonth.
10              
11 10     10   52 use strict;
  10         18  
  10         252  
12 10     10   52 use warnings;
  10         15  
  10         306  
13 10     10   48 use Carp;
  10         15  
  10         597  
14              
15 10     10   7294 use DateTime::Locale 0.45;
  10         614731  
  10         19714  
16              
17 19     19   209977 sub _locale_version { $DateTime::Locale::VERSION }
18              
19             my($CODE_METHOD, $CODES_METHOD);
20             if (_locale_version() > 0.92) {
21             $CODE_METHOD = "code";
22             $CODES_METHOD = "codes";
23             }
24             else {
25             $CODE_METHOD = "id";
26             $CODES_METHOD = "ids";
27             }
28              
29             my %Register;
30              
31             sub new {
32 309     309 1 501 my $class = shift;
33 309         588 my $self = {};
34 309         635 bless $self, $class;
35 309         1399 my %parms = @_;
36             # id is for backwards compatibility
37             my $code = $parms{code} || $parms{id}
38 309 50 33     1649 or croak "Locale code required (eg 'en-US')\n";
39 309 50       1265 $self->{full_days} = defined $parms{full_days} ? $parms{full_days} : 0;
40 309 50       989 $self->{full_months} = defined $parms{full_months} ? $parms{full_months} : 1;
41             # returned code might be different from given code
42 309 100       910 unless ($Register{$code}) {
43 10 50       39 my $dtl = $self->locale->load($code)
44             or croak "Problem loading locale '$code'";
45 10         5394 $Register{$code} = $Register{$dtl->$CODE_METHOD} = { loc => $dtl };
46             }
47 309         2118 $self->{code} = $Register{$code}{loc}->$CODE_METHOD;
48 309         2707 $self;
49             }
50              
51 11     11 1 83 sub locale { 'DateTime::Locale' }
52              
53 35     35 1 92 sub loc { $Register{shift->code}{loc} }
54              
55 1     1 1 17 sub locales { shift->locale->$CODES_METHOD }
56              
57 2834     2834 1 9263 sub code { shift->{code} }
58             *id = *code;
59              
60 10     10 1 35 sub full_days { shift->{full_days} }
61 10     10 1 38 sub full_months { shift->{full_months} }
62              
63 7     7 1 21 sub first_day_of_week { shift->loc->first_day_of_week % 7 }
64              
65             sub days {
66 624     624 1 1030 my $self = shift;
67 624         1611 my $code = $self->code;
68 624 100       2177 unless ($Register{$code}{days}) {
69 10 100       112 my $method = $self->full_days ? 'day_stand_alone_wide'
70             : 'day_stand_alone_abbreviated';
71             # adjust to H::CM standard expectation, 1st day Sun
72             # Sunday is first, regardless of what the calendar considers to be
73             # the first day of the week
74 10         16 my @days = @{$self->loc->$method};
  10         34  
75 10         225 unshift(@days, pop @days);
76 10         38 $Register{$code}{days} = \@days;
77             }
78 624 100       2062 wantarray ? @{$Register{$code}{days}} : $Register{$code}{days};
  317         2131  
79             }
80              
81             sub narrow_days {
82 6     6 1 13 my $self = shift;
83 6         11 my $code = $self->code;
84 6 100       20 unless ($Register{$code}{narrow_days}) {
85             # Sunday is first, regardless of what the calendar considers to be
86             # the first day of the week
87 1         2 my @days = @{ $self->loc->day_stand_alone_narrow };
  1         3  
88 1         7 unshift(@days, pop @days);
89 1         8 $Register{$code}{narrow_days} = \@days;
90             }
91 6         30 wantarray ? @{$Register{$code}{narrow_days}}
92 6 50       14 : $Register{$code}{narrow_days};
93             }
94              
95             sub months {
96 327     327 1 442 my $self = shift;
97 327         863 my $code = $self->code;
98 327 100       1204 unless ($Register{$code}{months}) {
99 10 50       34 my $method = $self->full_months > 0 ? 'month_stand_alone_wide'
100             : 'month_stand_alone_abbreviated';
101 10         16 $Register{$code}{months} = [@{$self->loc->$method}];
  10         37  
102             }
103 327 100       2242 wantarray ? @{$Register{$code}{months}} : $Register{$code}{months};
  10         69  
104             }
105              
106             sub narrow_months {
107 0     0 1 0 my $self = shift;
108 0         0 my $code = $self->code;
109             $Register{$code}{narrow_months}
110 0   0     0 ||= [@{$self->loc->month_stand_alone_narrow}];
  0         0  
111 0         0 wantarray ? @{$Register{$code}{narrow_months}}
112 0 0       0 : $Register{$code}{narrow_months};
113             }
114              
115             sub days_minmatch {
116 0     0 1 0 my $self = shift;
117             $Register{$self->code}{days_mm}
118 0   0     0 ||= $self->lc_minmatch_hash($self->days);
119             }
120             *minmatch = \&days_minmatch;
121              
122             sub _days_minmatch_pattern {
123 0     0   0 my $dmm = shift->days_minmatch;
124 0         0 join('|', sort keys %$dmm);
125             }
126             *minmatch_pattern = \&_days_minmatch_pattern;
127              
128             sub months_minmatch {
129 1228     1228 1 1538 my $self = shift;
130             $Register{$self->code}{months_mm}
131 1228   66     2348 ||= $self->lc_minmatch_hash($self->months);
132             }
133              
134             sub _months_minmatch_pattern {
135 614     614   1390 my $mmm = shift->months_minmatch;
136 614         5790 join('|', sort keys %$mmm);
137             }
138              
139             sub daynums {
140 0     0 1 0 my $self = shift;
141 0         0 my $code = $self->code;
142 0 0       0 unless ($Register{$code}{daynum}) {
143 0         0 my %daynum;
144 0         0 my $days = $self->days;
145 0         0 $daynum{$days->[$_]} = $_ foreach 0 .. $#$days;
146 0         0 $Register{$code}{daynum} = \%daynum;
147             }
148 0         0 wantarray ? %{$Register{$code}{daynum}}
149 0 0       0 : $Register{$code}{daynum};
150             }
151              
152             sub _daymatch {
153 0     0   0 my($self, $day) = @_;
154 0 0       0 return unless defined $day;
155 0 0       0 if ($day =~ /^\d+$/) {
156 0         0 $day %= 7;
157 0         0 return($day, $self->days->[$day]);
158             }
159 0         0 my $p = $self->_days_minmatch_pattern;
160 0 0       0 if ($day =~ /^($p)/i) {
161 0         0 $day = $self->days_minmatch->{lc $1};
162 0         0 return($self->daynums->{$day}, $day);
163             }
164 0         0 return ();
165             }
166              
167 0     0 1 0 sub daynum { (shift->_daymatch(@_))[0] }
168 0     0 1 0 sub dayname { (shift->_daymatch(@_))[1] }
169              
170             sub monthnums {
171 614     614 1 893 my $self = shift;
172 614         1164 my $code = $self->code;
173 614 100       1759 unless ($Register{$code}{monthnum}) {
174 10         16 my %monthnum;
175 10         29 my $months = $self->months;
176 10         167 $monthnum{$months->[$_]} = $_ foreach 0 .. $#$months;
177 10         34 $Register{$code}{monthnum} = \%monthnum;
178             }
179 0         0 wantarray ? %{$Register{$code}{monthnum}}
180 614 50       3595 : $Register{$code}{monthnum};
181             }
182              
183             sub _monthmatch {
184 921     921   1586 my($self, $mon) = @_;
185 921 50       2156 return unless defined $mon;
186 921 100       2758 if ($mon =~ /^\d+$/) {
187 307         440 $mon %= 12;
188 307         1056 return($mon, $self->months->[$mon]);
189             }
190 614         1474 my $p = $self->_months_minmatch_pattern;
191 614 50   1   5542 if ($mon =~ /^($p)/i) {
  1         898  
  1         10  
  1         13  
192 614         31874 $mon = $self->months_minmatch->{lc $1};
193 614         1657 return($self->monthnums->{$mon}, $mon);
194             }
195 0         0 return ();
196             }
197              
198 614     614 1 1452 sub monthnum { (shift->_monthmatch(@_))[0] }
199 307     307 1 1037 sub monthname { (shift->_monthmatch(@_))[1] }
200              
201             ###
202              
203             sub locale_map {
204 0     0 1 0 my $self = shift;
205 0         0 my %map;
206 0         0 foreach my $code ($self->locales) {
207 0         0 $map{$code} = $self->locale->load($code)->name;
208             }
209 0 0       0 wantarray ? %map : \%map;
210             }
211              
212             ###
213              
214             sub lc_minmatch_hash {
215             # given a list, provide a reverse lookup of case-insensitive minimal
216             # values for each label in the list
217 10     10 1 16 my $whatever = shift;
218 10         32 my @orig_labels = @_;
219 10         22 my @labels = map { lc $_ } @orig_labels;
  120         6251  
220 10         23 my $cc = 1;
221 10         15 my %minmatch;
222 10         33 while (@labels) {
223 31         40 my %scratch;
224 31         71 foreach my $i (0 .. $#labels) {
225 218         291 my $str = $labels[$i];
226 218         347 my $chrs = substr($str, 0, $cc);
227 218   100     811 $scratch{$chrs} ||= [];
228 218         250 push(@{$scratch{$chrs}}, $i);
  218         632  
229             }
230 31         50 my @keep_i;
231 31         97 foreach (keys %scratch) {
232 165 100       177 if (@{$scratch{$_}} == 1) {
  165         349  
233 120         294 $minmatch{$_} = $orig_labels[$scratch{$_}[0]];
234             }
235             else {
236 45         55 push(@keep_i, @{$scratch{$_}});
  45         128  
237             }
238             }
239 31         126 @labels = @labels[@keep_i];
240 31         86 @orig_labels = @orig_labels[@keep_i];
241 31         153 ++$cc;
242             }
243 10         46 \%minmatch;
244             }
245              
246             sub minmatch_hash {
247             # given a list, provide a reverse lookup of minimal values for each
248             # label in the list
249 0     0 1 0 my $whatever = shift;
250 0         0 my @labels = @_;
251 0         0 my $cc = 1;
252 0         0 my %minmatch;
253 0         0 while (@labels) {
254 0         0 my %scratch;
255 0         0 foreach my $i (0 .. $#labels) {
256 0         0 my $str = $labels[$i];
257 0         0 my $chrs = substr($str, 0, $cc);
258 0   0     0 $scratch{$chrs} ||= [];
259 0         0 push(@{$scratch{$chrs}}, $i);
  0         0  
260             }
261 0         0 my @keep_i;
262 0         0 foreach (keys %scratch) {
263 0 0       0 if (@{$scratch{$_}} == 1) {
  0         0  
264 0         0 $minmatch{$_} = $labels[$scratch{$_}[0]];
265             }
266             else {
267 0         0 push(@keep_i, @{$scratch{$_}});
  0         0  
268             }
269             }
270 0         0 @labels = @labels[@keep_i];
271 0         0 ++$cc;
272             }
273 0         0 \%minmatch;
274             }
275              
276             1;
277              
278             __END__