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 # TODO: possible support for extraneous $yp information
  66 # ex. $ypdtu but on a bi-weekly (currently assumes weekly)
  67 sub subsequent_day {
  68     my $pat = shift;
  69     my $cur = shift;
  70
  71     my @cur = @$cur;
  72     my $dt  = DateTime->new(
  73         year  => $cur[0],
  74         month => $cur[1],
  75         day   => $cur[2]
  76     );
  77
  78    #     printf("# subsequent_day: pat='%s' cur='%s'\n", $pat, join('/', @cur));
  79
  80     if (exists $daynames{$pat}) {
  81         # dd: published on the given weekday
  82         my $dow  = $dt->day_of_week;
  83         my $corr = ($daynames{$pat} - $dow + 7) % 7;
  84
  85         if ($dow == $daynames{$pat}) {
  86             # the next one is one week hence
  87             $dt->add(days => 7);
  88         } else {
  89             # the next one is later this week,
  90             # or it is next week (ie, on or after next Monday)
  91             # $corr will take care of it.
  92             $dt->add(days => $corr);
  93         }
  94         @cur = ($dt->year, $dt->month, $dt->day);
  95     } elsif (length($pat) == 2) {
  96         # DD: published on the give day of every month
  97         if ($dt->day >= $pat) {
  98             # current date is on or after $pat: next one is next month
  99             $dt->set(day => $pat);
 100             $dt->add(months => 1);
 101             @cur = ($dt->year, $dt->month, $dt->day);
 102         } else {
 103             # current date is before $pat: set day to pattern
 104             $cur[2] = $pat;
 105         }
 106     } elsif (length($pat) == 4) {
 107         # MMDD: published on the given day of the given month
 108         my ($mon, $day) = unpack("a2a2", $pat);
 109
 110         if (on_or_after($mon, $day, $cur[1], $cur[2])) {
 111             # Current date is on or after pattern; next one is next year
 112             $cur[0] += 1;
 113         }
 114         # Year is now right. Either it's next year (because of on_or_after)
 115         # or it's this year, because the current date is NOT on or after
 116         # the pattern. Just fix the month and day
 117         $cur[1] = $mon;
 118         $cur[2] = $day;
 119     } else {
 120         carp "Invalid day pattern '$pat'";
 121         return undef;
 122     }
 123
 124     foreach my $i (0..$#cur) {
 125         $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
 126     }
 127
 128     #     printf("subsequent_day: returning '%s'\n", join('/', @cur));
 129
 130     return @cur;
 131 }
 132
 133 # Calculate date of 3rd Friday of the month (for example)
 134 # 1-5: count from beginning of month
 135 # 99-97: count back from end of month
 136 sub nth_week_of_month {
 137     my $dt   = shift;
 138     my $week = shift;
 139     my $day  = shift;
 140     my ($nth_day, $dow);
 141
 142     #     printf("# nth_week_of_month(dt, '%s', '%s')\n", $week, $day);
 143
 144     if (0 < $week && $week <= 5) {
 145         $nth_day = $dt->clone->set(day => 1);
 146     } elsif ($week >= 97) {
 147         $nth_day = DateTime->last_day_of_month(
 148             year  => $dt->year,
 149             month => $dt->month
 150         );
 151     } else {
 152         return undef;
 153     }
 154
 155     $dow = $nth_day->day_of_week();
 156
 157     # If a particular day was passed in (eg, we want 3rd friday)
 158     # then use that day for the calculations, otherwise, just use
 159     # the day of the week of the original date (the date $dt).
 160     if (defined($day)) {
 161         $day = $daynames{$day};
 162     } else {
 163         $day = $dt->day_of_week;
 164     }
 165
 166     if ($week <= 5) {
 167         # count forwards
 168         $nth_day->add(
 169             days  => ($day - $dow + 7) % 7,
 170             weeks => $week - 1
 171         );
 172     } else {
 173         # count backwards
 174         $nth_day->subtract(days => ($day - $dow + 7) % 7);
 175
 176         # 99: last week of month, 98: second last, etc.
 177         for (my $i = 99 - $week; $i > 0; $i--) {
 178             $nth_day->subtract(weeks => 1);
 179         }
 180     }
 181
 182     # There is no nth "day" in the month!
 183     return undef if ($dt->month != $nth_day->month);
 184
 185     return $nth_day;
 186 }
 187
 188 #
 189 # Internal utility function to match the various different patterns
 190 # of month, week, and day
 191 #
 192 sub check_date {
 193     my $dt     = shift;
 194     my $month  = shift;
 195     my $weekno = shift;
 196     my $day    = shift;
 197
 198     #     printf("check_date('%s', '%s', '%s')\n", $month, $weekno, $day || '');
 199
 200     if (!defined $day) {
 201         # MMWW
 202         return (
 203             ($dt->month == $month)
 204               && (
 205                 ($dt->week_of_month == $weekno)
 206                 || (
 207                     $weekno >= 97
 208                     && ($dt->week_of_month ==
 209                         nth_week_of_month($dt, $weekno, $day)->week_of_month)
 210                 )
 211               )
 212         );
 213     }
 214
 215     # simple cases first
 216     if ($daynames{$day} != $dt->day_of_week) {
 217         # if it's the wrong day of the week, rest doesn't matter
 218         return 0;
 219     }
 220
 221     if (!defined $month) {
 222         # WWdd
 223         return (
 224             ($weekno == 0)    # Every week
 225               || ($dt->weekday_of_month == $weekno)    # this week
 226               || (
 227                 ($weekno >= 97)
 228                 && ($dt->weekday_of_month ==
 229                     nth_week_of_month($dt, $weekno, $day)->weekday_of_month)
 230               )
 231         );
 232     }
 233
 234     # MMWWdd
 235     if ($month != $dt->month) {
 236         # If it's the wrong month, then we're done
 237         return 0;
 238     }
 239
 240     # It's the right day of the week
 241     # It's the right month
 242
 243     if (($weekno == 0) || ($weekno == $dt->weekday_of_month)) {
 244         # If this matches, then we're counting from the beginning
 245         # of the month and it matches and we're done.
 246         return 1;
 247     }
 248
 249     # only case left is that the week number is counting from
 250     # the end of the month: eg, second last wednesday
 251     return (
 252         ($weekno >= 97)
 253           && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month ==
 254             $dt->weekday_of_month)
 255     );
 256 }
 257
 258 sub match_week {
 259     my $pat  = shift;
 260     my @date = @_;
 261     my $dt   = DateTime->new(
 262         year  => $date[0],
 263         month => $date[1],
 264         day   => $date[2]
 265     );
 266
 267     if ($pat =~ m/^$weekpat$daypat$/) {
 268         # WWdd: 03we = Third Wednesday
 269         return check_date($dt, undef, $1, $2);
 270     } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
 271         # MMWWdd: 0599tu Last Tuesday in May XXX WRITE ME
 272         return check_date($dt, $1, $2, $3);
 273     } elsif ($pat =~ m/^$monthpat$weekpat$/) {
 274         # MMWW: 1204: Fourth week in December XXX WRITE ME
 275         return check_date($dt, $1, $2, undef);
 276     } else {
 277         carp "invalid week pattern '$pat'";
 278         return 0;
 279     }
 280 }
 281
 282 #
 283 # Use $pat to calcuate the date of the issue following $cur
 284 #
 285 sub subsequent_week {
 286     my $pat = shift;
 287     my $cur = shift;
 288
 289     my @cur = @$cur;
 290     my $candidate;
 291     my $dt;
 292
 293     #     printf("# subsequent_week('%s', '%s', '%s', '%s')\n", $pat, @cur);
 294
 295     $dt = DateTime->new(
 296         year  => $cur[0],
 297         month => $cur[1],
 298         day   => $cur[2]
 299     );
 300
 301     if ($pat =~ m/^$weekpat$daypat$/o) {
 302         # WWdd: published on given weekday of given week of every month
 303         my ($week, $day) = ($1, $2);
 304
 305         #       printf("# subsequent_week: matched /WWdd/: week='%s', day='%s'\n",
 306         #              $week, $day);
 307
 308         if ($week eq '00') {
 309             # Every week
 310             $candidate = $dt->clone;
 311
 312             if ($dt->day_of_week == $daynames{$day}) {
 313                 # Current is right day, next one is a week hence
 314                 $candidate->add(days => 7);
 315             } else {
 316                 $candidate->add(
 317                     days => ($daynames{$day} - $dt->day_of_week + 7) % 7);
 318             }
 319         } else {
 320             # 3rd Friday of the month (eg)
 321             $candidate = nth_week_of_month($dt, $week, $day);
 322         }
 323
 324         if ($candidate <= $dt) {
 325 # If the n'th week of the month happens on before the
 326 # current issue, then the next issue is published next
 327 # month, otherwise, it's published this month.
 328 # This will never happen for the "00: every week" pattern
 329 #           printf("# subsequent_week: candidate (%s) occurs on or before current date (%s)\n",
 330 #                  join('/', $candidate->year, $candidate->month, $candidate->day),
 331 #                  join('/', $dt->year, $dt->month, $dt->day));
 332             $candidate->set(day => 1);
 333             $candidate->add(months => 1);
 334             $candidate = nth_week_of_month($candidate, $week, $day);
 335         }
 336     } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
 337         # MMWWdd: published on given weekday of given week of given month
 338         my ($month, $week, $day) = ($1, $2, $3);
 339
 340 #       printf("# subsequent_week: matched /MMWWdd/: month='%s', week='%s', day='%s'\n",
 341 #              $month, $week, $day);
 342
 343         $candidate = DateTime->new(
 344             year  => $dt->year,
 345             month => $month,
 346             day   => 1
 347         );
 348         $candidate = nth_week_of_month($candidate, $week, $day);
 349         if ($candidate <= $dt) {
 350             # We've missed it for this year, next one that matches
 351             # will be next year
 352             $candidate->add(years => 1)->set(day => 1);
 353             $candidate = nth_week_of_month($candidate, $week, $day);
 354         }
 355     } elsif ($pat =~ m/^$monthpat$weekpat$/) {
 356         # MMWW: published during given week of given month
 357         my ($month, $week) = ($1, $2);
 358
 359         $candidate = nth_week_of_month(
 360             DateTime->new(
 361                 year  => $dt->year,
 362                 month => $month,
 363                 day   => 1
 364             ),
 365             $week, 'th'
 366         );
 367         if ($candidate <= $dt) {
 368             # Already past the pattern date this year, move to next year
 369             $candidate->add(years => 1)->set(day => 1);
 370             $candidate = nth_week_of_month($candidate, $week, 'th');
 371         }
 372     } else {
 373         carp "invalid week pattern '$pat'";
 374         return undef;
 375     }
 376
 377     $cur[0] = $candidate->year;
 378     $cur[1] = $candidate->month;
 379     $cur[2] = $candidate->day;
 380
 381     foreach my $i (0..$#cur) {
 382         $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
 383     }
 384
 385     return @cur;
 386 }
 387
 388 sub match_month {
 389     my $pat  = shift;
 390     my @date = @_;
 391
 392     return ($pat eq $date[1]);
 393 }
 394
 395 sub subsequent_month {
 396     my $pat = shift;
 397     my $cur = shift;
 398
 399     my @cur = @$cur;
 400
 401     if ($cur[1] >= $pat) {
 402         # Current date is on or after the patter date, so the next
 403         # occurence is next year
 404         $cur[0] += 1;
 405     }
 406
 407     # The year is right, just set the month to the pattern date.
 408     $cur[1] = $pat;
 409
 410     return @cur;
 411 }
 412
 413 sub match_season {
 414     my $pat  = shift;
 415     my @date = @_;
 416
 417     return ($pat eq $date[1]);
 418 }
 419
 420 sub subsequent_season {
 421     my $pat = shift;
 422     my $cur = shift;
 423     my $caption = shift;
 424
 425     my @cur = @$cur;
 426
 427 #     printf("# subsequent_season: pat='%s', cur='%s'\n", $pat, join('/',@cur));
 428
 429     if (($pat < 21) || ($pat > 24)) {
 430         carp "Unexpected season '$pat'";
 431         return undef;
 432     }
 433
 434     if ($caption->winter_starts_year()) {
 435         if ($pat == 24) {
 436             $pat = 20; # fake early winter
 437         }
 438         if ($cur[1] == 24) {
 439             $cur[1] = 20; # fake early winter
 440         }
 441     }
 442
 443     if ($cur[1] >= $pat) {
 444         # current season is on or past pattern season in this year,
 445         # advance to next year
 446         $cur[0] += 1;
 447     }
 448     # Either we've advanced to the next year or the current season
 449     # is before the pattern season in the current year. Either way,
 450     # all that remains is to set the season properly
 451     $cur[1] = $pat;
 452
 453     return @cur;
 454 }
 455
 456 sub match_year {
 457     my $pat  = shift;
 458     my @date = @_;
 459
 460     # XXX WRITE ME
 461     return 0;
 462 }
 463
 464 sub subsequent_year {
 465     my $pat = shift;
 466     my $cur = shift;
 467
 468     my @cur = @$cur;
 469
 470     # XXX WRITE ME
 471     return undef;
 472 }
 473
 474 sub match_issue {
 475     my $pat  = shift;
 476     my @date = @_;
 477
 478     # We handle enumeration patterns separately. This just
 479     # ensures that when we're processing chronological patterns
 480     # we don't match an enumeration pattern.
 481     return 0;
 482 }
 483
 484 sub subsequent_issue {
 485     my $pat = shift;
 486     my $cur = shift;
 487
 488     my @cur = @$cur;
 489
 490     # Issue generation is handled separately
 491     return undef;
 492 }
 493
 494 my %dispatch = (
 495     d => \&match_day,
 496     e => \&match_issue,    # not really a "chron" code
 497     w => \&match_week,
 498     m => \&match_month,
 499     s => \&match_season,
 500     y => \&match_year,
 501 );
 502
 503 my %generators = (
 504     d => \&subsequent_day,
 505     e => \&subsequent_issue,    # not really a "chron" code
 506     w => \&subsequent_week,
 507     m => \&subsequent_month,
 508     s => \&subsequent_season,
 509     y => \&subsequent_year,
 510 );
 511
 512 sub dispatch {
 513     my $chroncode = shift;
 514
 515     return $dispatch{$chroncode};
 516 }
 517
 518 sub generator {
 519     my $chroncode = shift;
 520
 521     return $generators{$chroncode};
 522 }
 523
 524 my %increments = (
 525     a => {years  => 1},     # annual
 526     b => {months => 2},     # bimonthly
 527     c => {days   => 3},     # semiweekly
 528     d => {days   => 1},     # daily
 529     e => {weeks  => 2},     # biweekly
 530     f => {months => 6},     # semiannual
 531     g => {years  => 2},     # biennial
 532     h => {years  => 3},     # triennial
 533     i => {days   => 2},     # three times / week
 534     j => {days   => 10},    # three times /month
 535                             # k => continuous
 536 #    l => {weeks  => 3},     # triweekly (NON-STANDARD)
 537     m => {months => 1},     # monthly
 538     q => {months => 3},     # quarterly
 539     s => {days   => 15},    # semimonthly
 540     t => {months => 4},     # three times / year
 541     w => {weeks  => 1},     # weekly
 542                             # x => completely irregular
 543 );
 544
 545 sub can_increment {
 546     my $freq = shift;
 547
 548     return exists $increments{$freq};
 549 }
 550
 551 # TODO: add support for weeks as chron level?
 552 sub incr_date {
 553     my $freq = shift;
 554     my $incr = $increments{$freq};
 555     my @new  = @_;
 556
 557     if (scalar(@new) == 1) {
 558         # only a year is specified. Next date is easy
 559         $new[0] += $incr->{years} || 1;
 560     } elsif (scalar(@new) == 2) {
 561         # Year and month or season
 562         if ($new[1] > 20) {
 563             # season
 564             $new[1] += ($incr->{months} / 3) || 1;
 565             if ($new[1] > 24) {
 566                 # carry
 567                 $new[0] += 1;
 568                 $new[1] -= 4;    # 25 - 4 == 21 == Spring after Winter
 569             }
 570         } else {
 571             # month
 572             $new[1] += $incr->{months} || 1;
 573             if ($new[1] > 12) {
 574                 # carry
 575                 $new[0] += 1;
 576                 $new[1] -= 12;
 577             }
 578         }
 579     } elsif (scalar(@new) == 3) {
 580         # Year, Month, Day: now it gets complicated.
 581
 582         if ($new[2] =~ /^[0-9]+$/) {
 583             # A single number for the day of month, relatively simple
 584             my $dt = DateTime->new(
 585                 year  => $new[0],
 586                 month => $new[1],
 587                 day   => $new[2]
 588             );
 589             $dt->add(%{$incr});
 590             $new[0] = $dt->year;
 591             $new[1] = $dt->month;
 592             $new[2] = $dt->day;
 593         }
 594     } else {
 595         warn("Don't know how to cope with @new");
 596     }
 597
 598     foreach my $i (0..$#new) {
 599         $new[$i] = '0' . (0 + $new[$i]) if $new[$i] < 10;
 600     }
 601
 602     return @new;
 603 }
 604
 605 1;