[open-ils-commits] r14646 - branches/rel_1_6_0/Open-ILS/src/perlmods/OpenILS/Utils/MFHD (dbs)
svn at svn.open-ils.org
svn at svn.open-ils.org
Tue Oct 27 23:36:29 EDT 2009
Author: dbs
Date: 2009-10-27 23:36:26 -0400 (Tue, 27 Oct 2009)
New Revision: 14646
Added:
branches/rel_1_6_0/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Date.pm
Log:
Missed the addition of Date.pm when backporting djfiander's MFHD enhancements. Argh.
Added: branches/rel_1_6_0/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Date.pm
===================================================================
--- branches/rel_1_6_0/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Date.pm (rev 0)
+++ branches/rel_1_6_0/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Date.pm 2009-10-28 03:36:26 UTC (rev 14646)
@@ -0,0 +1,544 @@
+package MFHD::Date;
+use strict;
+use integer;
+use Carp;
+
+use Data::Dumper;
+use DateTime;
+
+use base 'Exporter';
+
+our @EXPORT_OK =qw(dispatch generator incr_date can_increment);
+
+my %daynames = (
+ 'mo' => 1,
+ 'tu' => 2,
+ 'we' => 3,
+ 'th' => 4,
+ 'fr' => 5,
+ 'sa' => 6,
+ 'su' => 7,
+ );
+
+my $daypat = '(mo|tu|we|th|fr|sa|su)';
+my $weekpat = '(99|98|97|00|01|02|03|04|05)';
+my $weeknopat;
+my $monthpat = '(01|02|03|04|05|06|07|08|09|10|11|12)';
+my $seasonpat = '(21|22|23|24)';
+
+# Initialize $weeknopat to be '(01|02|03|...|51|52|53)'
+$weeknopat = '(';
+foreach my $weekno (1..52) {
+ $weeknopat .= sprintf('%02d|', $weekno);
+}
+$weeknopat .= '53)';
+
+sub match_day {
+ my $pat = shift;
+ my @date = @_;
+ # Translate daynames into day of week for DateTime
+ # also used to check if dayname is valid.
+
+ if (exists $daynames{$pat}) {
+ # dd
+ # figure out day of week for date and compare
+ my $dt = DateTime->new(year => $date[0],
+ month => $date[1],
+ day => $date[2]);
+ return ($dt->day_of_week == $daynames{$pat});
+ } elsif (length($pat) == 2) {
+ # DD
+ return $pat == $date[2];
+ } elsif (length($pat) == 4) {
+ # MMDD
+ my ($mon, $day) = unpack("a2a2", $pat);
+
+ return (($mon == $date[1]) && ($day == $date[2]));
+ } else {
+ carp "Invalid day pattern '$pat'";
+ return 0;
+ }
+}
+
+sub subsequent_day {
+ my $pat = shift;
+ my @cur = @_;
+ my $dt = DateTime->new(year => $cur[0],
+ month => $cur[1],
+ day => $cur[2]);
+
+# printf("# subsequent_day: pat='%s' cur='%s'\n", $pat, join('/', @cur));
+
+ if (exists $daynames{$pat}) {
+ # dd: published on the given weekday
+ my $dow = $dt->day_of_week;
+ my $corr = ($daynames{$pat} - $dow + 7) % 7;
+
+ if ($dow == $daynames{$pat}) {
+ # the next one is one week hence
+ $dt->add(days => 7);
+ } else {
+ # the next one is later this week,
+ # or it is next week (ie, on or after next Monday)
+ # $corr will take care of it.
+ $dt->add(days => $corr);
+ }
+ @cur = ($dt->year, $dt->month, $dt->day);
+ } elsif (length($pat) == 2) {
+ # DD: published on the give day of every month
+ if ($dt->day >= $pat) {
+ # current date is on or after $pat: next one is next month
+ $dt->set(day => $pat);
+ $dt->add(months => 1);
+ @cur = ($dt->year, $dt->month, $dt->day);
+ } else {
+ # current date is before $pat: set day to pattern
+ $cur[2] = $pat;
+ }
+ } elsif (length($pat) == 4) {
+ # MMDD: published on the given day of the given month
+ my ($mon, $day) = unpack("a2a2", $pat);
+
+ if (on_or_after($mon, $day, $cur[1], $cur[2])) {
+ # Current date is on or after pattern; next one is next year
+ $cur[0] += 1;
+ }
+ # Year is now right. Either it's next year (because of on_or_after)
+ # or it's this year, because the current date is NOT on or after
+ # the pattern. Just fix the month and day
+ $cur[1] = $mon;
+ $cur[2] = $day;
+ } else {
+ carp "Invalid day pattern '$pat'";
+ return undef;
+ }
+
+ foreach my $i (0..$#cur) {
+ $cur[$i] = '0' . (0+$cur[$i]) if $cur[$i] < 10;
+ }
+
+# printf("subsequent_day: returning '%s'\n", join('/', @cur));
+
+ return @cur;
+}
+
+
+# Calculate date of 3rd Friday of the month (for example)
+# 1-5: count from beginning of month
+# 99-97: count back from end of month
+sub nth_week_of_month {
+ my $dt = shift;
+ my $week = shift;
+ my $day = shift;
+ my ($nth_day, $dow);
+
+# printf("# nth_week_of_month(dt, '%s', '%s')\n", $week, $day);
+
+ if (0 < $week && $week <= 5) {
+ $nth_day = $dt->clone->set(day => 1);
+ } elsif ($week >= 97) {
+ $nth_day = DateTime->last_day_of_month(year => $dt->year,
+ month => $dt->month);
+ } else {
+ return undef;
+ }
+
+ $dow = $nth_day->day_of_week();
+
+ # If a particular day was passed in (eg, we want 3rd friday)
+ # then use that day for the calculations, otherwise, just use
+ # the day of the week of the original date (the date $dt).
+ if (defined($day)) {
+ $day = $daynames{$day};
+ } else {
+ $day = $dt->day_of_week;
+ }
+
+ if ($week <= 5) {
+ # count forwards
+ $nth_day->add(days => ($day - $dow + 7) % 7,
+ weeks=> $week - 1);
+ } else {
+ # count backwards
+ $nth_day->subtract(days => ($day - $dow + 7) % 7);
+
+ # 99: last week of month, 98: second last, etc.
+ for (my $i = 99 - $week; $i > 0; $i--) {
+ $nth_day->subtract(weeks => 1);
+ }
+ }
+
+ # There is no nth "day" in the month!
+ return undef if ($dt->month != $nth_day->month);
+
+ return $nth_day;
+}
+
+#
+# Internal utility function to match the various different patterns
+# of month, week, and day
+#
+sub check_date {
+ my $dt = shift;
+ my $month = shift;
+ my $weekno = shift;
+ my $day = shift;
+
+# printf("check_date('%s', '%s', '%s')\n", $month, $weekno, $day || '');
+
+ if (!defined $day) {
+ # MMWW
+ return (($dt->month == $month)
+ && (($dt->week_of_month == $weekno)
+ || ($weekno >= 97
+ && ($dt->week_of_month == nth_week_of_month($dt, $weekno, $day)->week_of_month))));
+ }
+
+ # simple cases first
+ if ($daynames{$day} != $dt->day_of_week) {
+ # if it's the wrong day of the week, rest doesn't matter
+ return 0;
+ }
+
+ if (!defined $month) {
+ # WWdd
+ return (($weekno == 0) # Every week
+ || ($dt->weekday_of_month == $weekno) # this week
+ || (($weekno >= 97) && ($dt->weekday_of_month == nth_week_of_month($dt, $weekno, $day)->weekday_of_month)));
+ }
+
+ # MMWWdd
+ if ($month != $dt->month) {
+ # If it's the wrong month, then we're done
+ return 0;
+ }
+
+ # It's the right day of the week
+ # It's the right month
+
+ if (($weekno == 0) ||($weekno == $dt->weekday_of_month)) {
+ # If this matches, then we're counting from the beginning
+ # of the month and it matches and we're done.
+ return 1;
+ }
+
+ # only case left is that the week number is counting from
+ # the end of the month: eg, second last wednesday
+ return (($weekno >= 97)
+ && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month == $dt->weekday_of_month));
+}
+
+sub match_week {
+ my $pat = shift;
+ my @date = @_;
+ my $dt = DateTime->new(year => $date[0],
+ month => $date[1],
+ day => $date[2]);
+
+ if ($pat =~ m/^$weekpat$daypat$/) {
+ # WWdd: 03we = Third Wednesday
+ return check_date($dt, undef, $1, $2);
+ } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
+ # MMWWdd: 0599tu Last Tuesday in May XXX WRITE ME
+ return check_date($dt, $1, $2, $3);
+ } elsif ($pat =~ m/^$monthpat$weekpat$/) {
+ # MMWW: 1204: Fourth week in December XXX WRITE ME
+ return check_date($dt, $1, $2, undef);
+ } else {
+ carp "invalid week pattern '$pat'";
+ return 0;
+ }
+}
+
+#
+# Use $pat to calcuate the date of the issue following $cur
+#
+sub subsequent_week {
+ my $pat = shift;
+ my @cur = @_;
+ my $candidate;
+ my $dt;
+
+# printf("# subsequent_week('%s', '%s', '%s', '%s')\n", $pat, @cur);
+
+ $dt = DateTime->new(year => $cur[0],
+ month=> $cur[1],
+ day => $cur[2]);
+
+ if ($pat =~ m/^$weekpat$daypat$/o) {
+ # WWdd: published on given weekday of given week of every month
+ my ($week, $day) = ($1, $2);
+
+# printf("# subsequent_week: matched /WWdd/: week='%s', day='%s'\n",
+# $week, $day);
+
+ if ($week eq '00') {
+ # Every week
+ $candidate = $dt->clone;
+
+ if ($dt->day_of_week == $daynames{$day}) {
+ # Current is right day, next one is a week hence
+ $candidate->add(days => 7);
+ } else {
+ $candidate->add(days => ($daynames{$day} - $dt->day_of_week + 7) % 7);
+ }
+ } else {
+ # 3rd Friday of the month (eg)
+ $candidate = nth_week_of_month($dt, $week, $day);
+ }
+
+ if ($candidate <= $dt) {
+ # If the n'th week of the month happens on before the
+ # current issue, then the next issue is published next
+ # month, otherwise, it's published this month.
+ # This will never happen for the "00: every week" pattern
+# printf("# subsequent_week: candidate (%s) occurs on or before current date (%s)\n",
+# join('/', $candidate->year, $candidate->month, $candidate->day),
+# join('/', $dt->year, $dt->month, $dt->day));
+ $candidate->set(day => 1);
+ $candidate->add(months => 1);
+ $candidate = nth_week_of_month($candidate, $week, $day);
+ }
+ } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
+ # MMWWdd: published on given weekday of given week of given month
+ my ($month, $week, $day) = ($1, $2, $3);
+
+# printf("# subsequent_week: matched /MMWWdd/: month='%s', week='%s', day='%s'\n",
+# $month, $week, $day);
+
+ $candidate = DateTime->new(year => $dt->year,
+ month=> $month,
+ day => 1);
+ $candidate = nth_week_of_month($candidate, $week, $day);
+ if ($candidate <= $dt) {
+ # We've missed it for this year, next one that matches
+ # will be next year
+ $candidate->add(years => 1)->set(day => 1);
+ $candidate = nth_week_of_month($candidate, $week, $day);
+ }
+ } elsif ($pat =~ m/^$monthpat$weekpat$/) {
+ # MMWW: published during given week of given month
+ my ($month, $week) = ($1, $2);
+
+ $candidate = nth_week_of_month(DateTime->new(year => $dt->year,
+ month=> $month,
+ day => 1),
+ $week,
+ 'th');
+ if ($candidate <= $dt) {
+ # Already past the pattern date this year, move to next year
+ $candidate->add(years => 1)->set(day => 1);
+ $candidate = nth_week_of_month($candidate, $week, 'th');
+ }
+ } else {
+ carp "invalid week pattern '$pat'";
+ return undef;
+ }
+
+ $cur[0] = $candidate->year;
+ $cur[1] = $candidate->month;
+ $cur[2] = $candidate->day;
+
+ foreach my $i (0..$#cur) {
+ $cur[$i] = '0' . (0+$cur[$i]) if $cur[$i] < 10;
+ }
+
+ return @cur;
+}
+
+sub match_month {
+ my $pat = shift;
+ my @date = @_;
+
+ return ($pat eq $date[1]);
+}
+
+sub subsequent_month {
+ my $pat = shift;
+ my @cur = @_;
+
+ if ($cur[1] >= $pat) {
+ # Current date is on or after the patter date, so the next
+ # occurence is next year
+ $cur[0] += 1;
+ }
+
+ # The year is right, just set the month to the pattern date.
+ $cur[1] = $pat;
+
+ return @cur;
+}
+
+sub match_season {
+ my $pat = shift;
+ my @date = @_;
+
+ return ($pat eq $date[1]);
+}
+
+sub subsequent_season {
+ my $pat = shift;
+ my @cur = @_;
+
+# printf("# subsequent_season: pat='%s', cur='%s'\n", $pat, join('/', at cur));
+
+ if (($pat < 21) || ($pat > 24)) {
+ carp "Unexpected season '$pat'";
+ return undef;
+ }
+
+ if ($cur[1] >= $pat) {
+ # current season is on or past pattern season in this year,
+ # advance to next year
+ $cur[0] += 1;
+ }
+ # Either we've advanced to the next year or the current season
+ # is before the pattern season in the current year. Either way,
+ # all that remains is to set the season properly
+ $cur[1] = $pat;
+
+ return @cur;
+}
+
+sub match_year {
+ my $pat = shift;
+ my @date = @_;
+
+ # XXX WRITE ME
+ return 0;
+}
+
+sub subsequent_year {
+ my $pat = shift;
+ my $cur = shift;
+
+ # XXX WRITE ME
+ return undef;
+}
+
+sub match_issue {
+ my $pat = shift;
+ my @date = @_;
+
+ # We handle enumeration patterns separately. This just
+ # ensures that when we're processing chronological patterns
+ # we don't match an enumeration pattern.
+ return 0;
+}
+
+sub subsequent_issue {
+ my $pat = shift;
+ my $cur = shift;
+
+ # Issue generation is handled separately
+ return undef;
+}
+
+my %dispatch = (
+ d => \&match_day,
+ e => \&match_issue, # not really a "chron" code
+ w => \&match_week,
+ m => \&match_month,
+ s => \&match_season,
+ y => \&match_year,
+);
+
+my %generators = (
+ d => \&subsequent_day,
+ e => \&subsequent_issue, # not really a "chron" code
+ w => \&subsequent_week,
+ m => \&subsequent_month,
+ s => \&subsequent_season,
+ y => \&subsequent_year,
+);
+
+sub dispatch {
+ my $chroncode = shift;
+
+ return $dispatch{$chroncode};
+}
+
+sub generator {
+ my $chroncode = shift;
+
+ return $generators{$chroncode};
+}
+
+my %increments = (
+ a => {years => 1}, # annual
+ b => {months => 2}, # bimonthly
+ c => {days => 3}, # semiweekly
+ d => {days => 1}, # daily
+ e => {weeks => 2}, # biweekly
+ f => {months => 6}, # semiannual
+ g => {years => 2}, # biennial
+ h => {years => 3}, # triennial
+ i => {days => 2}, # three times / week
+ j => {days => 10}, # three times /month
+ # k => continuous
+ m => {months => 1}, # monthly
+ q => {months => 3}, # quarterly
+ s => {days => 15}, # semimonthly
+ t => {months => 4}, # three times / year
+ w => {weeks => 1}, # weekly
+ # x => completely irregular
+);
+
+sub can_increment {
+ my $freq = shift;
+
+ return exists $increments{$freq};
+}
+
+sub incr_date {
+ my $freq = shift;
+ my $incr = $increments{$freq};
+ my @new = @_;
+
+ if (scalar(@new) == 1) {
+ # only a year is specified. Next date is easy
+ $new[0] += $incr->{years} || 1;
+ } elsif (scalar(@new) == 2) {
+ # Year and month or season
+ if ($new[1] > 20) {
+ # season
+ $new[1] += ($incr->{months}/3) || 1;
+ if ($new[1] > 24) {
+ # carry
+ $new[0] += 1;
+ $new[1] -= 4; # 25 - 4 == 21 == Spring after Winter
+ }
+ } else {
+ # month
+ $new[1] += $incr->{months} || 1;
+ if ($new[1] > 12) {
+ # carry
+ $new[0] += 1;
+ $new[1] -= 12;
+ }
+ }
+ } elsif (scalar(@new) == 3) {
+ # Year, Month, Day: now it gets complicated.
+
+ if ($new[2] =~ /^[0-9]+$/) {
+ # A single number for the day of month, relatively simple
+ my $dt = DateTime->new(year => $new[0],
+ month=> $new[1],
+ day => $new[2]);
+ $dt->add(%{$incr});
+ $new[0] = $dt->year;
+ $new[1] = $dt->month;
+ $new[2] = $dt->day;
+ }
+ } else {
+ warn("Don't know how to cope with @new");
+ }
+
+ foreach my $i (0..$#new) {
+ $new[$i] = '0' . (0+$new[$i]) if $new[$i] < 10;
+ }
+
+ return @new;
+}
+
+1;
More information about the open-ils-commits
mailing list