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