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

package HTML::CalendarMonth::Locale;
{
  $HTML::CalendarMonth::Locale::VERSION = '2.00';
}

# Front end class around DateTime::Locale. In addition to providing
# access to the DT::Locale class and locale-specific instance, this
# class prepares some other hashes and lookups utilized by
# HTML::CalendarMonth.

use strict;
use warnings;
use Carp;

use DateTime::Locale 0.45;

sub _locale_version { $DateTime::Locale::VERSION }

my($CODE_METHOD, $CODES_METHOD);
if (_locale_version() > 0.92) {
  $CODE_METHOD  = "code";
  $CODES_METHOD = "codes";
}
else {
  $CODE_METHOD  = "id";
  $CODES_METHOD = "ids";
}

my %Register;

sub new {
  my $class = shift;
  my $self = {};
  bless $self, $class;
  my %parms = @_;
  # id is for backwards compatibility
  my $code = $parms{code} || $parms{id}
    or croak "Locale code required (eg 'en-US')\n";
  $self->{full_days}   = defined $parms{full_days}   ? $parms{full_days}   : 0;
  $self->{full_months} = defined $parms{full_months} ? $parms{full_months} : 1;
  # returned code might be different from given code
  unless ($Register{$code}) {
    my $dtl = $self->locale->load($code)
      or croak "Problem loading locale '$code'";
    $Register{$code} = $Register{$dtl->$CODE_METHOD} = { loc => $dtl };
  }
  $self->{code} = $Register{$code}{loc}->$CODE_METHOD;
  $self;
}

sub locale { 'DateTime::Locale' }

sub loc { $Register{shift->code}{loc} }

sub locales { shift->locale->$CODES_METHOD }

sub code { shift->{code} }
*id = *code;

sub full_days   { shift->{full_days}   }
sub full_months { shift->{full_months} }

sub first_day_of_week { shift->loc->first_day_of_week % 7 }

sub days {
  my $self = shift;
  my $code = $self->code;
  unless ($Register{$code}{days}) {
    my $method = $self->full_days ? 'day_stand_alone_wide'
                                  : 'day_stand_alone_abbreviated';
    # adjust to H::CM standard expectation, 1st day Sun
    # Sunday is first, regardless of what the calendar considers to be
    # the first day of the week
    my @days  = @{$self->loc->$method};
    unshift(@days, pop @days);
    $Register{$code}{days} = \@days;
  }
  wantarray ? @{$Register{$code}{days}} : $Register{$code}{days};
}

sub narrow_days {
  my $self = shift;
  my $code = $self->code;
  unless ($Register{$code}{narrow_days}) {
    # Sunday is first, regardless of what the calendar considers to be
    # the first day of the week
    my @days = @{ $self->loc->day_stand_alone_narrow };
    unshift(@days, pop @days);
    $Register{$code}{narrow_days} = \@days;
  }
  wantarray ? @{$Register{$code}{narrow_days}}
            :   $Register{$code}{narrow_days};
}

sub months {
  my $self = shift;
  my $code = $self->code;
  unless ($Register{$code}{months}) {
    my $method = $self->full_months > 0 ? 'month_stand_alone_wide'
                                        : 'month_stand_alone_abbreviated';
    $Register{$code}{months} = [@{$self->loc->$method}];
  }
  wantarray ? @{$Register{$code}{months}} : $Register{$code}{months};
}

sub narrow_months {
  my $self = shift;
  my $code = $self->code;
  $Register{$code}{narrow_months}
    ||= [@{$self->loc->month_stand_alone_narrow}];
  wantarray ? @{$Register{$code}{narrow_months}}
            :   $Register{$code}{narrow_months};
}

sub days_minmatch {
  my $self = shift;
  $Register{$self->code}{days_mm}
    ||= $self->lc_minmatch_hash($self->days);
}
*minmatch = \&days_minmatch;

sub _days_minmatch_pattern {
  my $dmm = shift->days_minmatch;
  join('|', sort keys %$dmm);
}
*minmatch_pattern = \&_days_minmatch_pattern;

sub months_minmatch {
  my $self = shift;
  $Register{$self->code}{months_mm}
    ||= $self->lc_minmatch_hash($self->months);
}

