X-Git-Url: https://git.donarmstrong.com/?p=deb_pkgs%2Flibhtml-calendarmonth-perl.git;a=blobdiff_plain;f=lib%2FHTML%2FCalendarMonth%2FDateTool.pm;fp=lib%2FHTML%2FCalendarMonth%2FDateTool.pm;h=91df572ca0e895746e7c6eecdc9446c694260a19;hp=e3a40f5e1207344906dfa07f04134a88be8e7761;hb=f3ef12e10123e46a0db95d820bb77f6e6d3225c7;hpb=febd0b02136ed777f42c0e2b79d71db21c1805a8 diff --git a/lib/HTML/CalendarMonth/DateTool.pm b/lib/HTML/CalendarMonth/DateTool.pm index e3a40f5..91df572 100644 --- a/lib/HTML/CalendarMonth/DateTool.pm +++ b/lib/HTML/CalendarMonth/DateTool.pm @@ -1,24 +1,31 @@ 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}; @@ -30,7 +37,7 @@ sub toolmap { } } } - return undef unless $tool; + return unless $tool; join('::', __PACKAGE__, $tool); } @@ -39,19 +46,24 @@ sub new { 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; } @@ -62,19 +74,84 @@ sub weeknum { shift->{weeknum} } 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 { @@ -85,7 +162,7 @@ sub day_epoch { Time::Local::timegm(0,0,0,1,$month,$year); } -sub skips { +sub _skips { my $self = shift; @_ ? $self->{skips} = shift : $self->{skips}; } @@ -94,65 +171,145 @@ sub dow1st { (shift->dow1st_and_lastday)[0] } 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; @@ -179,8 +336,9 @@ 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 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 @@ -209,17 +367,18 @@ currently set up for week of year calculations. =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 @@ -245,7 +404,7 @@ Accessors for the parameters provided to C above. Returns the day of week number for the 1st of the C and C specified during the call to C. Relies on the presence of -C. +C. Should be 0..6 starting with Sun. =item lastday() @@ -264,8 +423,9 @@ C methods. =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() @@ -285,7 +445,7 @@ methods are necessary: For a given day, and optionally C and C if they are different from those specified in C, provide the day of week -number. (1=Sunday, 6=Saturday). +number. (1=Sunday, 7=Saturday). =item add_days($days, $delta, $day, [$month], [$year]) @@ -308,7 +468,7 @@ Matthew P. Sisk, EFE =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.