lib/HTML/CalendarMonth/Locale.pm

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