8 use OpenILS::Utils::MFHD::Caption;
12 our @EXPORT_OK = qw(dispatch generator incr_date can_increment);
24 my $daypat = '(mo|tu|we|th|fr|sa|su)';
25 my $weekpat = '(99|98|97|00|01|02|03|04|05)';
27 my $monthpat = '(01|02|03|04|05|06|07|08|09|10|11|12)';
28 my $seasonpat = '(21|22|23|24)';
30 # Initialize $weeknopat to be '(01|02|03|...|51|52|53)'
32 foreach my $weekno (1..52) {
33 $weeknopat .= sprintf('%02d|', $weekno);
40 # Translate daynames into day of week for DateTime
41 # also used to check if dayname is valid.
43 if (exists $daynames{$pat}) {
45 # figure out day of week for date and compare
46 my $dt = DateTime->new(
51 return ($dt->day_of_week == $daynames{$pat});
52 } elsif (length($pat) == 2) {
54 return $pat == $date[2];
55 } elsif (length($pat) == 4) {
57 my ($mon, $day) = unpack("a2a2", $pat);
59 return (($mon == $date[1]) && ($day == $date[2]));
61 carp "Invalid day pattern '$pat'";
66 # TODO: possible support for extraneous $yp information
67 # ex. $ypdtu but on a bi-weekly (currently assumes weekly)
73 my $dt = DateTime->new(
79 # printf("# subsequent_day: pat='%s' cur='%s'\n", $pat, join('/', @cur));
81 if (exists $daynames{$pat}) {
82 # dd: published on the given weekday
83 my $dow = $dt->day_of_week;
84 my $corr = ($daynames{$pat} - $dow + 7) % 7;
86 if ($dow == $daynames{$pat}) {
87 # the next one is one week hence
90 # the next one is later this week,
91 # or it is next week (ie, on or after next Monday)
92 # $corr will take care of it.
93 $dt->add(days => $corr);
95 @cur = ($dt->year, $dt->month, $dt->day);
96 } elsif (length($pat) == 2) {
97 # DD: published on the give day of every month
98 if ($dt->day >= $pat) {
99 # current date is on or after $pat: next one is next month
100 $dt->set(day => $pat);
101 $dt->add(months => 1);
102 @cur = ($dt->year, $dt->month, $dt->day);
104 # current date is before $pat: set day to pattern
107 } elsif (length($pat) == 4) {
108 # MMDD: published on the given day of the given month
109 my ($mon, $day) = unpack("a2a2", $pat);
111 if (MFHD::Caption::on_or_after([$cur[1], $cur[2]], [$mon, $day])) {
112 # Current date is on or after pattern; next one is next year
115 # Year is now right. Either it's next year (because of on_or_after)
116 # or it's this year, because the current date is NOT on or after
117 # the pattern. Just fix the month and day
121 carp "Invalid day pattern '$pat'";
125 foreach my $i (0..$#cur) {
126 $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
129 # printf("subsequent_day: returning '%s'\n", join('/', @cur));
134 # Calculate date of 3rd Friday of the month (for example)
135 # 1-5: count from beginning of month
136 # 99-97: count back from end of month
137 sub nth_week_of_month {
143 # printf("# nth_week_of_month(dt, '%s', '%s')\n", $week, $day);
145 if (0 < $week && $week <= 5) {
146 $nth_day = $dt->clone->set(day => 1);
147 } elsif ($week >= 97) {
148 $nth_day = DateTime->last_day_of_month(
156 $dow = $nth_day->day_of_week();
158 # If a particular day was passed in (eg, we want 3rd friday)
159 # then use that day for the calculations, otherwise, just use
160 # the day of the week of the original date (the date $dt).
162 $day = $daynames{$day};
164 $day = $dt->day_of_week;
170 days => ($day - $dow + 7) % 7,
175 $nth_day->subtract(days => ($day - $dow + 7) % 7);
177 # 99: last week of month, 98: second last, etc.
178 for (my $i = 99 - $week; $i > 0; $i--) {
179 $nth_day->subtract(weeks => 1);
183 # There is no nth "day" in the month!
184 return undef if ($dt->month != $nth_day->month);
190 # Internal utility function to match the various different patterns
191 # of month, week, and day
199 # printf("check_date('%s', '%s', '%s')\n", $month, $weekno, $day || '');
204 ($dt->month == $month)
206 ($dt->week_of_month == $weekno)
209 && ($dt->week_of_month ==
210 nth_week_of_month($dt, $weekno, $day)->week_of_month)
217 if ($daynames{$day} != $dt->day_of_week) {
218 # if it's the wrong day of the week, rest doesn't matter
222 if (!defined $month) {
225 ($weekno == 0) # Every week
226 || ($dt->weekday_of_month == $weekno) # this week
229 && ($dt->weekday_of_month ==
230 nth_week_of_month($dt, $weekno, $day)->weekday_of_month)
236 if ($month != $dt->month) {
237 # If it's the wrong month, then we're done
241 # It's the right day of the week
242 # It's the right month
244 if (($weekno == 0) || ($weekno == $dt->weekday_of_month)) {
245 # If this matches, then we're counting from the beginning
246 # of the month and it matches and we're done.
250 # only case left is that the week number is counting from
251 # the end of the month: eg, second last wednesday
254 && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month ==
255 $dt->weekday_of_month)
262 my $dt = DateTime->new(
268 if ($pat =~ m/^$weekpat$daypat$/) {
269 # WWdd: 03we = Third Wednesday
270 return check_date($dt, undef, $1, $2);
271 } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
272 # MMWWdd: 0599tu Last Tuesday in May XXX WRITE ME
273 return check_date($dt, $1, $2, $3);
274 } elsif ($pat =~ m/^$monthpat$weekpat$/) {
275 # MMWW: 1204: Fourth week in December XXX WRITE ME
276 return check_date($dt, $1, $2, undef);
278 carp "invalid week pattern '$pat'";
284 # Use $pat to calcuate the date of the issue following $cur
286 sub subsequent_week {
294 # printf("# subsequent_week('%s', '%s', '%s', '%s')\n", $pat, @cur);
302 if ($pat =~ m/^$weekpat$daypat$/o) {
303 # WWdd: published on given weekday of given week of every month
304 my ($week, $day) = ($1, $2);
306 # printf("# subsequent_week: matched /WWdd/: week='%s', day='%s'\n",
311 $candidate = $dt->clone;
313 if ($dt->day_of_week == $daynames{$day}) {
314 # Current is right day, next one is a week hence
315 $candidate->add(days => 7);
318 days => ($daynames{$day} - $dt->day_of_week + 7) % 7);
321 # 3rd Friday of the month (eg)
322 $candidate = nth_week_of_month($dt, $week, $day);
325 if ($candidate <= $dt) {
326 # If the n'th week of the month happens on before the
327 # current issue, then the next issue is published next
328 # month, otherwise, it's published this month.
329 # This will never happen for the "00: every week" pattern
330 # printf("# subsequent_week: candidate (%s) occurs on or before current date (%s)\n",
331 # join('/', $candidate->year, $candidate->month, $candidate->day),
332 # join('/', $dt->year, $dt->month, $dt->day));
333 $candidate->set(day => 1);
334 $candidate->add(months => 1);
335 $candidate = nth_week_of_month($candidate, $week, $day);
337 } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
338 # MMWWdd: published on given weekday of given week of given month
339 my ($month, $week, $day) = ($1, $2, $3);
341 # printf("# subsequent_week: matched /MMWWdd/: month='%s', week='%s', day='%s'\n",
342 # $month, $week, $day);
344 $candidate = DateTime->new(
349 $candidate = nth_week_of_month($candidate, $week, $day);
350 if ($candidate <= $dt) {
351 # We've missed it for this year, next one that matches
353 $candidate->add(years => 1)->set(day => 1);
354 $candidate = nth_week_of_month($candidate, $week, $day);
356 } elsif ($pat =~ m/^$monthpat$weekpat$/) {
357 # MMWW: published during given week of given month
358 my ($month, $week) = ($1, $2);
360 $candidate = nth_week_of_month(
368 if ($candidate <= $dt) {
369 # Already past the pattern date this year, move to next year
370 $candidate->add(years => 1)->set(day => 1);
371 $candidate = nth_week_of_month($candidate, $week, 'th');
374 carp "invalid week pattern '$pat'";
378 $cur[0] = $candidate->year;
379 $cur[1] = $candidate->month;
380 $cur[2] = $candidate->day;
382 foreach my $i (0..$#cur) {
383 $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
393 return ($pat eq $date[1]);
396 sub subsequent_month {
402 if ($cur[1] >= $pat) {
403 # Current date is on or after the patter date, so the next
404 # occurence is next year
408 # The year is right, just set the month to the pattern date.
418 return ($pat eq $date[1]);
421 sub subsequent_season {
428 # printf("# subsequent_season: pat='%s', cur='%s'\n", $pat, join('/',@cur));
430 if (($pat < 21) || ($pat > 24)) {
431 carp "Unexpected season '$pat'";
435 if ($caption->winter_starts_year()) {
437 $pat = 20; # fake early winter
440 $cur[1] = 20; # fake early winter
444 if ($cur[1] >= $pat) {
445 # current season is on or past pattern season in this year,
446 # advance to next year
449 # Either we've advanced to the next year or the current season
450 # is before the pattern season in the current year. Either way,
451 # all that remains is to set the season properly
465 sub subsequent_year {
479 # We handle enumeration patterns separately. This just
480 # ensures that when we're processing chronological patterns
481 # we don't match an enumeration pattern.
485 sub subsequent_issue {
491 # Issue generation is handled separately
497 e => \&match_issue, # not really a "chron" code
505 d => \&subsequent_day,
506 e => \&subsequent_issue, # not really a "chron" code
507 w => \&subsequent_week,
508 m => \&subsequent_month,
509 s => \&subsequent_season,
510 y => \&subsequent_year,
514 my $chroncode = shift;
516 return $dispatch{$chroncode};
520 my $chroncode = shift;
522 return $generators{$chroncode};
526 a => {years => 1}, # annual
527 b => {months => 2}, # bimonthly
528 c => {days => 3}, # semiweekly
529 d => {days => 1}, # daily
530 e => {weeks => 2}, # biweekly
531 f => {months => 6}, # semiannual
532 g => {years => 2}, # biennial
533 h => {years => 3}, # triennial
534 i => {days => 2}, # three times / week
535 j => {days => 10}, # three times /month
537 # l => {weeks => 3}, # triweekly (NON-STANDARD)
538 m => {months => 1}, # monthly
539 q => {months => 3}, # quarterly
540 s => {days => 15}, # semimonthly
541 t => {months => 4}, # three times / year
542 w => {weeks => 1}, # weekly
543 # x => completely irregular
549 return exists $increments{$freq};
552 # TODO: add support for weeks as chron level?
555 my $incr = $increments{$freq};
558 if (scalar(@new) == 1) {
559 # only a year is specified. Next date is easy
560 $new[0] += $incr->{years} || 1;
561 } elsif (scalar(@new) == 2) {
562 # Year and month or season
565 $new[1] += ($incr->{months} / 3) || 1;
569 $new[1] -= 4; # 25 - 4 == 21 == Spring after Winter
573 $new[1] += $incr->{months} || 1;
580 } elsif (scalar(@new) == 3) {
581 # Year, Month, Day: now it gets complicated.
583 if ($new[2] =~ /^[0-9]+$/) {
584 # A single number for the day of month, relatively simple
585 my $dt = DateTime->new(
592 $new[1] = $dt->month;
596 warn("Don't know how to cope with @new");
599 foreach my $i (0..$#new) {
600 $new[$i] = '0' . (0 + $new[$i]) if $new[$i] < 10;