package HTML::CalendarMonth::DateTool;
+BEGIN {
+ $HTML::CalendarMonth::DateTool::VERSION = '1.25';
+}
# Base class for determining what date calculation package to use.
use strict;
+use warnings;
use Carp;
-use vars qw($VERSION);
-$VERSION = '0.01';
-
-my $DEBUG = 0;
+use File::Which qw( which );
my %Toolmap = (
'Time::Local' => 'TimeLocal',
'Date::Calc' => 'DateCalc',
'DateTime' => 'DateTime',
'Date::Manip' => 'DateManip',
+ 'ncal' => 'Ncal',
'cal' => 'Cal',
);
-sub toolmap {
+my %Classmap;
+$Classmap{lc $Toolmap{$_}} = $_ foreach keys %Toolmap;
+
+my($Cal_Cmd, $Ncal_Cmd);
+
+sub _toolmap {
shift;
my $str = shift;
my $tool = $Toolmap{$str};
}
}
}
- return undef unless $tool;
+ return unless $tool;
join('::', __PACKAGE__, $tool);
}
my $self = {};
bless $self, $class;
my %parms = @_;
- $self->{year} = $parms{year} or croak "missing year (YYYY)\n";
- $self->{month} = $parms{month} or croak "missing month num (1-12)\n";
+ $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})
+ $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";
}
- print STDERR "Using date class $dc\n" if $DEBUG;
# rebless into new class
bless $self, $dc;
}
sub historic { shift->{historic} }
sub datetool { shift->{datetool} }
-sub cal_cmd {
+sub _name {
+ my $class = shift;
+ $class = ref $class || $class;
+ lc((split(/::/, $class))[-1]);
+}
+
+sub _cal_cmd {
my $self = shift;
- unless (exists $self->{cal_cmd}) {
- my $cal;
- foreach (qw(/usr/bin /bin /usr/local/bin)) {
- if (-x "$_/cal") {
- $cal = "$_/cal";
- last;
+ 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 = '';
}
}
- $self->{cal_cmd} = $cal || undef;
}
- $self->{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 {
Time::Local::timegm(0,0,0,1,$month,$year);
}
-sub skips {
+sub _skips {
my $self = shift;
@_ ? $self->{skips} = shift : $self->{skips};
}
sub lastday { (shift->dow1st_and_lastday)[1] }
-sub _summon_date_class {
+sub _dmy_now {
my $self = shift;
- return $self->datetool if $self->datetool;
- my $dc;
- if ( $self->_test_for_timelocal ) {
- $dc = __PACKAGE__ . '::TimeLocal';
+ 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);
+ }
}
- elsif ( $self->_test_for_cal ) {
- $dc = __PACKAGE__ . '::Cal';
+ 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) {
+ @tools = $c->_name;
}
- elsif ( $self->_test_for_datecalc ) {
- $dc = __PACKAGE__ . '::DateCalc';
+ else {
+ @tools = qw( timelocal datecalc datetime datemanip ncal cal );
}
- elsif ( $self->_test_for_datetime ) {
- $dc = __PACKAGE__ . '::DateTime';
+ 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;
+ }
}
- elsif( $self->_test_for_datemanip ) {
- $dc = __PACKAGE__ . '::DateManip';
+ return $dc if $dc;
+ if (@tools == 1) {
+ croak "invalid date tool " . join(': ', @{$fails[0]}) if @tools == 1;
}
else {
- croak <<__NOTOOL;
-No valid date mechanism found. Install Date::Calc, DateTime, or
-Date::Manip, or try using a date between 1970 and 2038 so that
-Time::Local can be used.
-__NOTOOL
+ croak join("\n",
+ "no valid date tool found:",
+ map(sprintf("%11s: %s", @$_), @fails),
+ "\n"
+ );
}
- $dc;
}
sub _dump_tests {
my $self = shift;
- print "Time::Local : ", $self->_test_for_timelocal, "\n";
- print " cal : ", $self->_test_for_cal, "\n";
- print " Date::Calc : ", $self->_test_for_datecalc, "\n";
- print " DateTime : ", $self->_test_for_datetime, "\n";
- print "Date::Manip : ", $self->_test_for_datemanip, "\n";
+ 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 _test_for_timelocal {
+sub _is_julian {
my $self = shift;
- my $year = $self->year;
- my $weeknum = $self->weeknum;
- !$weeknum && eval "require Time::Local" &&
- (!defined $year || (($year >= 1970) && ($year < 2038)));
+ my $y = $self->year;
+ $y < 1752 || ($y == 1752 && $self->month <= 9);
}
-sub _test_for_cal {
+sub _timelocal_fails {
my $self = shift;
- my $weeknum = $self->weeknum;
- my $historic = $self->historic;
- my $cal = $self->cal_cmd;
- !$weeknum && $historic && $cal;
+ 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 _test_for_datecalc { eval "require Date::Calc"; 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 _test_for_datetime { eval "require DateTime"; 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 _test_for_datemanip { eval "require Date::Manip"; 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;
+ 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;
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 unix 'cal' command. Each of these has a specific subclass of this
-module offering the same utility methods needed by HTML::CalendarMonth.
+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
=item historic
-Optional. If the 'cal' command is available, use it rather than other available
-date modules since the 'cal' command accurately handles some specific
-historical artifacts such as the transition from Julian to Gregorian.
+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. For the
-'cal' command, use 'cal'.
+name of the CalendarMonth handler leaf class, e.g. DateCalc. Use 'ncal'
+or 'cal', respectively, for the wrappers around those commands.
=back
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()>.
+C<dow1st_and_lastday()>. Should be 0..6 starting with Sun.
=item lastday()
=item dow1st_and_lastday()
-Required. Provides a list containing the day of the week of the first day of the
-month along with the last day of the month.
+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()
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, 6=Saturday).
+number. (1=Sunday, 7=Saturday).
=item add_days($days, $delta, $day, [$month], [$year])
=head1 COPYRIGHT
-Copyright (c) 2005 Matthew P. Sisk. All rights reserved. All wrongs
+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.
projects / deb_pkgs / libhtml-calendarmonth-perl.git / blobdiff