lib/HTML/CalendarMonth/Locale.pm

   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 use strict;
  12 use warnings;
  13 use Carp;
  14
  15 use DateTime::Locale 0.45;
  16
  17 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   my $class = shift;
  33   my $self = {};
  34   bless $self, $class;
  35   my %parms = @_;
  36   # id is for backwards compatibility
  37   my $code = $parms{code} || $parms{id}
  38     or croak "Locale code required (eg 'en-US')\n";
  39   $self->{full_days}   = defined $parms{full_days}   ? $parms{full_days}   : 0;
  40   $self->{full_months} = defined $parms{full_months} ? $parms{full_months} : 1;
  41   # returned code might be different from given code
  42   unless ($Register{$code}) {
  43     my $dtl = $self->locale->load($code)
  44       or croak "Problem loading locale '$code'";
  45     $Register{$code} = $Register{$dtl->$CODE_METHOD} = { loc => $dtl };
  46   }
  47   $self->{code} = $Register{$code}{loc}->$CODE_METHOD;
  48   $self;
  49 }
  50
  51 sub locale { 'DateTime::Locale' }
  52
  53 sub loc { $Register{shift->code}{loc} }
  54
  55 sub locales { shift->locale->$CODES_METHOD }
  56
  57 sub code { shift->{code} }
  58 *id = *code;
  59
  60 sub full_days   { shift->{full_days}   }
  61 sub full_months { shift->{full_months} }
  62
  63 sub first_day_of_week { shift->loc->first_day_of_week % 7 }
  64
  65 sub days {
  66   my $self = shift;
  67   my $code = $self->code;
  68   unless ($Register{$code}{days}) {
  69     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     my @days  = @{$self->loc->$method};
  75     unshift(@days, pop @days);
  76     $Register{$code}{days} = \@days;
  77   }
  78   wantarray ? @{$Register{$code}{days}} : $Register{$code}{days};
  79 }
  80
  81 sub narrow_days {
  82   my $self = shift;
  83   my $code = $self->code;
  84   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     my @days = @{ $self->loc->day_stand_alone_narrow };
  88     unshift(@days, pop @days);
  89     $Register{$code}{narrow_days} = \@days;
  90   }
  91   wantarray ? @{$Register{$code}{narrow_days}}
  92             :   $Register{$code}{narrow_days};
  93 }
  94
  95 sub months {
  96   my $self = shift;
  97   my $code = $self->code;
  98   unless ($Register{$code}{months}) {
  99     my $method = $self->full_months > 0 ? 'month_stand_alone_wide'
 100                                         : 'month_stand_alone_abbreviated';
 101     $Register{$code}{months} = [@{$self->loc->$method}];
 102   }
 103   wantarray ? @{$Register{$code}{months}} : $Register{$code}{months};
 104 }
 105
 106 sub narrow_months {
 107   my $self = shift;
 108   my $code = $self->code;
 109   $Register{$code}{narrow_months}
 110     ||= [@{$self->loc->month_stand_alone_narrow}];
 111   wantarray ? @{$Register{$code}{narrow_months}}
 112             :   $Register{$code}{narrow_months};
 113 }
 114
 115 sub days_minmatch {
 116   my $self = shift;
 117   $Register{$self->code}{days_mm}
 118     ||= $self->lc_minmatch_hash($self->days);
 119 }
 120 *minmatch = \&days_minmatch;
 121
 122 sub _days_minmatch_pattern {
 123   my $dmm = shift->days_minmatch;
 124   join('|', sort keys %$dmm);
 125 }
 126 *minmatch_pattern = \&_days_minmatch_pattern;
 127
 128 sub months_minmatch {
 129   my $self = shift;
 130   $Register{$self->code}{months_mm}
 131     ||= $self->lc_minmatch_hash($self->months);
 132 }
 133
 134 sub _months_minmatch_pattern {
 135   my $mmm = shift->months_minmatch;
 136   join('|', sort keys %$mmm);
 137 }
 138
 139 sub daynums {
 140   my $self = shift;
 141   my $code = $self->code;
 142   unless ($Register{$code}{daynum}) {
 143     my %daynum;
 144     my $days = $self->days;
 145     $daynum{$days->[$_]} = $_ foreach 0 .. $#$days;
 146     $Register{$code}{daynum} = \%daynum;
 147   }
 148   wantarray ? %{$Register{$code}{daynum}}
 149             :   $Register{$code}{daynum};
 150 }
 151
 152 sub _daymatch {
 153   my($self, $day) = @_;
 154   return unless defined $day;
 155   if ($day =~ /^\d+$/) {
 156     $day %= 7;
 157     return($day, $self->days->[$day]);
 158   }
 159   my $p = $self->_days_minmatch_pattern;
 160   if ($day =~ /^($p)/i) {
 161     $day = $self->days_minmatch->{lc $1};
 162     return($self->daynums->{$day}, $day);
 163   }
 164   return ();
 165 }
 166
 167 sub daynum  { (shift->_daymatch(@_))[0] }
 168 sub dayname { (shift->_daymatch(@_))[1] }
 169
 170 sub monthnums {
 171   my $self = shift;
 172   my $code = $self->code;
 173   unless ($Register{$code}{monthnum}) {
 174     my %monthnum;
 175     my $months = $self->months;
 176     $monthnum{$months->[$_]} = $_ foreach 0 .. $#$months;
 177     $Register{$code}{monthnum} = \%monthnum;
 178   }
 179   wantarray ? %{$Register{$code}{monthnum}}
 180             :   $Register{$code}{monthnum};
 181 }
 182
 183 sub _monthmatch {
 184   my($self, $mon) = @_;
 185   return unless defined $mon;
 186   if ($mon =~ /^\d+$/) {
 187     $mon %= 12;
 188     return($mon, $self->months->[$mon]);
 189   }
 190   my $p = $self->_months_minmatch_pattern;
 191   if ($mon =~ /^($p)/i) {
 192     $mon = $self->months_minmatch->{lc $1};
 193     return($self->monthnums->{$mon}, $mon);
 194   }
 195   return ();
 196 }
 197
 198 sub monthnum  { (shift->_monthmatch(@_))[0] }
 199 sub monthname { (shift->_monthmatch(@_))[1] }
 200
 201 ###
 202
 203 sub locale_map {
 204   my $self = shift;
 205   my %map;
 206   foreach my $code ($self->locales) {
 207     $map{$code} = $self->locale->load($code)->name;
 208   }
 209   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   my $whatever = shift;
 218   my @orig_labels = @_;
 219   my @labels = map { lc $_ } @orig_labels;
 220   my $cc = 1;
 221   my %minmatch;
 222   while (@labels) {
 223     my %scratch;
 224     foreach my $i (0 .. $#labels) {
 225       my $str = $labels[$i];
 226       my $chrs = substr($str, 0, $cc);
 227       $scratch{$chrs} ||= [];
 228       push(@{$scratch{$chrs}}, $i);
 229     }
 230     my @keep_i;
 231     foreach (keys %scratch) {
 232       if (@{$scratch{$_}} == 1) {
 233         $minmatch{$_} = $orig_labels[$scratch{$_}[0]];
 234       }
 235       else {
 236         push(@keep_i, @{$scratch{$_}});
 237       }
 238     }
 239     @labels      = @labels[@keep_i];
 240     @orig_labels = @orig_labels[@keep_i];
 241     ++$cc;
 242   }
 243   \%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   my $whatever = shift;
 250   my @labels = @_;
 251   my $cc = 1;
 252   my %minmatch;
 253   while (@labels) {
 254     my %scratch;
 255     foreach my $i (0 .. $#labels) {
 256       my $str = $labels[$i];
 257       my $chrs = substr($str, 0, $cc);
 258       $scratch{$chrs} ||= [];
 259       push(@{$scratch{$chrs}}, $i);
 260     }
 261     my @keep_i;
 262     foreach (keys %scratch) {
 263       if (@{$scratch{$_}} == 1) {
 264         $minmatch{$_} = $labels[$scratch{$_}[0]];
 265       }
 266       else {
 267         push(@keep_i, @{$scratch{$_}});
 268       }
 269     }
 270     @labels = @labels[@keep_i];
 271     ++$cc;
 272   }
 273   \%minmatch;
 274 }
 275
 276 1;
 277
 278 __END__
 279
 280 =head1 NAME
 281
 282 HTML::CalendarMonth::Locale - Front end class for DateTime::Locale
 283
 284 =head1 SYNOPSIS
 285
 286   use HTML::CalendarMonth::Locale;
 287
 288   my $loc = HTML::CalendarMonth::Locale->new( code => 'en-US' );
 289
 290   # list of days of the week for locale
 291   my @days = $loc->days;
 292
 293   # list of months of the year for locale
 294   my @months = $loc->months;
 295
 296   # the name of the current locale, as supplied the code parameter to
 297   # new()
 298   my $locale_name = $loc->code;
 299
 300   # the actual DateTime::Locale object
 301   my $loc = $loc->loc;
 302
 303   1;
 304
 305 =head1 DESCRIPTION
 306
 307 HTML::CalendarMonth utilizes the powerful locale capabilities of
 308 DateTime::Locale for rendering its calendars. The default locale is
 309 'en-US' but many others are available. To see this list, invoke the
 310 class method HTML::CalendarMonth::Locale->locales() which in turn
 311 invokes DateTime::Locale::codes().
 312
 313 This module is mostly intended for internal usage within
 314 HTML::CalendarMonth, but some of its functionality may be of use for
 315 developers:
 316
 317 =head1 METHODS
 318
 319 =over
 320
 321 =item new()
 322
 323 Constructor. Takes the following parameters:
 324
 325 =over
 326
 327 =item code
 328
 329 Locale code, e.g. 'en-US'.
 330
 331 =item full_days
 332
 333 Specifies whether full day names or their abbreviations are desired.
 334 Default 0, use abbreviated days.
 335
 336 =item full_months
 337
 338 Specifies whether full month names or their abbreviations are desired.
 339 Default 1, use full months.
 340
 341 =back
 342
 343 =item code()
 344
 345 Returns the locale code used during object construction.
 346
 347 =item locale()
 348
 349 Accessor method for the DateTime::Locale class, which in turn offers
 350 several class methods of specific interest. See L<DateTime::Locale>.
 351
 352 =item locale_map()
 353
 354 Returns a hash of all available locales, mapping their code to their
 355 full name.
 356
 357 =item loc()
 358
 359 Accessor method for the DateTime::Locale instance as specified by C<code>.
 360 See L<DateTime::Locale>.
 361
 362 =item locales()
 363
 364 Lists all available locale codes. Equivalent to locale()->codes(), or
 365 DateTime::Locale->codes().
 366
 367 =item days()
 368
 369 Returns a list of days of the week, Sunday first. These are the actual
 370 unique day strings used for rendering calendars, so depending on which
 371 attributes were provided to C<new()>, this list will either be
 372 abbreviations or full names. The default uses abbreviated day names.
 373 Returns a list in list context or an array ref in scalar context.
 374
 375 =item narrow_days()
 376
 377 Returns a list of short day abbreviations, beginning with Sunday. The
 378 narrow abbreviations are not guaranteed to be unique (i.e. 'S' for both
 379 Sat and Sun).
 380
 381 =item days_minmatch()
 382
 383 Provides a hash reference containing minimal case-insensitive match
 384 strings for each day of the week, e.g., 'sa' for Saturday, 'm' for
 385 Monday, etc.
 386
 387 =item months()
 388
 389 Returns a list of months of the year, beginning with January. Depending
 390 on which attributes were provided to C<new()>, this list will either be
 391 full names or abbreviations. The default uses full names. Returns a list
 392 in list context or an array ref in scalar context.
 393
 394 =item narrow_months()
 395
 396 Returns a list of short month abbreviations, beginning with January. The
 397 narrow abbreviations are not guaranteed to be unique.
 398
 399 =item months_minmatch()
 400
 401 Provides a hash reference containing minimal case-insensitive match
 402 strings for each month of the year, e.g., 'n' for November, 'ja' for
 403 January, 'jul' for July, 'jun' for June, etc.
 404
 405 =item daynums()
 406
 407 Provides a hash reference containing day of week indices for each fully
 408 qualified day name as returned by days().
 409
 410 =item daynum($day)
 411
 412 Provides the day of week index for a particular day name.
 413
 414 =item dayname($day)
 415
 416 Provides the fully qualified day name for a given string or day index.
 417
 418 =item monthnums()
 419
 420 Provides a hash reference containing month of year indices for each
 421 fully qualified month name as returned by months().
 422
 423 =item monthnum($month)
 424
 425 Provides the month of year index for a particular month name.
 426
 427 =item monthname($month)
 428
 429 Provides the month name for a given string or month index.
 430
 431 =item minmatch_hash(@list)
 432
 433 This is the method used to generate the case-insensitive minimal match
 434 hash referenced above. Given an arbitrary list, a hash reference will
 435 be returned with minimal match strings as keys and the original strings
 436 as values.
 437
 438 =item lc_minmatch_hash(@list)
 439
 440 Same as minmatch_hash, except keys are forced to lower case.
 441
 442 =item first_day_of_week()
 443
 444 Returns a number from 0 to 6 representing the first day of the week for
 445 this locale, where 0 represents Sunday.
 446
 447 =back
 448
 449 =head1 AUTHOR
 450
 451 Matthew P. Sisk, E<lt>F<sisk@mojotoad.com>E<gt>
 452
 453 =head1 COPYRIGHT
 454
 455 Copyright (c) 2010-2015 Matthew P. Sisk. All rights reserved. All wrongs
 456 revenged. This program is free software; you can redistribute it and/or
 457 modify it under the same terms as Perl itself.
 458
 459 =head1 SEE ALSO
 460
 461 HTML::CalendarMonth(3), DateTime::Locale(3)
 462
 463 =for Pod::Coverage minmatch minmatch_pattern id