lib/HTML/CalendarMonth/DateTool/Ncal.pm

   1 package HTML::CalendarMonth::DateTool::Ncal;
   2 BEGIN {
   3   $HTML::CalendarMonth::DateTool::Ncal::VERSION = '1.25';
   4 }
   5
   6 # Interface to linux 'ncal' command
   7
   8 use strict;
   9 use warnings;
  10 use Carp;
  11
  12 use base qw( HTML::CalendarMonth::DateTool );
  13
  14 sub dow1st_and_lastday {
  15   my($self, $month, $year) = @_;
  16   $month ||= $self->month;
  17   $year  ||= $self->year;
  18   if (my $r = $self->{_res}{$year}{$month}) {
  19     return(@$r);
  20   }
  21   my $cmd = $self->_ncal_cmd or croak "ncal command not found\n";
  22   my @cal = grep(!/^\s*$/,`$cmd -w $month $year`);
  23   shift @cal if $cal[0] =~ /\D+/;
  24   my @woy;
  25   if ($cal[-1] =~ /^\s*\d+/) {
  26     @woy = (pop @cal) =~ /(\d+)/g;
  27   }
  28   my($dow1st, %woy, %dow);
  29   my $last_day = 0;
  30   for my $di (0 .. $#cal) {
  31     my $dow_row = $cal[$di];
  32     $dow_row =~ s/^\s+//;
  33     $dow_row =~ s/\s+$//;
  34     $dow_row =~ s/\s{3,}/ 0 /g;
  35     $dow_row =~ s/\D+/ /g;
  36     $dow_row =~ s/^\s+//;
  37     my @days = split(/\s+/, $dow_row);
  38     $dow1st = ($di + 1) % 7 if !$dow1st && $days[0];
  39     for my $i (0 .. $#days) {
  40       my $d = $days[$i] || next;
  41       $last_day = $d if $d > $last_day;
  42       $woy{$d}  = $woy[$i];
  43       $dow{$d}  = $di;
  44     }
  45   }
  46   # catch switchover from Julian to Gregorian
  47   $self->_skips(undef);
  48   if ($month == 9 && $year == 1752) {
  49     my %skips;
  50     grep(++$skips{$_}, 3 .. 13);
  51     $self->_skips(\%skips);
  52   }
  53   delete $self->{_woy};
  54   delete $self->{_dow};
  55   delete $self->{_res};
  56   $self->{_woy}{$year}{$month} = \%woy if %woy;
  57   $self->{_dow}{$year}{$month} = \%dow if %dow;
  58   $self->{_res}{$year}{$month} = [$dow1st, $last_day];
  59   ($dow1st, $last_day);
  60 }
  61
  62 sub week_of_year {
  63   my($self, $day, $month, $year) = @_;
  64   $month ||= $self->month;
  65   $year  ||= $self->year;
  66   croak "week of year not supported by ncal prior to 10/1752"
  67     if $year < 1752 || ($year == 1752 && $month < 10);
  68   $self->dow1st_and_lastday unless $self->{_woy}{$year}{$month};
  69   $self->{_woy}{$year}{$month}{$day};
  70 }
  71
  72 sub dow {
  73   my($self, $day, $month, $year) = @_;
  74   $month ||= $self->month;
  75   $year  ||= $self->year;
  76   $self->dow1st_and_lastday unless $self->{_dow}{$year}{$month};
  77   $self->{_dow}{$year}{$month}{$day};
  78 }
  79
  80 sub add_days {
  81   my($self, $delta, $day, $month, $year) = @_;
  82   $month ||= $self->month;
  83   $year  ||= $self->year;
  84   if ($delta <= 0) {
  85     $delta = abs($delta);
  86     if ($delta < $day) {
  87       return($day - $delta, $month, $year);
  88     }
  89     else {
  90       my @days = reverse 1 .. $day;
  91       while (@days < $delta) {
  92         --$month;
  93         if ($month <= 0) {
  94           --$year; $month = 12;
  95         }
  96         my($dow1st, $last_day) = $self->dow1st_and_lastday($month, $year);
  97         push(@days, reverse 1 .. $last_day);
  98       }
  99       return($days[$delta], $month, $year);
 100     }
 101   }
 102   else {
 103     my $last_day;
 104     if (my $res = $self->{_res}{$year}{$month}) {
 105       $last_day = $res->[1];
 106     }
 107     else {
 108       $last_day = ($self->dow1st_and_lastday($month, $year))[1];
 109     }
 110     if ($delta + $day <= $last_day) {
 111       return($day + $delta, $month, $year);
 112     }
 113     my @days = $day .. $last_day;
 114     while (@days < $delta) {
 115       ++$month;
 116       if ($month > 12) {
 117         ++$year; $month = 1;
 118       }
 119       my($dow1st, $last_day) = $self->dow1st_and_lastday($month, $year);
 120       push(@days, 1 .. $last_day);
 121     }
 122     return($days[$delta], $month, $year);
 123   }
 124 }
 125
 126 1;