Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Caption.pm

   1 package MFHD::Caption;
   2 use strict;
   3 use integer;
   4 use Carp;
   5
   6 use Data::Dumper;
   7
   8 use DateTime;
   9
  10 use base 'MARC::Field';
  11
  12 sub new
  13 {
  14     my $proto = shift;
  15     my $class = ref($proto) || $proto;
  16     my $self = shift;
  17     my $last_enum = undef;
  18
  19     $self->{_mfhdc_ENUMS} = {};
  20     $self->{_mfhdc_CHRONS} = {};
  21     $self->{_mfhdc_PATTERN} = {};
  22     $self->{_mfhdc_COPY} = undef;
  23     $self->{_mfhdc_UNIT} = undef;
  24     $self->{_mfhdc_COMPRESSIBLE} = 1;   # until proven otherwise
  25
  26     foreach my $subfield ($self->subfields) {
  27         my ($key, $val) = @$subfield;
  28         if ($key eq '8') {
  29             $self->{LINK} = $val;
  30         } elsif ($key =~ /[a-h]/) {
  31             # Enumeration Captions
  32             $self->{_mfhdc_ENUMS}->{$key} = {CAPTION => $val,
  33                                              COUNT => undef,
  34                                              RESTART => undef};
  35             if ($key =~ /[ag]/) {
  36                 $last_enum = undef;
  37             } else {
  38                 $last_enum = $key;
  39             }
  40         } elsif ($key =~ /[i-m]/) {
  41             # Chronology captions
  42             $self->{_mfhdc_CHRONS}->{$key} = $val;
  43         } elsif ($key eq 'u') {
  44             # Bib units per next higher enumeration level
  45             carp('$u specified for top-level enumeration')
  46               unless defined($last_enum);
  47             $self->{_mfhdc_ENUMS}->{$last_enum}->{COUNT} = $val;
  48         } elsif ($key eq 'v') {
  49             carp '$v specified for top-level enumeration'
  50               unless defined($last_enum);
  51             $self->{_mfhdc_ENUMS}->{$last_enum}->{RESTART} = ($val eq 'r');
  52         } elsif ($key =~ /[npwz]/) {
  53             # Publication Pattern info ('o' == type of unit, 'q'..'t' undefined)
  54             $self->{_mfhdc_PATTERN}->{$key} = $val;
  55         } elsif ($key =~ /x/) {
  56             # Calendar change can have multiple comma-separated values
  57             $self->{_mfhdc_PATTERN}->{x} = [split /,/, $val];
  58         } elsif ($key eq 'y') {
  59             $self->{_mfhdc_PATTERN}->{y} = {}
  60               unless exists $self->{_mfhdc_PATTERN}->{y};
  61             update_pattern($self, $val);
  62         } elsif ($key eq 'o') {
  63             # Type of unit
  64             $self->{_mfhdc_UNIT} = $val;
  65         } elsif ($key eq 't') {
  66             $self->{_mfhdc_COPY} = $val;
  67         } else {
  68             carp "Unknown caption subfield '$key'";
  69         }
  70     }
  71
  72     # subsequent levels of enumeration (primary and alternate)
  73     # If an enumeration level doesn't document the number
  74     # of "issues" per "volume", or whether numbering of issues
  75     # restarts, then we can't compress.
  76     foreach my $key ('b', 'c', 'd', 'e', 'f', 'h') {
  77         if (exists $self->{_mfhdc_ENUMS}->{$key}) {
  78             my $pattern = $self->{_mfhdc_ENUMS}->{$key};
  79             if (!$pattern->{RESTART} || !$pattern->{COUNT}
  80                 || ($pattern->{COUNT} eq 'var')
  81                 || ($pattern->{COUNT} eq 'und')) {
  82                 $self->{_mfhdc_COMPRESSIBLE} = 0;
  83                 last;
  84             }
  85         }
  86     }
  87
  88     my $pat = $self->{_mfhdc_PATTERN};
  89
  90     # Sanity check publication frequency vs publication pattern:
  91     # if the frequency is a number, then the pattern better
  92     # have that number of values associated with it.
  93     if (exists($pat->{w}) && ($pat->{w} =~ /^\d+$/)
  94         && ($pat->{w} != scalar(@{$pat->{y}->{p}}))) {
  95         carp("Caption::new: publication frequency '$pat->{w}' != publication pattern @{$pat->{y}->{p}}");
  96     }
  97
  98
  99     # If there's a $x subfield and a $j, then it's compressible
 100     if (exists $pat->{x} && exists $self->{_mfhdc_CHRONS}->{'j'}) {
 101         $self->{_mfhdc_COMPRESSIBLE} = 1;
 102     }
 103
 104     bless ($self, $class);
 105
 106     return $self;
 107 }
 108
 109 sub update_pattern {
 110     my $self = shift;
 111     my $val = shift;
 112     my $pathash = $self->{_mfhdc_PATTERN}->{y};
 113     my ($pubcode, $pat) = unpack("a1a*", $val);
 114
 115     $pathash->{$pubcode} = [] unless exists $pathash->{$pubcode};
 116     push @{$pathash->{$pubcode}}, $pat;
 117 }
 118
 119 sub decode_pattern {
 120     my $self = shift;
 121     my $pattern = $self->{_mfhdc_PATTERN}->{y};
 122
 123     # XXX WRITE ME (?)
 124 }
 125
 126 sub compressible {
 127     my $self = shift;
 128
 129     return $self->{_mfhdc_COMPRESSIBLE};
 130 }
 131
 132 sub chrons {
 133     my $self = shift;
 134     my $key = shift;
 135
 136     if (exists $self->{_mfhdc_CHRONS}->{$key}) {
 137         return $self->{_mfhdc_CHRONS}->{$key};
 138     } else {
 139         return undef;
 140     }
 141 }
 142
 143 sub capfield {
 144     my $self = shift;
 145     my $key = shift;
 146
 147     if (exists $self->{_mfhdc_ENUMS}->{$key}) {
 148         return $self->{_mfhdc_ENUMS}->{$key};
 149     } elsif (exists $self->{_mfhdc_CHRONS}->{$key}) {
 150         return $self->{_mfhdc_CHRONS}->{$key};
 151     } else {
 152         return undef;
 153     }
 154 }
 155
 156 sub capstr {
 157     my $self = shift;
 158     my $key = shift;
 159     my $val = $self->capfield($key);
 160
 161     if (ref $val) {
 162         return $val->{CAPTION};
 163     } else {
 164         return $val;
 165     }
 166 }
 167
 168 sub calendar_change {
 169     my $self = shift;
 170
 171     return $self->{_mfhdc_PATTERN}->{x};
 172 }
 173
 174 # If items are identified by chronology only, with no separate
 175 # enumeration (eg, a newspaper issue), then the chronology is
 176 # recorded in the enumeration subfields $a - $f.  We can tell
 177 # that this is the case if there are $a - $f subfields and no
 178 # chronology subfields ($i-$k), and none of the $a-$f subfields
 179 # have associated $u or $v subfields, but there's a $w and no $x
 180
 181 sub enumeration_is_chronology {
 182     my $self = shift;
 183
 184     # There is always a '$a' subfield in well-formed fields.
 185     return 0 if exists $self->{_mfhdc_CHRONS}->{i}
 186       || exists $self->{_mfhdc_PATTERN}->{x};
 187
 188     foreach my $key ('a' .. 'f') {
 189         my $enum;
 190
 191         last if !exists $self->{_mfhdc_ENUMS}->{$key};
 192
 193         $enum = $self->{_mfhdc_ENUMS}->{$key};
 194         return 0 if defined $enum->{COUNT} || defined $enum->{RESTART};
 195     }
 196
 197     return (exists $self->{_mfhdc_PATTERN}->{w});
 198 }
 199
 200 my %daynames = (
 201                 'mo' => 1,
 202                 'tu' => 2,
 203                 'we' => 3,
 204                 'th' => 4,
 205                 'fr' => 5,
 206                 'sa' => 6,
 207                 'su' => 7,
 208                );
 209
 210 my $daypat = '(mo|tu|we|th|fr|sa|su)';
 211 my $weekpat = '(99|98|97|00|01|02|03|04|05)';
 212 my $weeknopat;
 213 my $monthpat = '(01|02|03|04|05|06|07|08|09|10|11|12)';
 214 my $seasonpat = '(21|22|23|24)';
 215
 216 # Initialize $weeknopat to be '(01|02|03|...|51|52|53)'
 217 $weeknopat = '(';
 218 foreach my $weekno (1..52) {
 219     $weeknopat .= sprintf('%02d|', $weekno);
 220 }
 221 $weeknopat .= '53)';
 222
 223 sub match_day {
 224     my $pat = shift;
 225     my @date = @_;
 226     # Translate daynames into day of week for DateTime
 227     # also used to check if dayname is valid.
 228
 229     if (exists $daynames{$pat}) {
 230         # dd
 231         # figure out day of week for date and compare
 232         my $dt = DateTime->new(year  => $date[0],
 233                                month => $date[1],
 234                                day   => $date[2]);
 235         return ($dt->day_of_week == $daynames{$pat});
 236     } elsif (length($pat) == 2) {
 237         # DD
 238         return $pat == $date[2];
 239     } elsif (length($pat) == 4) {
 240         # MMDD
 241         my ($mon, $day) = unpack("a2a2", $pat);
 242
 243         return (($mon == $date[1]) && ($day == $date[2]));
 244     } else {
 245         carp "Invalid day pattern '$pat'";
 246         return 0;
 247     }
 248 }
 249
 250 sub subsequent_day {
 251     my $pat = shift;
 252     my $cur = shift;
 253     my $dt = DateTime->new(year  => $cur->[0],
 254                            month => $cur->[1],
 255                            day   => $cur->[2]);
 256
 257     if (exists $daynames{$pat}) {
 258         # dd: published on the given weekday
 259         my $dow = $dt->day_of_week;
 260         my $corr = ($dow - $daynames{$pat} + 7) % 7;
 261
 262         if ($dow == $daynames{$pat}) {
 263             # the next one is one week hence
 264             $dt->add(days => 7);
 265         } else {
 266             # the next one is later this week,
 267             # or it is next week (ie, on or after next Monday)
 268             # $corr will take care of it.
 269             $dt->add(days => $corr);
 270         }
 271     } elsif (length($pat) == 2) {
 272         # DD: published on the give day of every month
 273         if ($dt->day >= $pat) {
 274             # current date is on or after $pat: next one is next month
 275             $dt->set(day => $pat);
 276             $dt->add(months => 1);
 277             $cur->[0] = $dt->year;
 278             $cur->[1] = $dt->month;
 279             $cur->[2] = $dt->day;
 280         }
 281         # current date is before $pat: set month to pattern
 282         # or we've adjusted the year to next year, now fix the month
 283         $cur->[1] = $pat;
 284     } elsif (length($pat) == 4) {
 285         # MMDD: published on the given day of the given month
 286         my ($mon, $day) = unpack("a2a2", $pat);
 287
 288         if (on_or_after($mon, $day, $cur->[1], $cur->[2])) {
 289             # Current date is on or after pattern; next one is next year
 290             $cur->[0] += 1;
 291         }
 292         # Year is now right. Either it's next year (because of on_or_before)
 293         # or it's this year, because the current date is NOT on or after
 294         # the pattern. Just fix the month and day
 295         $cur->[1] = $mon;
 296         $cur->[2] = $day;
 297     } else {
 298         carp "Invalid day pattern '$pat'";
 299         return undef;
 300     }
 301
 302     return $cur;
 303 }
 304
 305
 306 # Calculate date of 3rd Friday of the month (for example)
 307 # 1-5: count from beginning of month
 308 # 99-97: count back from end of month
 309 sub nth_week_of_month {
 310     my $dt = shift;
 311     my $week = shift;
 312     my $day = shift;
 313     my ($nth_day, $dow, $day);
 314
 315     $day = $daynames{$day};
 316
 317     if (0 < $week && $week <= 5) {
 318         $nth_day = DateTime->clone($dt)->set(day => 1);
 319     } elsif ($week >= 97) {
 320         $nth_day = DateTime->last_day_of_month(year  => $dt->year,
 321                                                month => $dt->month);
 322     } else {
 323         return undef;
 324     }
 325
 326     $dow = $nth_day->day_of_week();
 327
 328     if ($week <= 5) {
 329         # count forwards
 330         $nth_day->add(days => ($day - $dow + 7) % 7,
 331                       weeks=> $week - 1);
 332     } else {
 333         # count backwards
 334         $nth_day->subtract(days => ($day - $nth_day->day_of_week + 7) % 7);
 335
 336         # 99: last week of month, 98: second last, etc.
 337         for (my $i = 99 - $week; $i > 0; $i--) {
 338             $nth_day->subtract(weeks => 1);
 339         }
 340     }
 341
 342     # There is no nth "day" in the month!
 343     return undef if ($dt->month != $nth_day->month);
 344
 345     return $nth_day;
 346 }
 347
 348 #
 349 # Internal utility function to match the various different patterns
 350 # of month, week, and day
 351 #
 352 sub check_date {
 353     my $dt = shift;
 354     my $month = shift;
 355     my $weekno = shift;
 356     my $day = shift;
 357
 358     if (!defined $day) {
 359         # MMWW
 360         return (($dt->month == $month)
 361                 && (($dt->week_of_month == $weekno)
 362                     || ($weekno >= 97
 363                         && ($dt->week_of_month == nth_week_of_month($dt, $weekno, $day)->week_of_month))));
 364     }
 365
 366     # simple cases first
 367     if ($daynames{$day} != $dt->day_of_week) {
 368         # if it's the wrong day of the week, rest doesn't matter
 369         return 0;
 370     }
 371
 372     if (!defined $month) {
 373         # WWdd
 374         return (($weekno == 0)  # Every week
 375                 || ($dt->weekday_of_month == $weekno) # this week
 376                 || (($weekno >= 97) && ($dt->weekday_of_month == nth_week_of_month($dt, $weekno, $day)->weekday_of_month)));
 377     }
 378
 379     # MMWWdd
 380     if ($month != $dt->month) {
 381         # If it's the wrong month, then we're done
 382         return 0;
 383     }
 384
 385     # It's the right day of the week
 386     # It's the right month
 387
 388     if (($weekno == 0) ||($weekno == $dt->weekday_of_month)) {
 389         # If this matches, then we're counting from the beginning
 390         # of the month and it matches and we're done.
 391         return 1;
 392     }
 393
 394     # only case left is that the week number is counting from
 395     # the end of the month: eg, second last wednesday
 396     return (($weekno >= 97)
 397             && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month == $dt->weekday_of_month));
 398 }
 399
 400 sub match_week {
 401     my $pat = shift;
 402     my @date = @_;
 403     my $dt = DateTime->new(year  => $date[0],
 404                            month => $date[1],
 405                            day   => $date[2]);
 406
 407     if ($pat =~ m/^$weekpat$daypat$/) {
 408         # WWdd: 03we = Third Wednesday
 409         return check_date($dt, undef, $1, $2);
 410     } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
 411         # MMWWdd: 0599tu Last Tuesday in May XXX WRITE ME
 412         return check_date($dt, $1, $2, $3);
 413     } elsif ($pat =~ m/^$monthpat$weekpat$/) {
 414         # MMWW: 1204: Fourth week in December XXX WRITE ME
 415         return check_date($dt, $1, $2, undef);
 416     } else {
 417         carp "invalid week pattern '$pat'";
 418         return 0;
 419     }
 420 }
 421
 422 #
 423 # Use $pat to calcuate the date of the issue following $cur
 424 #
 425 sub subsequent_week {
 426     my $pat = shift;
 427     my $cur = shift;
 428     my $candidate;
 429     my $dt = DateTime->new(year => $cur->[0],
 430                            month=> $cur->[1],
 431                            day  => $cur->[2]);
 432
 433     if ($pat =~ m/^$weekpat$daypat$/) {
 434         # WWdd: published on given weekday of given week of every month
 435         my ($week, $day) = ($1, $2);
 436
 437         if ($week eq '00') {
 438             # Every week
 439             $candidate = DateTime->clone($dt);
 440             if ($dt->day_of_week == $daynames{$day}) {
 441                 # Current is right day, next one is a week hence
 442                 $candidate->add(days => 7);
 443             } else {
 444                 $candidate->add(days => ($dt->day_of_week - $daynames{$day} + 7) % 7);
 445             }
 446         } else {
 447             # 3rd Friday of the month (eg)
 448             $candidate = nth_week_of_month($dt, $week, $day);
 449         }
 450
 451         if ($candidate < $dt) {
 452             # If the n'th week of the month happens before the
 453             # current issue, then the next issue is published next
 454             # month, otherwise, it's published this month.
 455             # This will never happen for the "00: every week" pattern
 456             $candidate = DateTime->clone($dt)->add(months => 1)->set(day => 1);
 457             $candidate = nth_week_of_month($dt, $week, $day);
 458         }
 459     } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
 460         # MMWWdd: published on given weekday of given week of given month
 461         my ($month, $week, $day) = ($1, $2, $3);
 462
 463         $candidate = DateTime->new(year => $dt->year,
 464                                    month=> $month,
 465                                    day  => 1);
 466         $candidate = nth_week_of_month($candidate, $week, $day);
 467         if ($candidate < $dt) {
 468             # We've missed it for this year, next one that matches
 469             # will be next year
 470             $candidate->add(years => 1)->set(day => 1);
 471             $candidate = nth_week_of_month($candidate, $week, $day);
 472         }
 473     } elsif ($pat =~ m/^$monthpat$weekpat$/) {
 474         # MMWW: published during given week of given month
 475         my ($month, $week) = ($1, $2);
 476
 477         $candidate = nth_week_of_month(DateTime->new(year => $dt->year,
 478                                                      month=> $month,
 479                                                      day  => 1),
 480                                        $week,
 481                                        'th');
 482         if ($candidate < $dt) {
 483             # Already past the pattern date this year, move to next year
 484             $candidate->add(years => 1)->set(day => 1);
 485             $candidate = nth_week_of_month($candidate, $week, 'th');
 486         }
 487     } else {
 488         carp "invalid week pattern '$pat'";
 489         return undef;
 490     }
 491
 492     $cur->[0] = $candidate->year;
 493     $cur->[1] = $candidate->month;
 494     $cur->[2] = $candidate->day;
 495
 496     return $cur;
 497 }
 498
 499 sub match_month {
 500     my $pat = shift;
 501     my @date = @_;
 502
 503     return ($pat eq $date[1]);
 504 }
 505
 506 sub match_season {
 507     my $pat = shift;
 508     my @date = @_;
 509
 510     return ($pat eq $date[1]);
 511 }
 512
 513 sub subsequent_season {
 514     my $pat = shift;
 515     my $cur = shift;
 516
 517     return undef if (($pat < 21) || ($pat > 24));
 518
 519     if ($cur->[1] >= $pat) {
 520         # current season is on or past pattern season in this year,
 521         # advance to next year
 522         $cur->[0] += 1;
 523     }
 524     # Either we've advanced to the next year or the current season
 525     # is before the pattern season in the current year. Either way,
 526     # all that remains is to set the season properly
 527     $cur->[1] = $pat;
 528
 529     return $cur;
 530 }
 531
 532 sub match_year {
 533     my $pat = shift;
 534     my @date = @_;
 535
 536     # XXX WRITE ME
 537     return 0;
 538 }
 539
 540 sub subsequent_year {
 541     my $pat = shift;
 542     my $cur = shift;
 543
 544     # XXX WRITE ME
 545     return undef;
 546 }
 547
 548 sub match_issue {
 549     my $pat = shift;
 550     my @date = @_;
 551
 552     # We handle enumeration patterns separately. This just
 553     # ensures that when we're processing chronological patterns
 554     # we don't match an enumeration pattern.
 555     return 0;
 556 }
 557
 558 sub subsequent_issue {
 559     my $pat = shift;
 560     my $cur = shift;
 561
 562     # Issue generation is handled separately
 563     return undef;
 564 }
 565
 566 my %dispatch = (
 567                 'd' => \&match_day,
 568                 'e' => \&match_issue, # not really a "chron" code
 569                 'w' => \&match_week,
 570                 'm' => \&match_month,
 571                 's' => \&match_season,
 572                 'y' => \&match_year,
 573 );
 574
 575 sub regularity_match {
 576     my $self = shift;
 577     my $pubcode = shift;
 578     my @date = @_;
 579
 580     # we can't match something that doesn't exist.
 581     return 0 if !exists $self->{_mfhdc_PATTERN}->{y}->{$pubcode};
 582
 583     foreach my $regularity (@{$self->{_mfhdc_PATTERN}->{y}->{$pubcode}}) {
 584         my $chroncode= substr($regularity, 0, 1);
 585         my @pats = split(/,/, substr($regularity, 1));
 586
 587         if (!exists $dispatch{$chroncode}) {
 588             carp "Unrecognized chroncode '$chroncode'";
 589             return 0;
 590         }
 591
 592         # XXX WRITE ME
 593         foreach my $pat (@pats) {
 594             $pat =~ s|/.+||;    # If it's a combined date, match the start
 595             if ($dispatch{$chroncode}->($pat, @date)) {
 596                 return 1;
 597             }
 598         }
 599     }
 600
 601     return 0;
 602 }
 603
 604 sub is_omitted {
 605     my $self = shift;
 606     my @date = @_;
 607
 608     return $self->regularity_match('o', @date);
 609 }
 610
 611 sub is_published {
 612     my $self = shift;
 613     my @date = @_;
 614
 615     return $self->regularity_match('p', @date);
 616 }
 617
 618 sub is_combined {
 619     my $self = shift;
 620     my @date = @_;
 621
 622     return $self->regularity_match('c', @date);
 623 }
 624
 625 sub enum_is_combined {
 626     my $self = shift;
 627     my $subfield = shift;
 628     my $iss = shift;
 629     my $level = ord($subfield) - ord('a') + 1;
 630
 631     return 0 if !exists $self->{_mfhdc_PATTERN}->{y}->{c};
 632
 633     foreach my $regularity (@{$self->{_mfhdc_PATTERN}->{y}->{c}}) {
 634         next unless $regularity =~ m/^e$level/o;
 635
 636         my @pats = split(/,/, substr($regularity, 2));
 637
 638         foreach my $pat (@pats) {
 639             $pat =~ s|/.+||;    # if it's a combined issue, match the start
 640             return 1 if ($iss eq $pat);
 641         }
 642     }
 643
 644     return 0;
 645 }
 646
 647
 648 my %increments = (
 649                   a => {years => 1}, # annual
 650                   b => {months => 2}, # bimonthly
 651                   c => {days => 3}, # semiweekly
 652                   d => {days => 1}, # daily
 653                   e => {weeks => 2}, # biweekly
 654                   f => {months => 6}, # semiannual
 655                   g => {years => 2},  # biennial
 656                   h => {years => 3},  # triennial
 657                   i => {days => 2}, # three times / week
 658                   j => {days => 10}, # three times /month
 659                   # k => continuous
 660                   m => {months => 1}, # monthly
 661                   q => {months => 3}, # quarterly
 662                   s => {days => 15},  # semimonthly
 663                   t => {months => 4}, # three times / year
 664                   w => {weeks => 1},  # weekly
 665                   # x => completely irregular
 666 );
 667
 668 sub incr_date {
 669     my $incr = shift;
 670     my @new = @_;
 671
 672     if (scalar(@new) == 1) {
 673         # only a year is specified. Next date is easy
 674         $new[0] += $incr->{years} || 1;
 675     } elsif (scalar(@new) == 2) {
 676         # Year and month or season
 677         if ($new[1] > 20) {
 678             # season
 679             $new[1] += ($incr->{months}/3) || 1;
 680             if ($new[1] > 24) {
 681                 # carry
 682                 $new[0] += 1;
 683                 $new[1] -= 4;   # 25 - 4 == 21 == Spring after Winter
 684             }
 685         } else {
 686             # month
 687             $new[1] += $incr->{months} || 1;
 688             if ($new[1] > 12) {
 689                 # carry
 690                 $new[0] += 1;
 691                 $new[1] -= 12;
 692             }
 693             $new[1] = '0' . $new[1] if ($new[1] < 10);
 694         }
 695     } elsif (scalar(@new) == 3) {
 696         # Year, Month, Day: now it gets complicated.
 697
 698         if ($new[2] =~ /^[0-9]+$/) {
 699             # A single number for the day of month, relatively simple
 700             my $dt = DateTime->new(year => $new[0],
 701                                    month=> $new[1],
 702                                    day  => $new[2]);
 703             $dt->add(%{$incr});
 704             $new[0] = $dt->year;
 705             $new[1] = $dt->month;
 706             $new[2] = $dt->day;
 707         }
 708         $new[1] = '0' . $new[1] if ($new[1] < 10);
 709         $new[2] = '0' . $new[2] if ($new[2] < 10);
 710     } else {
 711         warn("Don't know how to cope with @new");
 712     }
 713
 714     return @new;
 715 }
 716
 717 # Test to see if $m1/$d1 is on or after $m2/$d2
 718 # if $d2 is undefined, test is based on just months
 719 sub on_or_after {
 720     my ($m1, $d1, $m2, $d2) = @_;
 721
 722     return (($m1 > $m2)
 723             || ($m1 == $m2 && ((!defined $d2) || ($d1 >= $d2))));
 724 }
 725
 726 sub calendar_increment {
 727     my $self = shift;
 728     my $cur = shift;
 729     my @new = @_;
 730     my $cal_change = $self->calendar_change;
 731     my $month;
 732     my $day;
 733     my $cur_before;
 734     my $new_on_or_after;
 735
 736     # A calendar change is defined, need to check if it applies
 737     if ((scalar(@new) == 2 && $new[1] > 20) || (scalar(@new) == 1)) {
 738         carp "Can't calculate date change for ", $self->as_string;
 739         return;
 740     }
 741
 742     foreach my $change (@{$cal_change}) {
 743         my $incr;
 744
 745         if (length($change) == 2) {
 746             $month = $change;
 747         } elsif (length($change) == 4) {
 748             ($month, $day) = unpack("a2a2", $change);
 749         }
 750
 751         if ($cur->[0] == $new[0]) {
 752             # Same year, so a 'simple' month/day comparison will be fine
 753             $incr = (!on_or_after($cur->[1], $cur->[2], $month, $day)
 754                      && on_or_after($new[1], $new[2], $month, $day));
 755         } else {
 756             # @cur is in the year before @new. There are
 757             # two possible cases for the calendar change date that
 758             # indicate that it's time to change the volume:
 759             # (1) the change date is AFTER @cur in the year, or
 760             # (2) the change date is BEFORE @new in the year.
 761             #
 762             #  -------|------|------X------|------|
 763             #       @cur    (1)   Jan 1   (2)   @new
 764
 765             $incr = (on_or_after($new[1], $new[2], $month, $day)
 766                      || !on_or_after($cur->[1], $cur->[2], $month, $day));
 767         }
 768         return $incr if $incr;
 769     }
 770 }
 771
 772 my %generators = (
 773                   'd' => \&subsequent_day,
 774                   'e' => \&subsequent_issue, # not a chron code
 775                   'w' => \&subsequent_week,
 776                   'm' => \&subsequent_month,
 777                   's' => \&subsequent_season,
 778                   'y' => \&subsequent_year,
 779 );
 780
 781 sub next_date {
 782     my $self = shift;
 783     my $next = shift;
 784     my $carry = shift;
 785     my @keys = @_;
 786     my @cur;
 787     my @new;
 788     my $incr;
 789     my @candidate;
 790
 791     my $reg = $self->{_mfhdc_REGULARITY};
 792     my $pattern = $self->{_mfhdc_PATTERN};
 793     my $freq = $pattern->{w};
 794
 795     foreach my $i (0..$#keys) {
 796         $new[$i] = $cur[$i] = $next->{$keys[$i]} if exists $next->{$keys[$i]};
 797     }
 798
 799     # If the current issue has a combined date (eg, May/June)
 800     # get rid of the first date and base the calculation
 801     # on the final date in the combined issue.
 802     $new[-1] =~ s|^[^/]+/||;
 803
 804     # XXX Insert new date generation code in here that uses publication
 805     # patterns.
 806
 807 ###
 808 ### Old code: only works for simple cases
 809 ###
 810     # If $frequency is not one of the standard codes defined in %increments
 811     # then there has to be a $yp publication regularity pattern that
 812     # lists the dates of publication. Use that that list to find the next
 813     # date following the current one.
 814     # XXX: the code doesn't handle this case yet.
 815     if (!defined($freq)) {
 816         carp "Undefined frequency in next_date!";
 817     } elsif (!exists $increments{$freq}) {
 818         carp "Don't know how to deal with frequency '$freq'!";
 819     } else {
 820         #
 821         # One of the standard defined issue frequencies
 822         #
 823         @new = incr_date($increments{$freq}, @new);
 824
 825         while ($self->is_omitted(@new)) {
 826             @new = incr_date($increments{$freq}, @new);
 827         }
 828
 829         if ($self->is_combined(@new)) {
 830             my @second_date = incr_date($increments{$freq}, @new);
 831
 832             # I am cheating: This code assumes that only the smallest
 833             # time increment is combined. So, no "Apr 15/May 1" allowed.
 834             $new[-1] = $new[-1] . '/' . $second_date[-1];
 835         }
 836     }
 837
 838     for my $i (0..$#new) {
 839         $next->{$keys[$i]} = $new[$i];
 840     }
 841
 842     # Figure out if we need to adust volume number
 843     # right now just use the $carry that was passed in.
 844     # in long run, need to base this on ($carry or date_change)
 845     if ($carry) {
 846         # if $carry is set, the date doesn't matter: we're not
 847         # going to increment the v. number twice at year-change.
 848         $next->{a} += $carry;
 849     } elsif (defined $pattern->{x}) {
 850         $next->{a} += $self->calendar_increment(\@cur, @new);
 851     }
 852 }
 853
 854 sub next_alt_enum {
 855     my $self = shift;
 856     my $next = shift;
 857
 858     # First handle any "alternative enumeration", since they're
 859     # a lot simpler, and don't depend on the the calendar
 860     foreach my $key ('h', 'g') {
 861         next if !exists $next->{$key};
 862         if (!$self->capstr($key)) {
 863             warn "Holding data exists for $key, but no caption specified";
 864             $next->{$key} += 1;
 865             last;
 866         }
 867
 868         my $cap = $self->capfield($key);
 869         if ($cap->{RESTART} && $cap->{COUNT}
 870             && ($next->{$key} == $cap->{COUNT})) {
 871             $next->{$key} = 1;
 872         } else {
 873             $next->{$key} += 1;
 874             last;
 875         }
 876     }
 877 }
 878
 879 sub next_enum {
 880     my $self = shift;
 881     my $next = shift;
 882     my $carry;
 883
 884     # $carry keeps track of whether we need to carry into the next
 885     # higher level of enumeration. It's not actually necessary except
 886     # for when the loop ends: if we need to carry from $b into $a
 887     # then $carry will be set when the loop ends.
 888     #
 889     # We need to keep track of this because there are two different
 890     # reasons why we might increment the highest level of enumeration ($a)
 891     # 1) we hit the correct number of items in $b (ie, 5th iss of quarterly)
 892     # 2) it's the right time of the year.
 893     #
 894     $carry = 0;
 895     foreach my $key (reverse('b'..'f')) {
 896         next if !exists $next->{$key};
 897
 898         if (!$self->capstr($key)) {
 899             # Just assume that it increments continuously and give up
 900             warn "Holding data exists for $key, but no caption specified";
 901             $next->{$key} += 1;
 902             $carry = 0;
 903             last;
 904         }
 905
 906         # If the current issue has a combined issue number (eg, 2/3)
 907         # get rid of the first issue number and base the calculation
 908         # on the final issue number in the combined issue.
 909         if ($next->{$key} =~ m|/|) {
 910             $next->{$key} =~ s|^[^/]+/||;
 911         }
 912
 913         my $cap = $self->capfield($key);
 914         if ($cap->{RESTART} && $cap->{COUNT}
 915             && ($next->{$key} eq $cap->{COUNT})) {
 916             $next->{$key} = 1;
 917             $carry = 1;
 918         } else {
 919             # If I don't need to "carry" beyond here, then I just increment
 920             # this level of the enumeration and stop looping, since the
 921             # "next" hash has been initialized with the current values
 922
 923             $next->{$key} += 1;
 924             $carry = 0;
 925         }
 926
 927         # You can't have a combined issue that spans two volumes: no.12/1
 928         # is forbidden
 929         if ($self->enum_is_combined($key, $next->{$key})) {
 930             $next->{$key} .= '/' . ($next->{$key} + 1);
 931         }
 932
 933         last if !$carry;
 934     }
 935
 936     # The easy part is done. There are two things left to do:
 937     # 1) Calculate the date of the next issue, if necessary
 938     # 2) Increment the highest level of enumeration (either by date
 939     #    or because $carry is set because of the above loop
 940
 941     if (!$self->subfield('i')) {
 942         # The simple case: if there is no chronology specified
 943         # then just check $carry and return
 944         $next->{'a'} += $carry;
 945     } else {
 946         # Figure out date of next issue, then decide if we need
 947         # to adjust top level enumeration based on that
 948         $self->next_date($next, $carry, ('i'..'m'));
 949     }
 950 }
 951
 952 sub next {
 953     my $self = shift;
 954     my $holding = shift;
 955     my $next = {};
 956
 957     # Initialize $next with current enumeration & chronology, then
 958     # we can just operate on $next, based on the contents of the caption
 959
 960     if ($self->enumeration_is_chronology) {
 961         foreach my $key ('a' .. 'h') {
 962             $next->{$key} = $holding->{_mfhdh_SUBFIELDS}->{$key}
 963               if defined $holding->{_mfhdh_SUBFIELDS}->{$key};
 964         }
 965         $self->next_date($next, 0, ('a' .. 'h'));
 966
 967         return $next;
 968     }
 969
 970     foreach my $key ('a' .. 'h') {
 971         $next->{$key} = $holding->{_mfhdh_SUBFIELDS}->{$key}->{HOLDINGS}
 972           if defined $holding->{_mfhdh_SUBFIELDS}->{$key};
 973     }
 974
 975     foreach my $key ('i'..'m') {
 976         $next->{$key} = $holding->{_mfhdh_SUBFIELDS}->{$key}
 977           if defined $holding->{_mfhdh_SUBFIELDS}->{$key};
 978     }
 979
 980     if (exists $next->{'h'}) {
 981         $self->next_alt_enum($next);
 982     }
 983
 984     $self->next_enum($next);
 985
 986     return($next);
 987 }
 988
 989 1;