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