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 use OpenILS::Utils::MFHD::Caption;
   9
  10 use base 'Exporter';
  11
  12 our @EXPORT_OK = qw(dispatch generator incr_date can_increment);
  13
  14 my %daynames = (
  15     'mo' => 1,
  16     'tu' => 2,
  17     'we' => 3,
  18     'th' => 4,
  19     'fr' => 5,
  20     'sa' => 6,
  21     'su' => 7,
  22 );
  23
  24 my $daypat  = '(mo|tu|we|th|fr|sa|su)';
  25 my $weekpat = '(99|98|97|00|01|02|03|04|05)';
  26 my $weeknopat;
  27 my $monthpat  = '(01|02|03|04|05|06|07|08|09|10|11|12)';
  28 my $seasonpat = '(21|22|23|24)';
  29
  30 # Initialize $weeknopat to be '(01|02|03|...|51|52|53)'
  31 $weeknopat = '(';
  32 foreach my $weekno (1..52) {
  33     $weeknopat .= sprintf('%02d|', $weekno);
  34 }
  35 $weeknopat .= '53)';
  36
  37 sub match_day {
  38     my $pat  = shift;
  39     my @date = @_;
  40     # Translate daynames into day of week for DateTime
  41     # also used to check if dayname is valid.
  42
  43     if (exists $daynames{$pat}) {
  44         # dd
  45         # figure out day of week for date and compare
  46         my $dt = DateTime->new(
  47             year  => $date[0],
  48             month => $date[1],
  49             day   => $date[2]
  50         );
  51         return ($dt->day_of_week == $daynames{$pat});
  52     } elsif (length($pat) == 2) {
  53         # DD
  54         return $pat == $date[2];
  55     } elsif (length($pat) == 4) {
  56         # MMDD
  57         my ($mon, $day) = unpack("a2a2", $pat);
  58
  59         return (($mon == $date[1]) && ($day == $date[2]));
  60     } else {
  61         carp "Invalid day pattern '$pat'";
  62         return 0;
  63     }
  64 }
  65
  66 # TODO: possible support for extraneous $yp information
  67 # ex. $ypdtu but on a bi-weekly (currently assumes weekly)
  68 sub subsequent_day {
  69     my $pat = shift;
  70     my $cur = shift;
  71
  72     my @cur = @$cur;
  73     my $dt  = DateTime->new(
  74         year  => $cur[0],
  75         month => $cur[1],
  76         day   => $cur[2]
  77     );
  78
  79    #     printf("# subsequent_day: pat='%s' cur='%s'\n", $pat, join('/', @cur));
  80
  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;
  85
  86         if ($dow == $daynames{$pat}) {
  87             # the next one is one week hence
  88             $dt->add(days => 7);
  89         } else {
  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);
  94         }
  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);
 103         } else {
 104             # current date is before $pat: set day to pattern
 105             $cur[2] = $pat;
 106         }
 107     } elsif (length($pat) == 4) {
 108         # MMDD: published on the given day of the given month
 109         my ($mon, $day) = unpack("a2a2", $pat);
 110
 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
 113             $cur[0] += 1;
 114         }
 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
 118         $cur[1] = $mon;
 119         $cur[2] = $day;
 120     } else {
 121         carp "Invalid day pattern '$pat'";
 122         return undef;
 123     }
 124
 125     foreach my $i (0..$#cur) {
 126         $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
 127     }
 128
 129     #     printf("subsequent_day: returning '%s'\n", join('/', @cur));
 130
 131     return @cur;
 132 }
 133
 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 {
 138     my $dt   = shift;
 139     my $week = shift;
 140     my $day  = shift;
 141     my ($nth_day, $dow);
 142
 143     #     printf("# nth_week_of_month(dt, '%s', '%s')\n", $week, $day);
 144
 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(
 149             year  => $dt->year,
 150             month => $dt->month
 151         );
 152     } else {
 153         return undef;
 154     }
 155
 156     $dow = $nth_day->day_of_week();
 157
 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).
 161     if (defined($day)) {
 162         $day = $daynames{$day};
 163     } else {
 164         $day = $dt->day_of_week;
 165     }
 166
 167     if ($week <= 5) {
 168         # count forwards
 169         $nth_day->add(
 170             days  => ($day - $dow + 7) % 7,
 171             weeks => $week - 1
 172         );
 173     } else {
 174         # count backwards
 175         $nth_day->subtract(days => ($day - $dow + 7) % 7);
 176
 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);
 180         }
 181     }
 182
 183     # There is no nth "day" in the month!
 184     return undef if ($dt->month != $nth_day->month);
 185
 186     return $nth_day;
 187 }
 188
 189 #
 190 # Internal utility function to match the various different patterns
 191 # of month, week, and day
 192 #
 193 sub check_date {
 194     my $dt     = shift;
 195     my $month  = shift;
 196     my $weekno = shift;
 197     my $day    = shift;
 198
 199     #     printf("check_date('%s', '%s', '%s')\n", $month, $weekno, $day || '');
 200
 201     if (!defined $day) {
 202         # MMWW
 203         return (
 204             ($dt->month == $month)
 205               && (
 206                 ($dt->week_of_month == $weekno)
 207                 || (
 208                     $weekno >= 97
 209                     && ($dt->week_of_month ==
 210                         nth_week_of_month($dt, $weekno, $day)->week_of_month)
 211                 )
 212               )
 213         );
 214     }
 215
 216     # simple cases first
 217     if ($daynames{$day} != $dt->day_of_week) {
 218         # if it's the wrong day of the week, rest doesn't matter
 219         return 0;
 220     }
 221
 222     if (!defined $month) {
 223         # WWdd
 224         return (
 225             ($weekno == 0)    # Every week
 226               || ($dt->weekday_of_month == $weekno)    # this week
 227               || (
 228                 ($weekno >= 97)
 229                 && ($dt->weekday_of_month ==
 230                     nth_week_of_month($dt, $weekno, $day)->weekday_of_month)
 231               )
 232         );
 233     }
 234
 235     # MMWWdd
 236     if ($month != $dt->month) {
 237         # If it's the wrong month, then we're done
 238         return 0;
 239     }
 240
 241     # It's the right day of the week
 242     # It's the right month
 243
 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.
 247         return 1;
 248     }
 249
 250     # only case left is that the week number is counting from
 251     # the end of the month: eg, second last wednesday
 252     return (
 253         ($weekno >= 97)
 254           && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month ==
 255             $dt->weekday_of_month)
 256     );
 257 }
 258
 259 sub match_week {
 260     my $pat  = shift;
 261     my @date = @_;
 262     my $dt   = DateTime->new(
 263         year  => $date[0],
 264         month => $date[1],
 265         day   => $date[2]
 266     );
 267
 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);
 277     } else {
 278         carp "invalid week pattern '$pat'";
 279         return 0;
 280     }
 281 }
 282
 283 #
 284 # Use $pat to calcuate the date of the issue following $cur
 285 #
 286 sub subsequent_week {
 287     my $pat = shift;
 288     my $cur = shift;
 289
 290     my @cur = @$cur;
 291     my $candidate;
 292     my $dt;
 293
 294     #     printf("# subsequent_week('%s', '%s', '%s', '%s')\n", $pat, @cur);
 295
 296     $dt = DateTime->new(
 297         year  => $cur[0],
 298         month => $cur[1],
 299         day   => $cur[2]
 300     );
 301
 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);
 305
 306         #   printf("# subsequent_week: matched /WWdd/: week='%s', day='%s'\n",
 307         #          $week, $day);
 308
 309         if ($week eq '00') {
 310             # Every week
 311             $candidate = $dt->clone;
 312
 313             if ($dt->day_of_week == $daynames{$day}) {
 314                 # Current is right day, next one is a week hence
 315                 $candidate->add(days => 7);
 316             } else {
 317                 $candidate->add(
 318                     days => ($daynames{$day} - $dt->day_of_week + 7) % 7);
 319             }
 320         } else {
 321             # 3rd Friday of the month (eg)
 322             $candidate = nth_week_of_month($dt, $week, $day);
 323         }
 324
 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);
 336         }
 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);
 340
 341 #   printf("# subsequent_week: matched /MMWWdd/: month='%s', week='%s', day='%s'\n",
 342 #          $month, $week, $day);
 343
 344         $candidate = DateTime->new(
 345             year  => $dt->year,
 346             month => $month,
 347             day   => 1
 348         );
 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
 352             # will be next year
 353             $candidate->add(years => 1)->set(day => 1);
 354             $candidate = nth_week_of_month($candidate, $week, $day);
 355         }
 356     } elsif ($pat =~ m/^$monthpat$weekpat$/) {
 357         # MMWW: published during given week of given month
 358         my ($month, $week) = ($1, $2);
 359
 360         $candidate = nth_week_of_month(
 361             DateTime->new(
 362                 year  => $dt->year,
 363                 month => $month,
 364                 day   => 1
 365             ),
 366             $week, 'th'
 367         );
 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');
 372         }
 373     } else {
 374         carp "invalid week pattern '$pat'";
 375         return undef;
 376     }
 377
 378     $cur[0] = $candidate->year;
 379     $cur[1] = $candidate->month;
 380     $cur[2] = $candidate->day;
 381
 382     foreach my $i (0..$#cur) {
 383         $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
 384     }
 385
 386     return @cur;
 387 }
 388
 389 sub match_month {
 390     my $pat  = shift;
 391     my @date = @_;
 392
 393     return ($pat eq $date[1]);
 394 }
 395
 396 sub subsequent_month {
 397     my $pat = shift;
 398     my $cur = shift;
 399
 400     my @cur = @$cur;
 401
 402     if ($cur[1] >= $pat) {
 403         # Current date is on or after the patter date, so the next
 404         # occurence is next year
 405         $cur[0] += 1;
 406     }
 407
 408     # The year is right, just set the month to the pattern date.
 409     $cur[1] = $pat;
 410
 411     return @cur;
 412 }
 413
 414 sub match_season {
 415     my $pat  = shift;
 416     my @date = @_;
 417
 418     return ($pat eq $date[1]);
 419 }
 420
 421 sub subsequent_season {
 422     my $pat = shift;
 423     my $cur = shift;
 424     my $caption = shift;
 425
 426     my @cur = @$cur;
 427
 428 #     printf("# subsequent_season: pat='%s', cur='%s'\n", $pat, join('/',@cur));
 429
 430     if (($pat < 21) || ($pat > 24)) {
 431         carp "Unexpected season '$pat'";
 432         return undef;
 433     }
 434
 435     if ($caption->winter_starts_year()) {
 436         if ($pat == 24) {
 437             $pat = 20; # fake early winter
 438         }
 439         if ($cur[1] == 24) {
 440             $cur[1] = 20; # fake early winter
 441         }
 442     }
 443
 444     if ($cur[1] >= $pat) {
 445         # current season is on or past pattern season in this year,
 446         # advance to next year
 447         $cur[0] += 1;
 448     }
 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
 452     $cur[1] = $pat;
 453
 454     return @cur;
 455 }
 456
 457 sub match_year {
 458     my $pat  = shift;
 459     my @date = @_;
 460
 461     # XXX WRITE ME
 462     return 0;
 463 }
 464
 465 sub subsequent_year {
 466     my $pat = shift;
 467     my $cur = shift;
 468
 469     my @cur = @$cur;
 470
 471     # XXX WRITE ME
 472     return undef;
 473 }
 474
 475 sub match_issue {
 476     my $pat  = shift;
 477     my @date = @_;
 478
 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.
 482     return 0;
 483 }
 484
 485 sub subsequent_issue {
 486     my $pat = shift;
 487     my $cur = shift;
 488
 489     my @cur = @$cur;
 490
 491     # Issue generation is handled separately
 492     return undef;
 493 }
 494
 495 my %dispatch = (
 496     d => \&match_day,
 497     e => \&match_issue,    # not really a "chron" code
 498     w => \&match_week,
 499     m => \&match_month,
 500     s => \&match_season,
 501     y => \&match_year,
 502 );
 503
 504 my %generators = (
 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,
 511 );
 512
 513 sub dispatch {
 514     my $chroncode = shift;
 515
 516     return $dispatch{$chroncode};
 517 }
 518
 519 sub generator {
 520     my $chroncode = shift;
 521
 522     return $generators{$chroncode};
 523 }
 524
 525 my %increments = (
 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
 536                             # k => continuous
 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
 544 );
 545
 546 sub can_increment {
 547     my $freq = shift;
 548
 549     return exists $increments{$freq};
 550 }
 551
 552 # TODO: add support for weeks as chron level?
 553 sub incr_date {
 554     my $freq = shift;
 555     my $incr = $increments{$freq};
 556     my @new  = @_;
 557
 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
 563         if ($new[1] > 20) {
 564             # season
 565             $new[1] += ($incr->{months} / 3) || 1;
 566             if ($new[1] > 24) {
 567                 # carry
 568                 $new[0] += 1;
 569                 $new[1] -= 4;    # 25 - 4 == 21 == Spring after Winter
 570             }
 571         } else {
 572             # month
 573             $new[1] += $incr->{months} || 1;
 574             if ($new[1] > 12) {
 575                 # carry
 576                 $new[0] += 1;
 577                 $new[1] -= 12;
 578             }
 579         }
 580     } elsif (scalar(@new) == 3) {
 581         # Year, Month, Day: now it gets complicated.
 582
 583         if ($new[2] =~ /^[0-9]+$/) {
 584             # A single number for the day of month, relatively simple
 585             my $dt = DateTime->new(
 586                 year  => $new[0],
 587                 month => $new[1],
 588                 day   => $new[2]
 589             );
 590             $dt->add(%{$incr});
 591             $new[0] = $dt->year;
 592             $new[1] = $dt->month;
 593             $new[2] = $dt->day;
 594         }
 595     } else {
 596         warn("Don't know how to cope with @new");
 597     }
 598
 599     foreach my $i (0..$#new) {
 600         $new[$i] = '0' . (0 + $new[$i]) if $new[$i] < 10;
 601     }
 602
 603     return @new;
 604 }
 605
 606 1;