X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lib%2FHTML%2FCalendarMonth%2FDateTool%2FNcal.pm;fp=lib%2FHTML%2FCalendarMonth%2FDateTool%2FNcal.pm;h=22fff0f107851c3158b111dad0f13d6a156aaaba;hb=f3ef12e10123e46a0db95d820bb77f6e6d3225c7;hp=0000000000000000000000000000000000000000;hpb=febd0b02136ed777f42c0e2b79d71db21c1805a8;p=deb_pkgs%2Flibhtml-calendarmonth-perl.git

diff --git a/lib/HTML/CalendarMonth/DateTool/Ncal.pm b/lib/HTML/CalendarMonth/DateTool/Ncal.pm
new file mode 100644
index 0000000..22fff0f
--- /dev/null
+++ b/lib/HTML/CalendarMonth/DateTool/Ncal.pm
@@ -0,0 +1,126 @@
+package HTML::CalendarMonth::DateTool::Ncal;
+BEGIN {
+  $HTML::CalendarMonth::DateTool::Ncal::VERSION = '1.25';
+}
+
+# Interface to linux 'ncal' command
+
+use strict;
+use warnings;
+use Carp;
+
+use base qw( HTML::CalendarMonth::DateTool );
+
+sub dow1st_and_lastday {
+  my($self, $month, $year) = @_;
+  $month ||= $self->month;
+  $year  ||= $self->year;
+  if (my $r = $self->{_res}{$year}{$month}) {
+    return(@$r);
+  }
+  my $cmd = $self->_ncal_cmd or croak "ncal command not found\n";
+  my @cal = grep(!/^\s*$/,`$cmd -w $month $year`);
+  shift @cal if $cal[0] =~ /\D+/;
+  my @woy;
+  if ($cal[-1] =~ /^\s*\d+/) {
+    @woy = (pop @cal) =~ /(\d+)/g;
+  }
+  my($dow1st, %woy, %dow);
+  my $last_day = 0;
+  for my $di (0 .. $#cal) {
+    my $dow_row = $cal[$di];
+    $dow_row =~ s/^\s+//;
+    $dow_row =~ s/\s+$//;
+    $dow_row =~ s/\s{3,}/ 0 /g;
+    $dow_row =~ s/\D+/ /g;
+    $dow_row =~ s/^\s+//;
+    my @days = split(/\s+/, $dow_row);
+    $dow1st = ($di + 1) % 7 if !$dow1st && $days[0];
+    for my $i (0 .. $#days) {
+      my $d = $days[$i] || next;
+      $last_day = $d if $d > $last_day;
+      $woy{$d}  = $woy[$i];
+      $dow{$d}  = $di;
+    }
+  }
+  # catch switchover from Julian to Gregorian
+  $self->_skips(undef);
+  if ($month == 9 && $year == 1752) {
+    my %skips;
+    grep(++$skips{$_}, 3 .. 13);
+    $self->_skips(\%skips);
+  }
+  delete $self->{_woy};
+  delete $self->{_dow};
+  delete $self->{_res};
+  $self->{_woy}{$year}{$month} = \%woy if %woy;
+  $self->{_dow}{$year}{$month} = \%dow if %dow;
+  $self->{_res}{$year}{$month} = [$dow1st, $last_day];
+  ($dow1st, $last_day);
+}
+
+sub week_of_year {
+  my($self, $day, $month, $year) = @_;
+  $month ||= $self->month;
+  $year  ||= $self->year;
+  croak "week of year not supported by ncal prior to 10/1752"
+    if $year < 1752 || ($year == 1752 && $month < 10);
+  $self->dow1st_and_lastday unless $self->{_woy}{$year}{$month};
+  $self->{_woy}{$year}{$month}{$day};
+}
+
+sub dow {
+  my($self, $day, $month, $year) = @_;
+  $month ||= $self->month;
+  $year  ||= $self->year;
+  $self->dow1st_and_lastday unless $self->{_dow}{$year}{$month};
+  $self->{_dow}{$year}{$month}{$day};
+}
+
+sub add_days {
+  my($self, $delta, $day, $month, $year) = @_;
+  $month ||= $self->month;
+  $year  ||= $self->year;
+  if ($delta <= 0) {
+    $delta = abs($delta);
+    if ($delta < $day) {
+      return($day - $delta, $month, $year);
+    }
+    else {
+      my @days = reverse 1 .. $day;
+      while (@days < $delta) {
+        --$month;
+        if ($month <= 0) {
+          --$year; $month = 12;
+        }
+        my($dow1st, $last_day) = $self->dow1st_and_lastday($month, $year);
+        push(@days, reverse 1 .. $last_day);
+      }
+      return($days[$delta], $month, $year);
+    }
+  }
+  else {
+    my $last_day;
+    if (my $res = $self->{_res}{$year}{$month}) {
+      $last_day = $res->[1];
+    }
+    else {
+      $last_day = ($self->dow1st_and_lastday($month, $year))[1];
+    }
+    if ($delta + $day <= $last_day) {
+      return($day + $delta, $month, $year);
+    }
+    my @days = $day .. $last_day;
+    while (@days < $delta) {
+      ++$month;
+      if ($month > 12) {
+        ++$year; $month = 1;
+      }
+      my($dow1st, $last_day) = $self->dow1st_and_lastday($month, $year);
+      push(@days, 1 .. $last_day);
+    }
+    return($days[$delta], $month, $year);
+  }
+}
+
+1;