Open-ILS/src/perlmods/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;