11 our @EXPORT_OK = qw(dispatch generator incr_date can_increment);
23 my $daypat = '(mo|tu|we|th|fr|sa|su)';
24 my $weekpat = '(99|98|97|00|01|02|03|04|05)';
26 my $monthpat = '(01|02|03|04|05|06|07|08|09|10|11|12)';
27 my $seasonpat = '(21|22|23|24)';
29 # Initialize $weeknopat to be '(01|02|03|...|51|52|53)'
31 foreach my $weekno (1..52) {
32 $weeknopat .= sprintf('%02d|', $weekno);
39 # Translate daynames into day of week for DateTime
40 # also used to check if dayname is valid.
42 if (exists $daynames{$pat}) {
44 # figure out day of week for date and compare
45 my $dt = DateTime->new(
50 return ($dt->day_of_week == $daynames{$pat});
51 } elsif (length($pat) == 2) {
53 return $pat == $date[2];
54 } elsif (length($pat) == 4) {
56 my ($mon, $day) = unpack("a2a2", $pat);
58 return (($mon == $date[1]) && ($day == $date[2]));
60 carp "Invalid day pattern '$pat'";
68 my $dt = DateTime->new(
74 # printf("# subsequent_day: pat='%s' cur='%s'\n", $pat, join('/', @cur));
76 if (exists $daynames{$pat}) {
77 # dd: published on the given weekday
78 my $dow = $dt->day_of_week;
79 my $corr = ($daynames{$pat} - $dow + 7) % 7;
81 if ($dow == $daynames{$pat}) {
82 # the next one is one week hence
85 # the next one is later this week,
86 # or it is next week (ie, on or after next Monday)
87 # $corr will take care of it.
88 $dt->add(days => $corr);
90 @cur = ($dt->year, $dt->month, $dt->day);
91 } elsif (length($pat) == 2) {
92 # DD: published on the give day of every month
93 if ($dt->day >= $pat) {
94 # current date is on or after $pat: next one is next month
95 $dt->set(day => $pat);
96 $dt->add(months => 1);
97 @cur = ($dt->year, $dt->month, $dt->day);
99 # current date is before $pat: set day to pattern
102 } elsif (length($pat) == 4) {
103 # MMDD: published on the given day of the given month
104 my ($mon, $day) = unpack("a2a2", $pat);
106 if (on_or_after($mon, $day, $cur[1], $cur[2])) {
107 # Current date is on or after pattern; next one is next year
110 # Year is now right. Either it's next year (because of on_or_after)
111 # or it's this year, because the current date is NOT on or after
112 # the pattern. Just fix the month and day
116 carp "Invalid day pattern '$pat'";
120 foreach my $i (0..$#cur) {
121 $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
124 # printf("subsequent_day: returning '%s'\n", join('/', @cur));
129 # Calculate date of 3rd Friday of the month (for example)
130 # 1-5: count from beginning of month
131 # 99-97: count back from end of month
132 sub nth_week_of_month {
138 # printf("# nth_week_of_month(dt, '%s', '%s')\n", $week, $day);
140 if (0 < $week && $week <= 5) {
141 $nth_day = $dt->clone->set(day => 1);
142 } elsif ($week >= 97) {
143 $nth_day = DateTime->last_day_of_month(
151 $dow = $nth_day->day_of_week();
153 # If a particular day was passed in (eg, we want 3rd friday)
154 # then use that day for the calculations, otherwise, just use
155 # the day of the week of the original date (the date $dt).
157 $day = $daynames{$day};
159 $day = $dt->day_of_week;
165 days => ($day - $dow + 7) % 7,
170 $nth_day->subtract(days => ($day - $dow + 7) % 7);
172 # 99: last week of month, 98: second last, etc.
173 for (my $i = 99 - $week; $i > 0; $i--) {
174 $nth_day->subtract(weeks => 1);
178 # There is no nth "day" in the month!
179 return undef if ($dt->month != $nth_day->month);
185 # Internal utility function to match the various different patterns
186 # of month, week, and day
194 # printf("check_date('%s', '%s', '%s')\n", $month, $weekno, $day || '');
199 ($dt->month == $month)
201 ($dt->week_of_month == $weekno)
204 && ($dt->week_of_month ==
205 nth_week_of_month($dt, $weekno, $day)->week_of_month)
212 if ($daynames{$day} != $dt->day_of_week) {
213 # if it's the wrong day of the week, rest doesn't matter
217 if (!defined $month) {
220 ($weekno == 0) # Every week
221 || ($dt->weekday_of_month == $weekno) # this week
224 && ($dt->weekday_of_month ==
225 nth_week_of_month($dt, $weekno, $day)->weekday_of_month)
231 if ($month != $dt->month) {
232 # If it's the wrong month, then we're done
236 # It's the right day of the week
237 # It's the right month
239 if (($weekno == 0) || ($weekno == $dt->weekday_of_month)) {
240 # If this matches, then we're counting from the beginning
241 # of the month and it matches and we're done.
245 # only case left is that the week number is counting from
246 # the end of the month: eg, second last wednesday
249 && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month ==
250 $dt->weekday_of_month)
257 my $dt = DateTime->new(
263 if ($pat =~ m/^$weekpat$daypat$/) {
264 # WWdd: 03we = Third Wednesday
265 return check_date($dt, undef, $1, $2);
266 } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
267 # MMWWdd: 0599tu Last Tuesday in May XXX WRITE ME
268 return check_date($dt, $1, $2, $3);
269 } elsif ($pat =~ m/^$monthpat$weekpat$/) {
270 # MMWW: 1204: Fourth week in December XXX WRITE ME
271 return check_date($dt, $1, $2, undef);
273 carp "invalid week pattern '$pat'";
279 # Use $pat to calcuate the date of the issue following $cur
281 sub subsequent_week {
287 # printf("# subsequent_week('%s', '%s', '%s', '%s')\n", $pat, @cur);
295 if ($pat =~ m/^$weekpat$daypat$/o) {
296 # WWdd: published on given weekday of given week of every month
297 my ($week, $day) = ($1, $2);
299 # printf("# subsequent_week: matched /WWdd/: week='%s', day='%s'\n",
304 $candidate = $dt->clone;
306 if ($dt->day_of_week == $daynames{$day}) {
307 # Current is right day, next one is a week hence
308 $candidate->add(days => 7);
311 days => ($daynames{$day} - $dt->day_of_week + 7) % 7);
314 # 3rd Friday of the month (eg)
315 $candidate = nth_week_of_month($dt, $week, $day);
318 if ($candidate <= $dt) {
319 # If the n'th week of the month happens on before the
320 # current issue, then the next issue is published next
321 # month, otherwise, it's published this month.
322 # This will never happen for the "00: every week" pattern
323 # printf("# subsequent_week: candidate (%s) occurs on or before current date (%s)\n",
324 # join('/', $candidate->year, $candidate->month, $candidate->day),
325 # join('/', $dt->year, $dt->month, $dt->day));
326 $candidate->set(day => 1);
327 $candidate->add(months => 1);
328 $candidate = nth_week_of_month($candidate, $week, $day);
330 } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
331 # MMWWdd: published on given weekday of given week of given month
332 my ($month, $week, $day) = ($1, $2, $3);
334 # printf("# subsequent_week: matched /MMWWdd/: month='%s', week='%s', day='%s'\n",
335 # $month, $week, $day);
337 $candidate = DateTime->new(
342 $candidate = nth_week_of_month($candidate, $week, $day);
343 if ($candidate <= $dt) {
344 # We've missed it for this year, next one that matches
346 $candidate->add(years => 1)->set(day => 1);
347 $candidate = nth_week_of_month($candidate, $week, $day);
349 } elsif ($pat =~ m/^$monthpat$weekpat$/) {
350 # MMWW: published during given week of given month
351 my ($month, $week) = ($1, $2);
353 $candidate = nth_week_of_month(
361 if ($candidate <= $dt) {
362 # Already past the pattern date this year, move to next year
363 $candidate->add(years => 1)->set(day => 1);
364 $candidate = nth_week_of_month($candidate, $week, 'th');
367 carp "invalid week pattern '$pat'";
371 $cur[0] = $candidate->year;
372 $cur[1] = $candidate->month;
373 $cur[2] = $candidate->day;
375 foreach my $i (0..$#cur) {
376 $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
386 return ($pat eq $date[1]);
389 sub subsequent_month {
393 if ($cur[1] >= $pat) {
394 # Current date is on or after the patter date, so the next
395 # occurence is next year
399 # The year is right, just set the month to the pattern date.
409 return ($pat eq $date[1]);
412 sub subsequent_season {
416 # printf("# subsequent_season: pat='%s', cur='%s'\n", $pat, join('/',@cur));
418 if (($pat < 21) || ($pat > 24)) {
419 carp "Unexpected season '$pat'";
423 if ($cur[1] >= $pat) {
424 # current season is on or past pattern season in this year,
425 # advance to next year
428 # Either we've advanced to the next year or the current season
429 # is before the pattern season in the current year. Either way,
430 # all that remains is to set the season properly
444 sub subsequent_year {
456 # We handle enumeration patterns separately. This just
457 # ensures that when we're processing chronological patterns
458 # we don't match an enumeration pattern.
462 sub subsequent_issue {
466 # Issue generation is handled separately
472 e => \&match_issue, # not really a "chron" code
480 d => \&subsequent_day,
481 e => \&subsequent_issue, # not really a "chron" code
482 w => \&subsequent_week,
483 m => \&subsequent_month,
484 s => \&subsequent_season,
485 y => \&subsequent_year,
489 my $chroncode = shift;
491 return $dispatch{$chroncode};
495 my $chroncode = shift;
497 return $generators{$chroncode};
501 a => {years => 1}, # annual
502 b => {months => 2}, # bimonthly
503 c => {days => 3}, # semiweekly
504 d => {days => 1}, # daily
505 e => {weeks => 2}, # biweekly
506 f => {months => 6}, # semiannual
507 g => {years => 2}, # biennial
508 h => {years => 3}, # triennial
509 i => {days => 2}, # three times / week
510 j => {days => 10}, # three times /month
512 m => {months => 1}, # monthly
513 q => {months => 3}, # quarterly
514 s => {days => 15}, # semimonthly
515 t => {months => 4}, # three times / year
516 w => {weeks => 1}, # weekly
517 # x => completely irregular
523 return exists $increments{$freq};
526 # TODO: add support for weeks as chron level?
529 my $incr = $increments{$freq};
532 if (scalar(@new) == 1) {
533 # only a year is specified. Next date is easy
534 $new[0] += $incr->{years} || 1;
535 } elsif (scalar(@new) == 2) {
536 # Year and month or season
539 $new[1] += ($incr->{months} / 3) || 1;
543 $new[1] -= 4; # 25 - 4 == 21 == Spring after Winter
547 $new[1] += $incr->{months} || 1;
554 } elsif (scalar(@new) == 3) {
555 # Year, Month, Day: now it gets complicated.
557 if ($new[2] =~ /^[0-9]+$/) {
558 # A single number for the day of month, relatively simple
559 my $dt = DateTime->new(
566 $new[1] = $dt->month;
570 warn("Don't know how to cope with @new");
573 foreach my $i (0..$#new) {
574 $new[$i] = '0' . (0 + $new[$i]) if $new[$i] < 10;