libhtml-calendarmonth-perl 1.26-1 / usr / share / perl5 / HTML / CalendarMonth / DateTool.pm

package HTML::CalendarMonth::DateTool;
{
  $HTML::CalendarMonth::DateTool::VERSION = '1.26';
}

# Base class for determining what date calculation package to use.

use strict;
use warnings;
use Carp;

use File::Which qw( which );

my %Toolmap = (
  'Time::Local' => 'TimeLocal',
  'Date::Calc'  => 'DateCalc',
  'DateTime'    => 'DateTime',
  'Date::Manip' => 'DateManip',
  'ncal'        => 'Ncal',
  'cal'         => 'Cal',
);

my %Classmap;
$Classmap{lc $Toolmap{$_}} = $_ foreach keys %Toolmap;

my($Cal_Cmd, $Ncal_Cmd);

sub _toolmap {
  shift;
  my $str = shift;
  my $tool = $Toolmap{$str};
  unless ($tool) {
    foreach (values %Toolmap) {
      if ($str =~ /^$_$/i) {
        $tool = $_;
        last;
      }
    }
  }
  return unless $tool;
  join('::', __PACKAGE__, $tool);
}

sub new {
  my $class = shift;
  my $self = {};
  bless $self, $class;
  my %parms = @_;
  $self->{year}     = $parms{year};
  $self->{month}    = $parms{month};
  $self->{weeknum}  = $parms{weeknum};
  $self->{historic} = $parms{historic};
  if (! $self->{year}) {
    my @dmy = $self->_dmy_now;
    $self->{year}    = $dmy[2];
    $self->{month} ||= $dmy[1];
  }
  $self->{month} ||= 1;
  if ($parms{datetool}) {
    $self->{datetool} = $self->_toolmap($parms{datetool})
      or croak "Sorry, didn't find a tool for datetool '$parms{datetool}'\n";
  }
  my $dc = $self->_summon_date_class;
  unless (eval "require $dc") {
    croak "Problem loading $dc ($@)\n";
  }
  # rebless into new class
  bless $self, $dc;
}

sub year     { shift->{year}     }
sub month    { shift->{month}    }
sub weeknum  { shift->{weeknum}  }
sub historic { shift->{historic} }
sub datetool { shift->{datetool} }

sub _name {
  my $class = shift;
  $class = ref $class || $class;
  lc((split(/::/, $class))[-1]);
}

sub _cal_cmd {
  my $self = shift;
  if (! defined $Cal_Cmd) {
    $Cal_Cmd = which('cal') || '';
    if ($Cal_Cmd) {
      my @out = grep { ! /^\s*$/ } `$Cal_Cmd 9 1752`;
      #   September 1752
      #Su Mo Tu We Th Fr Sa
      #       1  2 14 15 16
      #17 18 19 20 21 22 23
      #24 25 26 27 28 29 30
      my @pat = (
        qr/^\s*\S+\s+\d+$/,
        qr/^\s*\S+\s+\S+\s+\S+\s+\S+\s+\S+\s+\S+\s+\S+\s*$/,
        qr/^\s*\d+\s+\d+\s+\d+\s+\d+\s+\d+\s*$/,
        qr/^\s*\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s*$/,
        qr/^\s*\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s*$/,
      );
      if (@out == @pat) {
        for my $i (0 .. $#out) {
          if ($out[$i] !~ $pat[$i]) {
            $Cal_Cmd = '';
            last;
          }
        }
      }
      else {
        $Cal_Cmd = '';
      }
    }
  }
  $Cal_Cmd;
}

