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 DateTime;
   7
   8 use base 'MARC::Field';
   9
  10 sub new
  11 {
  12     my $proto = shift;
  13     my $class = ref($proto) || $proto;
  14     my $self = shift;
  15     my $last_enum = undef;
  16
  17     $self->{_mfhdc_ENUMS} = {};
  18     $self->{_mfhdc_CHRONS} = {};
  19     $self->{_mfhdc_PATTERN} = {};
  20     $self->{_mfhdc_COPY} = undef;
  21     $self->{_mfhdc_UNIT} = undef;
  22     $self->{_mfhdc_COMPRESSIBLE} = 1;   # until proven otherwise
  23
  24     foreach my $subfield ($self->subfields) {
  25         my ($key, $val) = @$subfield;
  26         if ($key eq '8') {
  27             $self->{LINK} = $val;
  28         } elsif ($key =~ /[a-h]/) {
  29             # Enumeration Captions
  30             $self->{_mfhdc_ENUMS}->{$key} = {CAPTION => $val,
  31                                              COUNT => undef,
  32                                              RESTART => undef};
  33             if ($key =~ /[ag]/) {
  34                 $last_enum = undef;
  35             } else {
  36                 $last_enum = $key;
  37             }
  38         } elsif ($key =~ /[i-m]/) {
  39             # Chronology captions
  40             $self->{_mfhdc_CHRONS}->{$key} = $val;
  41         } elsif ($key eq 'u') {
  42             # Bib units per next higher enumeration level
  43             carp('$u specified for top-level enumeration')
  44               unless defined($last_enum);
  45             $self->{_mfhdc_ENUMS}->{$last_enum}->{COUNT} = $val;
  46         } elsif ($key eq 'v') {
  47             carp '$v specified for top-level enumeration'
  48               unless defined($last_enum);
  49             $self->{_mfhdc_ENUMS}->{$last_enum}->{RESTART} = ($val eq 'r');
  50         } elsif ($key =~ /[npwz]/) {
  51             # Publication Pattern info ('o' == type of unit, 'q'..'t' undefined)
  52             $self->{_mfhdc_PATTERN}->{$key} = $val;
  53         } elsif ($key =~ /x/) {
  54             # Calendar change can have multiple comma-separated values
  55             $self->{_mfhdc_PATTERN}->{x} = [split /,/, $val];
  56         } elsif ($key eq 'y') {
  57             # Publication pattern: 'y' is repeatable
  58             $self->{_mfhdc_PATTERN}->{y} = [] if (!defined $self->{_mfhdc_PATTERN}->{y});
  59             push @{$self->{_mfhdc_PATTERN}->{y}}, $val;
  60         } elsif ($key eq 'o') {
  61             # Type of unit
  62             $self->{_mfhdc_UNIT} = $val;
  63         } elsif ($key eq 't') {
  64             $self->{_mfhdc_COPY} = $val;
  65         } else {
  66             carp "Unknown caption subfield '$key'";
  67         }
  68     }
  69
  70     # subsequent levels of enumeration (primary and alternate)
  71     # If an enumeration level doesn't document the number
  72     # of "issues" per "volume", or whether numbering of issues
  73     # restarts, then we can't compress.
  74     foreach my $key ('b', 'c', 'd', 'e', 'f', 'h') {
  75         if (exists $self->{_mfhdc_ENUMS}->{$key}) {
  76             my $pattern = $self->{_mfhdc_ENUMS}->{$key};
  77             if (!$pattern->{RESTART} || !$pattern->{COUNT}
  78                 || ($pattern->{COUNT} eq 'var')
  79                 || ($pattern->{COUNT} eq 'und')) {
  80                 $self->{_mfhdc_COMPRESSIBLE} = 0;
  81                 last;
  82             }
  83         }
  84     }
  85
  86     # If there's a $x subfield and a $j, then it's compressible
  87     if (exists $self->{_mfhdc_PATTERN}->{x} && exists $self->{_mfhdc_CHRONS}->{'j'}) {
  88         $self->{_mfhdc_COMPRESSIBLE} = 1;
  89     }
  90
  91     bless ($self, $class);
  92
  93     if (exists $self->{_mfhdc_PATTERN}->{y}) {
  94         $self->decode_pattern;
  95     }
  96
  97     return $self;
  98 }
  99
 100 sub decode_pattern {
 101     my $self = shift;
 102     my $pattern = $self->{_mfhdc_PATTERN}->{y};
 103
 104     # XXX WRITE ME (?)
 105 }
 106
 107 sub compressible {
 108     my $self = shift;
 109
 110     return $self->{_mfhdc_COMPRESSIBLE};
 111 }
 112
 113 sub chrons {
 114     my $self = shift;
 115     my $key = shift;
 116
 117     if (exists $self->{_mfhdc_CHRONS}->{$key}) {
 118         return $self->{_mfhdc_CHRONS}->{$key};
 119     } else {
 120         return undef;
 121     }
 122 }
 123
 124 sub capfield {
 125     my $self = shift;
 126     my $key = shift;
 127
 128     if (exists $self->{_mfhdc_ENUMS}->{$key}) {
 129         return $self->{_mfhdc_ENUMS}->{$key};
 130     } elsif (exists $self->{_mfhdc_CHRONS}->{$key}) {
 131         return $self->{_mfhdc_CHRONS}->{$key};
 132     } else {
 133         return undef;
 134     }
 135 }
 136
 137 sub capstr {
 138     my $self = shift;
 139     my $key = shift;
 140     my $val = $self->capfield($key);
 141
 142     if (ref $val) {
 143         return $val->{CAPTION};
 144     } else {
 145         return $val;
 146     }
 147 }
 148
 149 sub calendar_change {
 150     my $self = shift;
 151
 152     return $self->{_mfhdc_PATTERN}->{x};
 153 }
 154
 155 # If items are identified by chronology only, with no separate
 156 # enumeration (eg, a newspaper issue), then the chronology is
 157 # recorded in the enumeration subfields $a - $f.  We can tell
 158 # that this is the case if there are $a - $f subfields and no
 159 # chronology subfields ($i-$k), and none of the $a-$f subfields
 160 # have associated $u or $v subfields, but there's a $w and no $x
 161
 162 sub enumeration_is_chronology {
 163     my $self = shift;
 164
 165     # There is always a '$a' subfield in well-formed fields.
 166     return 0 if exists $self->{_mfhdc_CHRONS}->{i}
 167       || exists $self->{_mfhdc_PATTERN}->{x};
 168
 169     foreach my $key ('a' .. 'f') {
 170         my $enum;
 171
 172         last if !exists $self->{_mfhdc_ENUMS}->{$key};
 173
 174         $enum = $self->{_mfhdc_ENUMS}->{$key};
 175         return 0 if defined $enum->{COUNT} || defined $enum->{RESTART};
 176     }
 177
 178     return (exists $self->{_mfhdc_PATTERN}->{w});
 179 }
 180
 181 my %daynames = (
 182                 'mo' => 1,
 183                 'tu' => 2,
 184                 'we' => 3,
 185                 'th' => 4,
 186                 'fr' => 5,
 187                 'sa' => 6,
 188                 'su' => 7,
 189                );
 190
 191 my $daypat = '(mo|tu|we|th|fr|sa|su)';
 192 my $weekpat = '(99|98|97|00|01|02|03|04|05)';
 193 my $weeknopat;
 194 my $monthpat = '(01|02|03|04|05|06|07|08|09|10|11|12)';
 195 my $seasonpat = '(21|22|23|24)';
 196
 197 # Initialize $weeknopat to be '(01|02|03|...|51|52|53)'
 198 $weeknopat = '(';
 199 foreach my $weekno (1..52) {
 200     $weeknopat .= sprintf('%02d|', $weekno);
 201 }
 202 $weeknopat .= '53)';
 203
 204 sub match_day {
 205     my $pat = shift;
 206     my @date = @_;
 207     # Translate daynames into day of week for DateTime
 208     # also used to check if dayname is valid.
 209
 210     if (exists $daynames{$pat}) {
 211         # dd
 212         # figure out day of week for date and compare
 213         my $dt = DateTime->new(year  => $date[0],
 214                                month => $date[1],
 215                                day   => $date[2]);
 216         return ($dt->day_of_week == $daynames{$pat});
 217     } elsif (length($pat) == 2) {
 218         # MM
 219         return $pat == $date[3];
 220     } elsif (length($pat) == 4) {
 221         # MMDD
 222         my ($mon, $day);
 223         $mon = substr($pat, 0, 2);
 224         $day = substr($pat, 2, 2);
 225
 226         return (($mon == $date[1]) && ($day == $date[2]));
 227     } else {
 228         carp "Invalid day pattern '$pat'";
 229         return 0;
 230     }
 231 }
 232
 233 # Calcuate date of "n"th last "dayname" of month: second last Tuesday
 234 sub last_week_of_month {
 235     my $dt = shift;
 236     my $week = shift;
 237     my $day = shift;
 238     my $end_dt = DateTime->last_day_of_month(year  => $dt->year,
 239                                              month => $dt->month);
 240
 241     $day = $daynames{$day};
 242     while ($end_dt->day_of_week != $day) {
 243         $end_dt->subtract(days => 1);
 244     }
 245
 246     # 99: last week of month, 98: second last, etc.
 247     for (my $i = 99 - $week; $i > 0; $i--) {
 248         $end_dt->subtract(weeks => 1);
 249     }
 250
 251     return $end_dt;
 252 }
 253
 254 sub check_date {
 255     my $dt = shift;
 256     my $month = shift;
 257     my $weekno = shift;
 258     my $day = shift;
 259
 260     if (!defined $day) {
 261         # MMWW
 262         return (($dt->month == $month)
 263                 && (($dt->week_of_month == $weekno)
 264                     || ($dt->week_of_month == last_day_of_month($dt, $weekno, 'th')->week_of_month)));
 265     }
 266
 267     # simple cases first
 268     if ($daynames{$day} != $dt->day_of_week) {
 269         # if it's the wrong day of the week, rest doesn't matter
 270         return 0;
 271     }
 272
 273     if (!defined $month) {
 274         # WWdd
 275         return (($dt->weekday_of_month == $weekno)
 276                 || ($dt->weekday_of_month == last_day_of_month($dt, $weekno, $day)->weekday_of_month));
 277     }
 278
 279     # MMWWdd
 280     if ($month != $dt->month) {
 281         # If it's the wrong month, then we're done
 282         return 0;
 283     }
 284
 285     # It's the right day of the week
 286     # It's the right month
 287
 288     if ($weekno == $dt->weekday_of_month) {
 289         # If this matches, then we're counting from the beginning
 290         # of the month and it matches and we're done.
 291         return 1;
 292     }
 293
 294     # only case left is that the week number is counting from
 295     # the end of the month: eg, second last wednesday
 296     return (last_week_of_month($weekno, $day)->weekday_of_month == $dt->weekday_of_month);
 297 }
 298
 299 sub match_week {
 300     my $pat = shift;
 301     my @date = @_;
 302     my $dt = DateTime->new(year  => $date[0],
 303                            month => $date[1],
 304                            day   => $date[2]);
 305
 306     if ($pat =~ m/^$weekpat$daypat$/) {
 307         # WWdd: 03we = Third Wednesday
 308         return check_date($dt, undef, $1, $2);
 309     } elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
 310         # MMWWdd: 0599tu Last Tuesday in May XXX WRITE ME
 311         return check_date($dt, $1, $2, $3);
 312     } elsif ($pat =~ m/^$monthpat$weekpat$/) {
 313         # MMWW: 1204: Fourth week in December XXX WRITE ME
 314         return check_date($dt, $1, $2, undef);
 315     } else {
 316         carp "invalid week pattern '$pat'";
 317         return 0;
 318     }
 319 }
 320
 321 sub match_month {
 322     my $pat = shift;
 323     my @date = @_;
 324
 325     return ($pat eq $date[1]);
 326 }
 327
 328 sub match_season {
 329     my $pat = shift;
 330     my @date = @_;
 331
 332     return ($pat eq $date[1]);
 333 }
 334
 335 sub match_year {
 336     my $pat = shift;
 337     my @date = @_;
 338
 339     # XXX WRITE ME
 340     return 0;
 341 }
 342
 343 sub match_issue {
 344     my $pat = shift;
 345     my @date = @_;
 346
 347     # XXX WRITE ME
 348     return 0;
 349 }
 350
 351 my %dispatch = (
 352                 'd' => \&match_day,
 353                 'e' => \&match_issue, # not really a "chron" code
 354                 'w' => \&match_week,
 355                 'm' => \&match_month,
 356                 's' => \&match_season,
 357                 'y' => \&match_year,
 358 );
 359
 360 sub regularity_match {
 361     my $self = shift;
 362     my $pubcode = shift;
 363     my @date = @_;
 364
 365     # we can't match something that doesn't exist.
 366     return 0 if !exists $self->{_mfhdc_PATTERN}->{y};
 367
 368     foreach my $regularity (@{$self->{_mfhdc_PATTERN}->{y}}) {
 369         next unless $regularity =~ m/^$pubcode/;
 370
 371         my $chroncode= substr($regularity, 1, 1);
 372         my @pats = split(/,/, substr($regularity, 2));
 373
 374         if (!exists $dispatch{$chroncode}) {
 375             carp "Unrecognized chroncode '$chroncode'";
 376             return 0;
 377         }
 378
 379         # XXX WRITE ME
 380         foreach my $pat (@pats) {
 381             $pat =~ s|/.+||;    # If it's a combined date, match the start
 382             if ($dispatch{$chroncode}->($pat, @date)) {
 383                 return 1;
 384             }
 385         }
 386     }
 387
 388     return 0;
 389 }
 390
 391 sub is_omitted {
 392     my $self = shift;
 393     my @date = @_;
 394
 395     return $self->regularity_match('o', @date);
 396 }
 397
 398 sub is_published {
 399     my $self = shift;
 400     my @date = @_;
 401
 402     return $self->regularity_match('p', @date);
 403 }
 404
 405 sub is_combined {
 406     my $self = shift;
 407     my @date = @_;
 408
 409     return $self->regularity_match('c', @date);
 410 }
 411
 412 1;