Make Evergreen Perl modules installable via Module::Build to match OpenSRF
[working/Evergreen.git] / Open-ILS / src / perlmods / lib / OpenILS / Utils / MFHD / Date.pm
1 package MFHD::Date;
2 use strict;
3 use integer;
4 use Carp;
5
6 use Data::Dumper;
7 use DateTime;
8
9 use base 'Exporter';
10
11 our @EXPORT_OK = qw(dispatch generator incr_date can_increment);
12
13 my %daynames = (
14     'mo' => 1,
15     'tu' => 2,
16     'we' => 3,
17     'th' => 4,
18     'fr' => 5,
19     'sa' => 6,
20     'su' => 7,
21 );
22
23 my $daypat  = '(mo|tu|we|th|fr|sa|su)';
24 my $weekpat = '(99|98|97|00|01|02|03|04|05)';
25 my $weeknopat;
26 my $monthpat  = '(01|02|03|04|05|06|07|08|09|10|11|12)';
27 my $seasonpat = '(21|22|23|24)';
28
29 # Initialize $weeknopat to be '(01|02|03|...|51|52|53)'
30 $weeknopat = '(';
31 foreach my $weekno (1..52) {
32     $weeknopat .= sprintf('%02d|', $weekno);
33 }
34 $weeknopat .= '53)';
35
36 sub match_day {
37     my $pat  = shift;
38     my @date = @_;
39     # Translate daynames into day of week for DateTime
40     # also used to check if dayname is valid.
41
42     if (exists $daynames{$pat}) {
43         # dd
44         # figure out day of week for date and compare
45         my $dt = DateTime->new(
46             year  => $date[0],
47             month => $date[1],
48             day   => $date[2]
49         );
50         return ($dt->day_of_week == $daynames{$pat});
51     } elsif (length($pat) == 2) {
52         # DD
53         return $pat == $date[2];
54     } elsif (length($pat) == 4) {
55         # MMDD
56         my ($mon, $day) = unpack("a2a2", $pat);
57
58         return (($mon == $date[1]) && ($day == $date[2]));
59     } else {
60         carp "Invalid day pattern '$pat'";
61         return 0;
62     }
63 }
64
65 sub subsequent_day {
66     my $pat = shift;
67     my @cur = @_;
68     my $dt  = DateTime->new(
69         year  => $cur[0],
70         month => $cur[1],
71         day   => $cur[2]
72     );
73
74    #     printf("# subsequent_day: pat='%s' cur='%s'\n", $pat, join('/', @cur));
75
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;
80
81         if ($dow == $daynames{$pat}) {
82             # the next one is one week hence
83             $dt->add(days => 7);
84         } else {
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);
89         }
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);
98         } else {
99             # current date is before $pat: set day to pattern
100             $cur[2] = $pat;
101         }
102     } elsif (length($pat) == 4) {
103         # MMDD: published on the given day of the given month
104         my ($mon, $day) = unpack("a2a2", $pat);
105
106         if (on_or_after($mon, $day, $cur[1], $cur[2])) {
107             # Current date is on or after pattern; next one is next year
108             $cur[0] += 1;
109         }
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
113         $cur[1] = $mon;
114         $cur[2] = $day;
115     } else {
116         carp "Invalid day pattern '$pat'";
117         return undef;
118     }
119
120     foreach my $i (0..$#cur) {
121         $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
122     }
123
124     #     printf("subsequent_day: returning '%s'\n", join('/', @cur));
125
126     return @cur;
127 }
128
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 {
133     my $dt   = shift;
134     my $week = shift;
135     my $day  = shift;
136     my ($nth_day, $dow);
137
138     #     printf("# nth_week_of_month(dt, '%s', '%s')\n", $week, $day);
139
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(
144             year  => $dt->year,
145             month => $dt->month
146         );
147     } else {
148         return undef;
149     }
150
151     $dow = $nth_day->day_of_week();
152
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).
156     if (defined($day)) {
157         $day = $daynames{$day};
158     } else {
159         $day = $dt->day_of_week;
160     }
161
162     if ($week <= 5) {
163         # count forwards
164         $nth_day->add(
165             days  => ($day - $dow + 7) % 7,
166             weeks => $week - 1
167         );
168     } else {
169         # count backwards
170         $nth_day->subtract(days => ($day - $dow + 7) % 7);
171
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);
175         }
176     }
177
178     # There is no nth "day" in the month!
179     return undef if ($dt->month != $nth_day->month);
180
181     return $nth_day;
182 }
183
184 #
185 # Internal utility function to match the various different patterns
186 # of month, week, and day
187 #
188 sub check_date {
189     my $dt     = shift;
190     my $month  = shift;
191     my $weekno = shift;
192     my $day    = shift;
193
194     #     printf("check_date('%s', '%s', '%s')\n", $month, $weekno, $day || '');
195
196     if (!defined $day) {
197         # MMWW
198         return (
199             ($dt->month == $month)
200               && (
201                 ($dt->week_of_month == $weekno)
202                 || (
203                     $weekno >= 97
204                     && ($dt->week_of_month ==
205                         nth_week_of_month($dt, $weekno, $day)->week_of_month)
206                 )
207               )
208         );
209     }
210
211     # simple cases first
212     if ($daynames{$day} != $dt->day_of_week) {
213         # if it's the wrong day of the week, rest doesn't matter
214         return 0;
215     }
216
217     if (!defined $month) {
218         # WWdd
219         return (
220             ($weekno == 0)    # Every week
221               || ($dt->weekday_of_month == $weekno)    # this week
222               || (
223                 ($weekno >= 97)
224                 && ($dt->weekday_of_month ==
225                     nth_week_of_month($dt, $weekno, $day)->weekday_of_month)
226               )
227         );
228     }
229
230     # MMWWdd
231     if ($month != $dt->month) {
232         # If it's the wrong month, then we're done
233         return 0;
234     }
235
236     # It's the right day of the week
237     # It's the right month
238
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.
242         return 1;
243     }
244
245     # only case left is that the week number is counting from
246     # the end of the month: eg, second last wednesday
247     return (
248         ($weekno >= 97)
249           && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month ==
250             $dt->weekday_of_month)
251     );
252 }
253
254 sub match_week {
255     my $pat  = shift;
256     my @date = @_;
257     my $dt   = DateTime->new(
258         year  => $date[0],
259         month => $date[1],
260         day   => $date[2]
261     );
262
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);
272     } else {
273         carp "invalid week pattern '$pat'";
274         return 0;
275     }
276 }
277
278 #
279 # Use $pat to calcuate the date of the issue following $cur
280 #
281 sub subsequent_week {
282     my $pat = shift;
283     my @cur = @_;
284     my $candidate;
285     my $dt;
286
287     #     printf("# subsequent_week('%s', '%s', '%s', '%s')\n", $pat, @cur);
288
289     $dt = DateTime->new(
290         year  => $cur[0],
291         month => $cur[1],
292         day   => $cur[2]
293     );
294
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);
298
299         #       printf("# subsequent_week: matched /WWdd/: week='%s', day='%s'\n",
300         #              $week, $day);
301
302         if ($week eq '00') {
303             # Every week
304             $candidate = $dt->clone;
305
306             if ($dt->day_of_week == $daynames{$day}) {
307                 # Current is right day, next one is a week hence
308                 $candidate->add(days => 7);
309             } else {
310                 $candidate->add(
311                     days => ($daynames{$day} - $dt->day_of_week + 7) % 7);
312             }
313         } else {
314             # 3rd Friday of the month (eg)
315             $candidate = nth_week_of_month($dt, $week, $day);
316         }
317
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);
329         }
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);
333
334 #       printf("# subsequent_week: matched /MMWWdd/: month='%s', week='%s', day='%s'\n",
335 #              $month, $week, $day);
336
337         $candidate = DateTime->new(
338             year  => $dt->year,
339             month => $month,
340             day   => 1
341         );
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
345             # will be next year
346             $candidate->add(years => 1)->set(day => 1);
347             $candidate = nth_week_of_month($candidate, $week, $day);
348         }
349     } elsif ($pat =~ m/^$monthpat$weekpat$/) {
350         # MMWW: published during given week of given month
351         my ($month, $week) = ($1, $2);
352
353         $candidate = nth_week_of_month(
354             DateTime->new(
355                 year  => $dt->year,
356                 month => $month,
357                 day   => 1
358             ),
359             $week, 'th'
360         );
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');
365         }
366     } else {
367         carp "invalid week pattern '$pat'";
368         return undef;
369     }
370
371     $cur[0] = $candidate->year;
372     $cur[1] = $candidate->month;
373     $cur[2] = $candidate->day;
374
375     foreach my $i (0..$#cur) {
376         $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
377     }
378
379     return @cur;
380 }
381
382 sub match_month {
383     my $pat  = shift;
384     my @date = @_;
385
386     return ($pat eq $date[1]);
387 }
388
389 sub subsequent_month {
390     my $pat = shift;
391     my @cur = @_;
392
393     if ($cur[1] >= $pat) {
394         # Current date is on or after the patter date, so the next
395         # occurence is next year
396         $cur[0] += 1;
397     }
398
399     # The year is right, just set the month to the pattern date.
400     $cur[1] = $pat;
401
402     return @cur;
403 }
404
405 sub match_season {
406     my $pat  = shift;
407     my @date = @_;
408
409     return ($pat eq $date[1]);
410 }
411
412 sub subsequent_season {
413     my $pat = shift;
414     my @cur = @_;
415
416 #     printf("# subsequent_season: pat='%s', cur='%s'\n", $pat, join('/',@cur));
417
418     if (($pat < 21) || ($pat > 24)) {
419         carp "Unexpected season '$pat'";
420         return undef;
421     }
422
423     if ($cur[1] >= $pat) {
424         # current season is on or past pattern season in this year,
425         # advance to next year
426         $cur[0] += 1;
427     }
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
431     $cur[1] = $pat;
432
433     return @cur;
434 }
435
436 sub match_year {
437     my $pat  = shift;
438     my @date = @_;
439
440     # XXX WRITE ME
441     return 0;
442 }
443
444 sub subsequent_year {
445     my $pat = shift;
446     my $cur = shift;
447
448     # XXX WRITE ME
449     return undef;
450 }
451
452 sub match_issue {
453     my $pat  = shift;
454     my @date = @_;
455
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.
459     return 0;
460 }
461
462 sub subsequent_issue {
463     my $pat = shift;
464     my $cur = shift;
465
466     # Issue generation is handled separately
467     return undef;
468 }
469
470 my %dispatch = (
471     d => \&match_day,
472     e => \&match_issue,    # not really a "chron" code
473     w => \&match_week,
474     m => \&match_month,
475     s => \&match_season,
476     y => \&match_year,
477 );
478
479 my %generators = (
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,
486 );
487
488 sub dispatch {
489     my $chroncode = shift;
490
491     return $dispatch{$chroncode};
492 }
493
494 sub generator {
495     my $chroncode = shift;
496
497     return $generators{$chroncode};
498 }
499
500 my %increments = (
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
511                             # k => continuous
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
518 );
519
520 sub can_increment {
521     my $freq = shift;
522
523     return exists $increments{$freq};
524 }
525
526 # TODO: add support for weeks as chron level?
527 sub incr_date {
528     my $freq = shift;
529     my $incr = $increments{$freq};
530     my @new  = @_;
531
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
537         if ($new[1] > 20) {
538             # season
539             $new[1] += ($incr->{months} / 3) || 1;
540             if ($new[1] > 24) {
541                 # carry
542                 $new[0] += 1;
543                 $new[1] -= 4;    # 25 - 4 == 21 == Spring after Winter
544             }
545         } else {
546             # month
547             $new[1] += $incr->{months} || 1;
548             if ($new[1] > 12) {
549                 # carry
550                 $new[0] += 1;
551                 $new[1] -= 12;
552             }
553         }
554     } elsif (scalar(@new) == 3) {
555         # Year, Month, Day: now it gets complicated.
556
557         if ($new[2] =~ /^[0-9]+$/) {
558             # A single number for the day of month, relatively simple
559             my $dt = DateTime->new(
560                 year  => $new[0],
561                 month => $new[1],
562                 day   => $new[2]
563             );
564             $dt->add(%{$incr});
565             $new[0] = $dt->year;
566             $new[1] = $dt->month;
567             $new[2] = $dt->day;
568         }
569     } else {
570         warn("Don't know how to cope with @new");
571     }
572
573     foreach my $i (0..$#new) {
574         $new[$i] = '0' . (0 + $new[$i]) if $new[$i] < 10;
575     }
576
577     return @new;
578 }
579
580 1;