--- /dev/null
+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. (0=Sunday, 6=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)
projects / deb_pkgs / libhtml-calendarmonth-perl.git / blobdiff