sub _months_minmatch_pattern {
  my $mmm = shift->months_minmatch;
  join('|', sort keys %$mmm);
}

sub daynums {
  my $self = shift;
  my $code = $self->code;
  unless ($Register{$code}{daynum}) {
    my %daynum;
    my $days = $self->days;
    $daynum{$days->[$_]} = $_ foreach 0 .. $#$days;
    $Register{$code}{daynum} = \%daynum;
  }
  wantarray ? %{$Register{$code}{daynum}}
            :   $Register{$code}{daynum};
}

sub _daymatch {
  my($self, $day) = @_;
  return unless defined $day;
  if ($day =~ /^\d+$/) {
    $day %= 7;
    return($day, $self->days->[$day]);
  }
  my $p = $self->_days_minmatch_pattern;
  if ($day =~ /^($p)/i) {
    $day = $self->days_minmatch->{lc $1};
    return($self->daynums->{$day}, $day);
  }
  return ();
}

sub daynum  { (shift->_daymatch(@_))[0] }
sub dayname { (shift->_daymatch(@_))[1] }

sub monthnums {
  my $self = shift;
  my $code = $self->code;
  unless ($Register{$code}{monthnum}) {
    my %monthnum;
    my $months = $self->months;
    $monthnum{$months->[$_]} = $_ foreach 0 .. $#$months;
    $Register{$code}{monthnum} = \%monthnum;
  }
  wantarray ? %{$Register{$code}{monthnum}}
            :   $Register{$code}{monthnum};
}

sub _monthmatch {
  my($self, $mon) = @_;
  return unless defined $mon;
  if ($mon =~ /^\d+$/) {
    $mon %= 12;
    return($mon, $self->months->[$mon]);
  }
  my $p = $self->_months_minmatch_pattern;
  if ($mon =~ /^($p)/i) {
    $mon = $self->months_minmatch->{lc $1};
    return($self->monthnums->{$mon}, $mon);
  }
  return ();
}

sub monthnum  { (shift->_monthmatch(@_))[0] }
sub monthname { (shift->_monthmatch(@_))[1] }

###

sub locale_map {
  my $self = shift;
  my %map;
  foreach my $code ($self->locales) {
    $map{$code} = $self->locale->load($code)->name;
  }
  wantarray ? %map : \%map;
}

###

sub lc_minmatch_hash {
  # given a list, provide a reverse lookup of case-insensitive minimal
  # values for each label in the list
  my $whatever = shift;
  my @orig_labels = @_;
  my @labels = map { lc $_ } @orig_labels;
  my $cc = 1;
  my %minmatch;
  while (@labels) {
    my %scratch;
    foreach my $i (0 .. $#labels) {
      my $str = $labels[$i];
      my $chrs = substr($str, 0, $cc);
      $scratch{$chrs} ||= [];
      push(@{$scratch{$chrs}}, $i);
    }
    my @keep_i;
    foreach (keys %scratch) {
      if (@{$scratch{$_}} == 1) {
        $minmatch{$_} = $orig_labels[$scratch{$_}[0]];
      }
      else {
        push(@keep_i, @{$scratch{$_}});
      }
    }
    @labels      = @labels[@keep_i];
    @orig_labels = @orig_labels[@keep_i];
    ++$cc;
  }
  \%minmatch;
}

sub minmatch_hash {
  # given a list, provide a reverse lookup of minimal values for each
  # label in the list
  my $whatever = shift;
  my @labels = @_;
  my $cc = 1;
  my %minmatch;
  while (@labels) {
    my %scratch;
    foreach my $i (0 .. $#labels) {
      my $str = $labels[$i];
      my $chrs = substr($str, 0, $cc);
      $scratch{$chrs} ||= [];
      push(@{$scratch{$chrs}}, $i);
    }
    my @keep_i;
    foreach (keys %scratch) {
      if (@{$scratch{$_}} == 1) {
        $minmatch{$_} = $labels[$scratch{$_}[0]];
      }
      else {
        push(@keep_i, @{$scratch{$_}});
      }
    }
    @labels = @labels[@keep_i];
    ++$cc;
  }
  \%minmatch;
}

1;

__END__