sub _ncal_cmd {
  my $self = shift;
  if (! defined $Ncal_Cmd) {
    $Ncal_Cmd = which('ncal') || '';
    if ($Ncal_Cmd) {
      my @out = grep { ! /^\s*$/ } map { s/^\s*//; $_ } `$Ncal_Cmd 9 1752`;
      #    September 1752
      #Mo    18 25
      #Tu  1 19 26
      #We  2 20 27
      #Th 14 21 28
      #Fr 15 22 29
      #Sa 16 23 30
      #Su 17 24
      my @pat = (
        qr/^\s*\S+\s+\d+$/,
        qr/^\s*\S+\s+\d+\s+\d+\s*$/,
        qr/^\s*\S+\s+\d+\s+\d+\s+\d+\s*$/,
        qr/^\s*\S+\s+\d+\s+\d+\s+\d+\s*$/,
        qr/^\s*\S+\s+\d+\s+\d+\s+\d+\s*$/,
        qr/^\s*\S+\s+\d+\s+\d+\s+\d+\s*$/,
        qr/^\s*\S+\s+\d+\s+\d+\s+\d+\s*$/,
        qr/^\s*\S+\s+\d+\s+\d+\s*$/,
      );
      if (@out == @pat) {
        for my $i (0 .. $#out) {
          if ($out[$i] !~ $pat[$i]) {
            $Ncal_Cmd = '';
            last;
          }
        }
      }
      else {
        $Ncal_Cmd = '';
      }
    }
  }
  $Ncal_Cmd;
}

sub day_epoch {
  # in case our subclasses are lazy
  my($self, $day, $month, $year) = @_;
  $month ||= $self->month;
  $year  ||= $self->year;
  Time::Local::timegm(0,0,0,1,$month,$year);
}

sub _skips {
  my $self = shift;
  @_ ? $self->{skips} = shift : $self->{skips};
}

sub dow1st  { (shift->dow1st_and_lastday)[0] }

sub lastday { (shift->dow1st_and_lastday)[1] }

sub _dmy_now {
  my $self = shift;
  my $ts = @_ ? shift : time;
  my($d, $m, $y) = (localtime($ts))[3,4,5];
  ++$m; $y += 1900;
  ($d, $m, $y);
}

sub _dom_now {
  my $self = shift;
  my $ts = @_ ? shift : time;
  my($d, $m, $y);
  if ($ts =~ /^\d+$/) {
    if (length $ts <= 2) {
      ($d, $m, $y) = ($ts, $self->month, $self->year);
      croak "invalid day of month (1 .. " . $self->lastday . ") '$ts'"
        unless $ts >= 1 && $ts <= $self->lastday;
    }
    else {
      ($d, $m, $y) = $self->_dmy_now($ts);
    }
  }
  else {
    ($y, $m, $d) = $ts =~ m{^(\d+)/(\d\d)/(\d\d)$};
    croak "invalid yyyy/mm/dd date string '$ts'" unless defined $d;
  }
  my($cy, $cm) = ($self->year, $self->month);
  my $first = sprintf("%04d/%02d/%02d", $cy, $cm, 1);
  my $last  = sprintf("%04d/%02d/%02d", $cy, $cm, $self->lastday);
  my $pivot = sprintf("%04d/%02d/%02d", $y, $m, $d);
  return -1 if $pivot gt $last;
  return  0 if $pivot lt $first;
  $d;
}

sub _summon_date_class {
  my $self = shift;
  my @tools;
  if (my $c = $self->datetool) {
    eval "use $c";
    die "invalid date tool $c : $@" if $@;
    @tools = $c->_name;
  }
  else {
    @tools = qw( timelocal datecalc datetime datemanip ncal cal );
  }
  my($dc, @fails);
  for my $tool (@tools) {
    my $method = join('_', '', lc($tool), 'fails');
    if (my $f = $self->$method) {
      push(@fails, [$tool, $f]);
    }
    else {
      $dc = $self->_toolmap($tool);
      last;
    }
  }
  return $dc if $dc;
  if (@tools == 1) {
    croak "invalid date tool " . join(': ', @{$fails[0]});
  }
  else {
    croak join("\n",
      "no valid date tool found:",
      map(sprintf("%11s: %s", @$_), @fails),
      "\n"
    );
  }
}

sub _dump_tests {
  my $self = shift;
  print "Time::Local : ", $self->_timelocal_fails || 1, "\n";
  print " Date::Calc : ", $self->_datecalc_fails  || 1, "\n";
  print "   DateTime : ", $self->_datetime_fails  || 1, "\n";
  print "Date::Manip : ", $self->_datemanip_fails || 1, "\n";
  print "       ncal : ", $self->_ncal_fails      || 1, "\n";
  print "        cal : ", $self->_cal_fails       || 1, "\n";
}

sub _is_julian {
  my $self = shift;
  my $y = $self->year;
  $y < 1752 || ($y == 1752 && $self->month <= 9);
}

sub _timelocal_fails {
  my $self = shift;
  return "not installed" unless $self->_timelocal_present;
  return "week-of-year numbering unsupported" if $self->weeknum;
  my $y = $self->year;
  return "only years between 1970 and 2038 supported"
    if $y < 1970 || $y >= 2038;
  return;
}

sub _ncal_fails {
  my $self = shift;
  return "command not found" unless $self->_ncal_present;
  return "week-of-year numbering not supported prior to 1752/09"
    if $self->weeknum && $self->_is_julian;
  return;
}

sub _cal_fails  {
  my $self = shift;
  return "command not found" unless $self->_cal_present;
  return "week-of-year numbering not supported" if $self->weeknum;
  return;
}

sub _datecalc_fails {
  my $self = shift;
  return "not installed" unless $self->_datecalc_present;
  return "historic mode prior to 1752/09 not supported"
    if $self->historic && $self->_is_julian;
  return;
}

sub _datetime_fails {
  my $self = shift;
  return "not installed" unless $self->_datetime_present;
  return "historic mode prior to 1752/09 not supported"
    if $self->historic && $self->_is_julian;
  return;
}

sub _datemanip_fails {
  my $self = shift;
  return "not installed" unless $self->_datemanip_present;
  return "historic mode prior to 1752/09 not supported"
    if $self->historic && $self->_is_julian;
  eval { require Date::Manip && Date::Manip::Date_Init() };
  return "init failure: $@" if $@;
  return;
}

sub _timelocal_present { eval "require Time::Local"; return !$@ }
sub _datecalc_present  { eval "require Date::Calc";  return !$@ }
sub _datetime_present  { eval "require DateTime";    return !$@ }
sub _datemanip_present { eval "require Date::Manip"; return !$@ }
sub _ncal_present      { shift->_ncal_cmd }
sub _cal_present       { shift->_cal_cmd  };


1;

__END__

=head1 NAME

HTML::CalendarMonth::DateTool - Base class for determining which date package to use for calendrical calculations.

=head1 SYNOPSIS

  my $date_tool = HTML::CalendarMonth::DateTool->new(
                    year     => $YYYY_year,
                    month    => $one_thru_12_month,
                    weeknum  => $weeknum_mode,
                    historic => $historic_mode,
                    datetool => $specific_datetool_if_desired,
                  );

=head1 DESCRIPTION

This module attempts to utilize the best date calculation package
available on the current system. For most contemporary dates this
usually ends up being the internal Time::Local package of perl. For more
exotic dates, or when week number of the years are desired, other
methods are attempted including DateTime, Date::Calc, Date::Manip, and
the linux/unix 'ncal' or 'cal' commands. Each of these has a specific
subclass of this module offering the same utility methods needed by
HTML::CalendarMonth.

=head1 METHODS

=over

=item new()

Constructor. Takes the following parameters:

=over

=item year

Year of calendar in question (required). If you are rendering exotic
dates (i.e. dates outside of 1970 to 2038) then something besides
Time::Local will be used for calendrical calculations.

=item month

Month of calendar in question (required). 1 through 12.

=item weeknum

Optional. When specified, will limit class excursions to those that are
currently set up for week of year calculations.

=item historic

Optional. If the the ncal or cal commands are available, use one of them
rather than other available date modules since these utilities
accurately handle some specific historical artifacts such as the
transition from Julian to Gregorian.

=item datetool

Optional. Mostly for debugging, this option can be used to indicate a
specific HTML::CalendarMonth::DateTool subclass for instantiation. The
value can be either the actual utility class, e.g., Date::Calc, or the
name of the CalendarMonth handler leaf class, e.g. DateCalc. Use 'ncal'
or 'cal', respectively, for the wrappers around those commands.

=back

=back

There are number of methods automatically available:

=over

=item month()

=item year()

=item weeknum()

=item historical()

=item datetool()

Accessors for the parameters provided to C<new()> above.

=item dow1st()

Returns the day of week number for the 1st of the C<year> and C<month>
specified during the call to C<new()>. Relies on the presence of
C<dow1st_and_lastday()>. Should be 0..6 starting with Sun.

=item lastday()

Returns the last day of the month for the C<year> and C<month> specified
during the call to C<new()>. Relies on the presence of
C<dow1st_and_lastday()>.

=back

=head1 Overridden methods

Subclasses of this module must provide at least the C<day_epoch()> and
C<dow1st_and_lastday()> methods.

=over

=item dow1st_and_lastday()

Required. Provides a list containing the day of the week of the first
day of the month (0..6 starting with Sun) along with the last day of
the month.

=item day_epoch()

Optional unless interested in epoch values for wacky dates. For a given
day, and optionally C<month> and C<year> if they are different from
those specified in C<new()>, provide the unix epoch in seconds for that
day at midnight.

=back

If the subclass is expected to provide week of year numbers, three more
methods are necessary:

=over

=item dow()

For a given day, and optionally C<month> and C<year> if they are
different from those specified in C<new()>, provide the day of week
number. (1=Sunday, 7=Saturday).

=item add_days($days, $delta, $day, [$month], [$year])

For a given day, and optionally C<month> and C<year> if they are
different from those specified in C<new()>, provide a list of year,
month, and day once C<delta> days have been added.

=item week_of_year($day, [$month], [$year])

For a given day, and optionally C<month> and C<year> if they are
different from those specified in C<new()>, provide a list with the week
number of the year along with the year. (some days of a particular year
can end up belonging to the prior or following years).

=back

=head1 AUTHOR

Matthew P. Sisk, E<lt>F<sisk@mojotoad.com>E<gt>

=head1 COPYRIGHT

Copyright (c) 2010 Matthew P. Sisk. All rights reserved. All wrongs
revenged. This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

HTML::CalendarMonth(3), Time::Local(3), DateTime(3), Date::Calc(3),
Date::Manip(3), cal(1)