[open-ils-commits] r14917 - in trunk/Open-ILS/src/perlmods/OpenILS/Utils: . MFHD MFHD/test (djfiander)
svn at svn.open-ils.org
svn at svn.open-ils.org
Sat Nov 14 14:59:55 EST 2009
Author: djfiander
Date: 2009-11-14 14:59:50 -0500 (Sat, 14 Nov 2009)
New Revision: 14917
Modified:
trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD.pm
trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Caption.pm
trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Date.pm
trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Holding.pm
trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/test/mfhd.t
trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHDParser.pm
Log:
Whitespace patch to bring MFHD code into line with new perltidy standard
Modified: trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Caption.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Caption.pm 2009-11-14 09:11:53 UTC (rev 14916)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Caption.pm 2009-11-14 19:59:50 UTC (rev 14917)
@@ -9,64 +9,65 @@
use base 'MARC::Field';
-sub new
-{
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = shift;
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = shift;
my $last_enum = undef;
- $self->{_mfhdc_ENUMS} = {};
- $self->{_mfhdc_CHRONS} = {};
- $self->{_mfhdc_PATTERN} = {};
- $self->{_mfhdc_COPY} = undef;
- $self->{_mfhdc_UNIT} = undef;
- $self->{_mfhdc_COMPRESSIBLE} = 1; # until proven otherwise
+ $self->{_mfhdc_ENUMS} = {};
+ $self->{_mfhdc_CHRONS} = {};
+ $self->{_mfhdc_PATTERN} = {};
+ $self->{_mfhdc_COPY} = undef;
+ $self->{_mfhdc_UNIT} = undef;
+ $self->{_mfhdc_COMPRESSIBLE} = 1; # until proven otherwise
foreach my $subfield ($self->subfields) {
- my ($key, $val) = @$subfield;
- if ($key eq '8') {
- $self->{LINK} = $val;
- } elsif ($key =~ /[a-h]/) {
- # Enumeration Captions
- $self->{_mfhdc_ENUMS}->{$key} = {CAPTION => $val,
- COUNT => undef,
- RESTART => undef};
- if ($key =~ /[ag]/) {
- $last_enum = undef;
- } else {
- $last_enum = $key;
- }
- } elsif ($key =~ /[i-m]/) {
- # Chronology captions
- $self->{_mfhdc_CHRONS}->{$key} = $val;
- } elsif ($key eq 'u') {
- # Bib units per next higher enumeration level
- carp('$u specified for top-level enumeration')
- unless defined($last_enum);
- $self->{_mfhdc_ENUMS}->{$last_enum}->{COUNT} = $val;
- } elsif ($key eq 'v') {
- carp '$v specified for top-level enumeration'
- unless defined($last_enum);
- $self->{_mfhdc_ENUMS}->{$last_enum}->{RESTART} = ($val eq 'r');
- } elsif ($key =~ /[npwz]/) {
- # Publication Pattern info ('o' == type of unit, 'q'..'t' undefined)
- $self->{_mfhdc_PATTERN}->{$key} = $val;
- } elsif ($key =~ /x/) {
- # Calendar change can have multiple comma-separated values
- $self->{_mfhdc_PATTERN}->{x} = [split /,/, $val];
- } elsif ($key eq 'y') {
- $self->{_mfhdc_PATTERN}->{y} = {}
- unless exists $self->{_mfhdc_PATTERN}->{y};
- update_pattern($self, $val);
- } elsif ($key eq 'o') {
- # Type of unit
- $self->{_mfhdc_UNIT} = $val;
- } elsif ($key eq 't') {
- $self->{_mfhdc_COPY} = $val;
- } else {
- carp "Unknown caption subfield '$key'";
- }
+ my ($key, $val) = @$subfield;
+ if ($key eq '8') {
+ $self->{LINK} = $val;
+ } elsif ($key =~ /[a-h]/) {
+ # Enumeration Captions
+ $self->{_mfhdc_ENUMS}->{$key} = {
+ CAPTION => $val,
+ COUNT => undef,
+ RESTART => undef
+ };
+ if ($key =~ /[ag]/) {
+ $last_enum = undef;
+ } else {
+ $last_enum = $key;
+ }
+ } elsif ($key =~ /[i-m]/) {
+ # Chronology captions
+ $self->{_mfhdc_CHRONS}->{$key} = $val;
+ } elsif ($key eq 'u') {
+ # Bib units per next higher enumeration level
+ carp('$u specified for top-level enumeration')
+ unless defined($last_enum);
+ $self->{_mfhdc_ENUMS}->{$last_enum}->{COUNT} = $val;
+ } elsif ($key eq 'v') {
+ carp '$v specified for top-level enumeration'
+ unless defined($last_enum);
+ $self->{_mfhdc_ENUMS}->{$last_enum}->{RESTART} = ($val eq 'r');
+ } elsif ($key =~ /[npwz]/) {
+ # Publication Pattern info ('o' == type of unit, 'q'..'t' undefined)
+ $self->{_mfhdc_PATTERN}->{$key} = $val;
+ } elsif ($key =~ /x/) {
+ # Calendar change can have multiple comma-separated values
+ $self->{_mfhdc_PATTERN}->{x} = [split /,/, $val];
+ } elsif ($key eq 'y') {
+ $self->{_mfhdc_PATTERN}->{y} = {}
+ unless exists $self->{_mfhdc_PATTERN}->{y};
+ update_pattern($self, $val);
+ } elsif ($key eq 'o') {
+ # Type of unit
+ $self->{_mfhdc_UNIT} = $val;
+ } elsif ($key eq 't') {
+ $self->{_mfhdc_COPY} = $val;
+ } else {
+ carp "Unknown caption subfield '$key'";
+ }
}
# subsequent levels of enumeration (primary and alternate)
@@ -74,15 +75,16 @@
# of "issues" per "volume", or whether numbering of issues
# restarts, then we can't compress.
foreach my $key ('b', 'c', 'd', 'e', 'f', 'h') {
- if (exists $self->{_mfhdc_ENUMS}->{$key}) {
- my $pattern = $self->{_mfhdc_ENUMS}->{$key};
- if (!$pattern->{RESTART} || !$pattern->{COUNT}
- || ($pattern->{COUNT} eq 'var')
- || ($pattern->{COUNT} eq 'und')) {
- $self->{_mfhdc_COMPRESSIBLE} = 0;
- last;
- }
- }
+ if (exists $self->{_mfhdc_ENUMS}->{$key}) {
+ my $pattern = $self->{_mfhdc_ENUMS}->{$key};
+ if ( !$pattern->{RESTART}
+ || !$pattern->{COUNT}
+ || ($pattern->{COUNT} eq 'var')
+ || ($pattern->{COUNT} eq 'und')) {
+ $self->{_mfhdc_COMPRESSIBLE} = 0;
+ last;
+ }
+ }
}
my $pat = $self->{_mfhdc_PATTERN};
@@ -90,25 +92,27 @@
# Sanity check publication frequency vs publication pattern:
# if the frequency is a number, then the pattern better
# have that number of values associated with it.
- if (exists($pat->{w}) && ($pat->{w} =~ /^\d+$/)
- && ($pat->{w} != scalar(@{$pat->{y}->{p}}))) {
- carp("Caption::new: publication frequency '$pat->{w}' != publication pattern @{$pat->{y}->{p}}");
+ if ( exists($pat->{w})
+ && ($pat->{w} =~ /^\d+$/)
+ && ($pat->{w} != scalar(@{$pat->{y}->{p}}))) {
+ carp(
+"Caption::new: publication frequency '$pat->{w}' != publication pattern @{$pat->{y}->{p}}"
+ );
}
-
# If there's a $x subfield and a $j, then it's compressible
if (exists $pat->{x} && exists $self->{_mfhdc_CHRONS}->{'j'}) {
- $self->{_mfhdc_COMPRESSIBLE} = 1;
+ $self->{_mfhdc_COMPRESSIBLE} = 1;
}
- bless ($self, $class);
+ bless($self, $class);
return $self;
}
sub update_pattern {
- my $self = shift;
- my $val = shift;
+ my $self = shift;
+ my $val = shift;
my $pathash = $self->{_mfhdc_PATTERN}->{y};
my ($pubcode, $pat) = unpack("a1a*", $val);
@@ -117,7 +121,7 @@
}
sub decode_pattern {
- my $self = shift;
+ my $self = shift;
my $pattern = $self->{_mfhdc_PATTERN}->{y};
# XXX WRITE ME (?)
@@ -131,37 +135,37 @@
sub chrons {
my $self = shift;
- my $key = shift;
+ my $key = shift;
if (exists $self->{_mfhdc_CHRONS}->{$key}) {
- return $self->{_mfhdc_CHRONS}->{$key};
+ return $self->{_mfhdc_CHRONS}->{$key};
} else {
- return undef;
+ return undef;
}
}
sub capfield {
my $self = shift;
- my $key = shift;
+ my $key = shift;
if (exists $self->{_mfhdc_ENUMS}->{$key}) {
- return $self->{_mfhdc_ENUMS}->{$key};
+ return $self->{_mfhdc_ENUMS}->{$key};
} elsif (exists $self->{_mfhdc_CHRONS}->{$key}) {
- return $self->{_mfhdc_CHRONS}->{$key};
+ return $self->{_mfhdc_CHRONS}->{$key};
} else {
- return undef;
+ return undef;
}
}
sub capstr {
my $self = shift;
- my $key = shift;
- my $val = $self->capfield($key);
+ my $key = shift;
+ my $val = $self->capfield($key);
if (ref $val) {
- return $val->{CAPTION};
+ return $val->{CAPTION};
} else {
- return $val;
+ return $val;
}
}
@@ -188,46 +192,47 @@
my $self = shift;
# There is always a '$a' subfield in well-formed fields.
- return 0 if exists $self->{_mfhdc_CHRONS}->{i}
- || exists $self->{_mfhdc_PATTERN}->{x};
+ return 0
+ if exists $self->{_mfhdc_CHRONS}->{i}
+ || exists $self->{_mfhdc_PATTERN}->{x};
- foreach my $key ('a' .. 'f') {
- my $enum;
+ foreach my $key ('a'..'f') {
+ my $enum;
- last if !exists $self->{_mfhdc_ENUMS}->{$key};
+ last if !exists $self->{_mfhdc_ENUMS}->{$key};
- $enum = $self->{_mfhdc_ENUMS}->{$key};
- return 0 if defined $enum->{COUNT} || defined $enum->{RESTART};
+ $enum = $self->{_mfhdc_ENUMS}->{$key};
+ return 0 if defined $enum->{COUNT} || defined $enum->{RESTART};
}
return (exists $self->{_mfhdc_PATTERN}->{w});
}
sub regularity_match {
- my $self = shift;
+ my $self = shift;
my $pubcode = shift;
- my @date = @_;
+ my @date = @_;
# we can't match something that doesn't exist.
return 0 if !exists $self->{_mfhdc_PATTERN}->{y}->{$pubcode};
foreach my $regularity (@{$self->{_mfhdc_PATTERN}->{y}->{$pubcode}}) {
- my $chroncode= substr($regularity, 0, 1);
- my $matchfunc = MFHD::Date::dispatch($chroncode);
- my @pats = split(/,/, substr($regularity, 1));
+ my $chroncode = substr($regularity, 0, 1);
+ my $matchfunc = MFHD::Date::dispatch($chroncode);
+ my @pats = split(/,/, substr($regularity, 1));
- if (!defined $matchfunc) {
- carp "Unrecognized chroncode '$chroncode'";
- return 0;
- }
+ if (!defined $matchfunc) {
+ carp "Unrecognized chroncode '$chroncode'";
+ return 0;
+ }
- # XXX WRITE ME
- foreach my $pat (@pats) {
- $pat =~ s|/.+||; # If it's a combined date, match the start
- if ($matchfunc->($pat, @date)) {
- return 1;
- }
- }
+ # XXX WRITE ME
+ foreach my $pat (@pats) {
+ $pat =~ s|/.+||; # If it's a combined date, match the start
+ if ($matchfunc->($pat, @date)) {
+ return 1;
+ }
+ }
}
return 0;
@@ -237,8 +242,8 @@
my $self = shift;
my @date = @_;
-# printf("# is_omitted: testing date %s: %d\n", join('/', @date),
-# $self->regularity_match('o', @date));
+ # printf("# is_omitted: testing date %s: %d\n", join('/', @date),
+ # $self->regularity_match('o', @date));
return $self->regularity_match('o', @date);
}
@@ -257,28 +262,27 @@
}
sub enum_is_combined {
- my $self = shift;
+ my $self = shift;
my $subfield = shift;
- my $iss = shift;
- my $level = ord($subfield) - ord('a') + 1;
+ my $iss = shift;
+ my $level = ord($subfield) - ord('a') + 1;
return 0 if !exists $self->{_mfhdc_PATTERN}->{y}->{c};
foreach my $regularity (@{$self->{_mfhdc_PATTERN}->{y}->{c}}) {
- next unless $regularity =~ m/^e$level/o;
+ next unless $regularity =~ m/^e$level/o;
- my @pats = split(/,/, substr($regularity, 2));
+ my @pats = split(/,/, substr($regularity, 2));
- foreach my $pat (@pats) {
- $pat =~ s|/.+||; # if it's a combined issue, match the start
- return 1 if ($iss eq $pat);
- }
+ foreach my $pat (@pats) {
+ $pat =~ s|/.+||; # if it's a combined issue, match the start
+ return 1 if ($iss eq $pat);
+ }
}
return 0;
}
-
# Test to see if $dt1 is on or after $dt2
# if length(@{$dt2} == 2, then just month/day are compared
# if length(@{$dt2} == 1, then just the months are compared
@@ -288,28 +292,28 @@
# printf("# on_or_after(%s, %s): ", join('/', @{$dt1}), join('/', @{$dt2}));
- foreach my $i (0..(scalar(@{$dt2})-1)) {
- if ($dt1->[$i] > $dt2->[$i]) {
-# printf("after - pass\n");
- # $dt1 occurs AFTER $dt2
- return 1;
- } elsif ($dt1->[$i] < $dt2->[$i]) {
-# printf("before - fail\n");
- # $dt1 occurs BEFORE $dt2
- return 0;
- }
- # both are still equal, keep going
+ foreach my $i (0..(scalar(@{$dt2}) - 1)) {
+ if ($dt1->[$i] > $dt2->[$i]) {
+ # printf("after - pass\n");
+ # $dt1 occurs AFTER $dt2
+ return 1;
+ } elsif ($dt1->[$i] < $dt2->[$i]) {
+ # printf("before - fail\n");
+ # $dt1 occurs BEFORE $dt2
+ return 0;
+ }
+ # both are still equal, keep going
}
# We fell out of the loop with them being equal, so it's 'on'
-# printf("on - pass\n");
+ # printf("on - pass\n");
return 1;
}
sub calendar_increment {
- my $self = shift;
- my $cur = shift;
- my $new = shift;
+ my $self = shift;
+ my $cur = shift;
+ my $new = shift;
my $cal_change = $self->calendar_change;
my $month;
my $day;
@@ -318,62 +322,64 @@
# A calendar change is defined, need to check if it applies
if (scalar(@{$new}) == 1) {
- carp "Can't calculate date change for ", $self->as_string;
- return 0;
+ carp "Can't calculate date change for ", $self->as_string;
+ return 0;
}
foreach my $change (@{$cal_change}) {
- my $incr;
+ my $incr;
- if (length($change) == 2) {
- $month = $change;
- } elsif (length($change) == 4) {
- ($month, $day) = unpack("a2a2", $change);
- }
+ if (length($change) == 2) {
+ $month = $change;
+ } elsif (length($change) == 4) {
+ ($month, $day) = unpack("a2a2", $change);
+ }
-# printf("# calendar_increment('%s', '%s'): change on '%s/%s'\n",
-# join('/', @{$cur}), join('/', @{$new}),
-# $month, defined($day) ? $day : 'UNDEF');
+ # printf("# calendar_increment('%s', '%s'): change on '%s/%s'\n",
+ # join('/', @{$cur}), join('/', @{$new}),
+ # $month, defined($day) ? $day : 'UNDEF');
- if ($cur->[0] == $new->[0]) {
- # Same year, so a 'simple' month/day comparison will be fine
- $incr = (!on_or_after([$cur->[1], $cur->[2]], [$month, $day])
- && on_or_after([$new->[1], $new->[2]], [$month, $day]));
- } else {
- # @cur is in the year before @new. There are
- # two possible cases for the calendar change date that
- # indicate that it's time to change the volume:
- # (1) the change date is AFTER @cur in the year, or
- # (2) the change date is BEFORE @new in the year.
- #
- # -------|------|------X------|------|
- # @cur (1) Jan 1 (2) @new
+ if ($cur->[0] == $new->[0]) {
+ # Same year, so a 'simple' month/day comparison will be fine
+ $incr =
+ ( !on_or_after([$cur->[1], $cur->[2]], [$month, $day])
+ && on_or_after([$new->[1], $new->[2]], [$month, $day]));
+ } else {
+ # @cur is in the year before @new. There are
+ # two possible cases for the calendar change date that
+ # indicate that it's time to change the volume:
+ # (1) the change date is AFTER @cur in the year, or
+ # (2) the change date is BEFORE @new in the year.
+ #
+ # -------|------|------X------|------|
+ # @cur (1) Jan 1 (2) @new
- $incr = (on_or_after([$new->[1], $new->[2]], [$month, $day])
- || !on_or_after([$cur->[1], $cur->[2]], [$month, $day]));
- }
- return $incr if $incr;
+ $incr =
+ (on_or_after([$new->[1], $new->[2]], [$month, $day])
+ || !on_or_after([$cur->[1], $cur->[2]], [$month, $day]));
+ }
+ return $incr if $incr;
}
return 0;
}
sub next_date {
- my $self = shift;
- my $next = shift;
+ my $self = shift;
+ my $next = shift;
my $carry = shift;
- my @keys = @_;
+ my @keys = @_;
my @cur;
my @new;
- my @newend; # only used for combined issues
+ my @newend; # only used for combined issues
my $incr;
- my $reg = $self->{_mfhdc_REGULARITY};
+ my $reg = $self->{_mfhdc_REGULARITY};
my $pattern = $self->{_mfhdc_PATTERN};
- my $freq = $pattern->{w};
+ my $freq = $pattern->{w};
foreach my $i (0..$#keys) {
- $cur[$i] = $next->{$keys[$i]} if exists $next->{$keys[$i]};
+ $cur[$i] = $next->{$keys[$i]} if exists $next->{$keys[$i]};
}
# If the current issue has a combined date (eg, May/June)
@@ -382,111 +388,111 @@
$cur[-1] =~ s|^[^/]+/||;
if (defined $pattern->{y}->{p}) {
- # There is a $y publication pattern defined in the record:
- # use it to calculate the next issue date.
+ # There is a $y publication pattern defined in the record:
+ # use it to calculate the next issue date.
- foreach my $pubpat (@{$pattern->{y}->{p}}, @{$pattern->{y}->{c}}) {
- my $chroncode = substr($pubpat, 0, 1);
- my $genfunc = MFHD::Date::generator($chroncode);
- my @pats = split(/,/, substr($pubpat, 1));
+ foreach my $pubpat (@{$pattern->{y}->{p}}, @{$pattern->{y}->{c}}) {
+ my $chroncode = substr($pubpat, 0, 1);
+ my $genfunc = MFHD::Date::generator($chroncode);
+ my @pats = split(/,/, substr($pubpat, 1));
- next if $chroncode eq 'e';
+ next if $chroncode eq 'e';
- if (!defined $genfunc) {
- carp "Unrecognized chroncode '$chroncode'";
- return undef;
- }
+ if (!defined $genfunc) {
+ carp "Unrecognized chroncode '$chroncode'";
+ return undef;
+ }
- foreach my $pat (@pats) {
- my $combined = $pat =~ m|/|;
- my ($start, $end);
- my @candidate;
+ foreach my $pat (@pats) {
+ my $combined = $pat =~ m|/|;
+ my ($start, $end);
+ my @candidate;
-# printf("# next_date: generating with pattern '%s'\n", $pat);
+ # printf("# next_date: generating with pattern '%s'\n", $pat);
- if ($combined) {
- ($start, $end) = split('/', $pat, 2);
- } else {
- ($start, $end) = (undef, undef);
- }
+ if ($combined) {
+ ($start, $end) = split('/', $pat, 2);
+ } else {
+ ($start, $end) = (undef, undef);
+ }
- @candidate = $genfunc->($start || $pat, @cur);
+ @candidate = $genfunc->($start || $pat, @cur);
- while ($self->is_omitted(@candidate)) {
-# printf("# pubpat omitting date '%s'\n",
-# join('/', @candidate));
- @candidate = $genfunc->($start || $pat, @candidate);
- }
+ while ($self->is_omitted(@candidate)) {
+ # printf("# pubpat omitting date '%s'\n",
+ # join('/', @candidate));
+ @candidate = $genfunc->($start || $pat, @candidate);
+ }
-# printf("# testing new candidate '%s' against '%s'\n",
-# join('/', @candidate), join('/', @new));
+ # printf("# testing new candidate '%s' against '%s'\n",
+ # join('/', @candidate), join('/', @new));
- if (!defined($new[0])
- || !on_or_after(\@candidate, \@new)) {
- # first time through the loop
- # or @candidate is before @new =>
- # @candidate is the next issue.
- @new = @candidate;
- if (defined $end) {
- @newend = $genfunc->($end, @cur);
- } else {
- $newend[0] = undef;
- }
+ if ( !defined($new[0])
+ || !on_or_after(\@candidate, \@new)) {
+ # first time through the loop
+ # or @candidate is before @new =>
+ # @candidate is the next issue.
+ @new = @candidate;
+ if (defined $end) {
+ @newend = $genfunc->($end, @cur);
+ } else {
+ $newend[0] = undef;
+ }
-# printf("# selecting candidate date '%s'\n", join('/', @new));
- }
- }
- }
+ # printf("# selecting candidate date '%s'\n", join('/', @new));
+ }
+ }
+ }
- if (defined($newend[0])) {
- # The best match was a combined issue
- foreach my $i (0..$#new) {
- # don't combine identical fields
- next if $new[$i] eq $newend[$i];
- $new[$i] .= '/' . $newend[$i];
- }
- }
+ if (defined($newend[0])) {
+ # The best match was a combined issue
+ foreach my $i (0..$#new) {
+ # don't combine identical fields
+ next if $new[$i] eq $newend[$i];
+ $new[$i] .= '/' . $newend[$i];
+ }
+ }
}
if (scalar @new == 0) {
- # There was no suitable publication pattern defined,
- # so use the $w frequency to figure out the next date
- if (!defined($freq)) {
- carp "Undefined frequency in next_date!";
- } elsif (!MFHD::Date::can_increment($freq)) {
- carp "Don't know how to deal with frequency '$freq'!";
- } else {
- #
- # One of the standard defined issue frequencies
- #
- @new = MFHD::Date::incr_date($freq, @cur);
+ # There was no suitable publication pattern defined,
+ # so use the $w frequency to figure out the next date
+ if (!defined($freq)) {
+ carp "Undefined frequency in next_date!";
+ } elsif (!MFHD::Date::can_increment($freq)) {
+ carp "Don't know how to deal with frequency '$freq'!";
+ } else {
+ #
+ # One of the standard defined issue frequencies
+ #
+ @new = MFHD::Date::incr_date($freq, @cur);
- while ($self->is_omitted(@new)) {
- @new = MFHD::Date::incr_date($freq, @new);
- }
+ while ($self->is_omitted(@new)) {
+ @new = MFHD::Date::incr_date($freq, @new);
+ }
- if ($self->is_combined(@new)) {
- my @second_date = MFHD::Date::incr_date($freq, @new);
+ if ($self->is_combined(@new)) {
+ my @second_date = MFHD::Date::incr_date($freq, @new);
- # I am cheating: This code assumes that only the smallest
- # time increment is combined. So, no "Apr 15/May 1" allowed.
- $new[-1] = $new[-1] . '/' . $second_date[-1];
- }
- }
+ # I am cheating: This code assumes that only the smallest
+ # time increment is combined. So, no "Apr 15/May 1" allowed.
+ $new[-1] = $new[-1] . '/' . $second_date[-1];
+ }
+ }
}
for my $i (0..$#new) {
- $next->{$keys[$i]} = $new[$i];
+ $next->{$keys[$i]} = $new[$i];
}
# Figure out if we need to adust volume number
# right now just use the $carry that was passed in.
# in long run, need to base this on ($carry or date_change)
if ($carry) {
- # if $carry is set, the date doesn't matter: we're not
- # going to increment the v. number twice at year-change.
- $next->{a} += $carry;
+ # if $carry is set, the date doesn't matter: we're not
+ # going to increment the v. number twice at year-change.
+ $next->{a} += $carry;
} elsif (defined $pattern->{x}) {
- $next->{a} += $self->calendar_increment(\@cur, \@new);
+ $next->{a} += $self->calendar_increment(\@cur, \@new);
}
}
@@ -497,21 +503,22 @@
# First handle any "alternative enumeration", since they're
# a lot simpler, and don't depend on the the calendar
foreach my $key ('h', 'g') {
- next if !exists $next->{$key};
- if (!$self->capstr($key)) {
- warn "Holding data exists for $key, but no caption specified";
- $next->{$key} += 1;
- last;
- }
+ next if !exists $next->{$key};
+ if (!$self->capstr($key)) {
+ warn "Holding data exists for $key, but no caption specified";
+ $next->{$key} += 1;
+ last;
+ }
- my $cap = $self->capfield($key);
- if ($cap->{RESTART} && $cap->{COUNT}
- && ($next->{$key} == $cap->{COUNT})) {
- $next->{$key} = 1;
- } else {
- $next->{$key} += 1;
- last;
- }
+ my $cap = $self->capfield($key);
+ if ( $cap->{RESTART}
+ && $cap->{COUNT}
+ && ($next->{$key} == $cap->{COUNT})) {
+ $next->{$key} = 1;
+ } else {
+ $next->{$key} += 1;
+ last;
+ }
}
}
@@ -519,15 +526,15 @@
# particular publication pattern for the given level of enumeration
# returns the pattern string or undef
sub enum_pubpat {
- my $self = shift;
+ my $self = shift;
my $level = shift;
return undef if !exists $self->{_mfhdc_PATTERN}->{y}->{p};
foreach my $reg (@{$self->{_mfhdc_PATTERN}->{y}->{p}}) {
- if ($reg =~ m/^e$level/o) {
- return substr($reg, 2);
- }
+ if ($reg =~ m/^e$level/o) {
+ return substr($reg, 2);
+ }
}
return undef;
}
@@ -552,101 +559,102 @@
# least once. If there's no subfield b, then there's only a single
# level of enumeration, so we just add one to it and we're done.
if (exists $next->{b}) {
- $carry = 0;
+ $carry = 0;
} else {
- $carry = 1;
+ $carry = 1;
}
foreach my $key (reverse('b'..'f')) {
- my $level;
- my $pubpat;
+ my $level;
+ my $pubpat;
- next if !exists $next->{$key};
+ next if !exists $next->{$key};
- # If the current issue has a combined issue number (eg, 2/3)
- # get rid of the first issue number and base the calculation
- # on the final issue number in the combined issue.
- if ($next->{$key} =~ m|/|) {
- $next->{$key} =~ s|^[^/]+/||;
- }
+ # If the current issue has a combined issue number (eg, 2/3)
+ # get rid of the first issue number and base the calculation
+ # on the final issue number in the combined issue.
+ if ($next->{$key} =~ m|/|) {
+ $next->{$key} =~ s|^[^/]+/||;
+ }
- $level = ord($key) - ord('a') + 1; # enumeration level
+ $level = ord($key) - ord('a') + 1; # enumeration level
- $pubpat = $self->enum_pubpat($level);
+ $pubpat = $self->enum_pubpat($level);
- if ($pubpat) {
-# printf("# next_enum: found pubpat '%s' for subfield '%s'\n",
-# $pubpat, $key);
- my @pats = split(/,/, $pubpat);
+ if ($pubpat) {
+ # printf("# next_enum: found pubpat '%s' for subfield '%s'\n",
+ # $pubpat, $key);
+ my @pats = split(/,/, $pubpat);
- # If we fall out the bottom of the loop, then $carry
- # will still be 1, and we will reset the current
- # level to the first value in @pats and increment
- # then next higher level.
- $carry = 1;
+ # If we fall out the bottom of the loop, then $carry
+ # will still be 1, and we will reset the current
+ # level to the first value in @pats and increment
+ # then next higher level.
+ $carry = 1;
- foreach my $pat (@pats) {
- my $combined = $pat =~ m|/|;
- my $end;
+ foreach my $pat (@pats) {
+ my $combined = $pat =~ m|/|;
+ my $end;
-# printf("# next_enum: checking current '%s' against pat '%s'\n",
-# $next->{$key}, $pat);
+ # printf("# next_enum: checking current '%s' against pat '%s'\n",
+ # $next->{$key}, $pat);
- if ($combined) {
- ($pat, $end) = split('/', $pat, 2);
- } else {
- $end = undef;
- }
+ if ($combined) {
+ ($pat, $end) = split('/', $pat, 2);
+ } else {
+ $end = undef;
+ }
- if ($pat > $next->{$key}) {
- $carry = 0;
- $next->{$key} = $pat;
- $next->{$key} .= '/' . $end if $end;
-# printf("# next_enum: selecting new issue no. %s\n", $next->{$key});
- last; # We've found the correct next issue number
- }
- }
- if ($carry) {
- $next->{$key} = $pats[0];
- } else {
- last; # exit the top level loop because we're done
- }
+ if ($pat > $next->{$key}) {
+ $carry = 0;
+ $next->{$key} = $pat;
+ $next->{$key} .= '/' . $end if $end;
+ # printf("# next_enum: selecting new issue no. %s\n", $next->{$key});
+ last; # We've found the correct next issue number
+ }
+ }
+ if ($carry) {
+ $next->{$key} = $pats[0];
+ } else {
+ last; # exit the top level loop because we're done
+ }
- } else {
- # No enumeration publication pattern specified for this level,
- # just keed adding one.
+ } else {
+ # No enumeration publication pattern specified for this level,
+ # just keed adding one.
- if (!$self->capstr($key)) {
- # Just assume that it increments continuously and give up
- warn "Holding data exists for $key, but no caption specified";
- $next->{$key} += 1;
- $carry = 0;
- last;
- }
+ if (!$self->capstr($key)) {
+ # Just assume that it increments continuously and give up
+ warn "Holding data exists for $key, but no caption specified";
+ $next->{$key} += 1;
+ $carry = 0;
+ last;
+ }
-# printf("# next_enum: no publication pattern, using frequency\n");
+ # printf("# next_enum: no publication pattern, using frequency\n");
- my $cap = $self->capfield($key);
- if ($cap->{RESTART} && $cap->{COUNT}
- && ($next->{$key} eq $cap->{COUNT})) {
- $next->{$key} = 1;
- $carry = 1;
- } else {
- # If I don't need to "carry" beyond here, then I just increment
- # this level of the enumeration and stop looping, since the
- # "next" hash has been initialized with the current values
+ my $cap = $self->capfield($key);
+ if ( $cap->{RESTART}
+ && $cap->{COUNT}
+ && ($next->{$key} eq $cap->{COUNT})) {
+ $next->{$key} = 1;
+ $carry = 1;
+ } else {
+ # If I don't need to "carry" beyond here, then I just increment
+ # this level of the enumeration and stop looping, since the
+ # "next" hash has been initialized with the current values
- $next->{$key} += 1;
- $carry = 0;
- }
+ $next->{$key} += 1;
+ $carry = 0;
+ }
- # You can't have a combined issue that spans two volumes: no.12/1
- # is forbidden
- if ($self->enum_is_combined($key, $next->{$key})) {
- $next->{$key} .= '/' . ($next->{$key} + 1);
- }
+ # You can't have a combined issue that spans two volumes: no.12/1
+ # is forbidden
+ if ($self->enum_is_combined($key, $next->{$key})) {
+ $next->{$key} .= '/' . ($next->{$key} + 1);
+ }
- last if !$carry;
- }
+ last if !$carry;
+ }
}
# The easy part is done. There are two things left to do:
@@ -655,51 +663,51 @@
# or because $carry is set because of the above loop
if (!$self->subfield('i')) {
- # The simple case: if there is no chronology specified
- # then just check $carry and return
- $next->{'a'} += $carry;
+ # The simple case: if there is no chronology specified
+ # then just check $carry and return
+ $next->{'a'} += $carry;
} else {
- # Figure out date of next issue, then decide if we need
- # to adjust top level enumeration based on that
- $self->next_date($next, $carry, ('i'..'m'));
+ # Figure out date of next issue, then decide if we need
+ # to adjust top level enumeration based on that
+ $self->next_date($next, $carry, ('i'..'m'));
}
}
sub next {
- my $self = shift;
+ my $self = shift;
my $holding = shift;
- my $next = {};
+ my $next = {};
# Initialize $next with current enumeration & chronology, then
# we can just operate on $next, based on the contents of the caption
if ($self->enumeration_is_chronology) {
- foreach my $key ('a' .. 'h') {
- $next->{$key} = $holding->{_mfhdh_SUBFIELDS}->{$key}
- if defined $holding->{_mfhdh_SUBFIELDS}->{$key};
- }
- $self->next_date($next, 0, ('a' .. 'h'));
+ foreach my $key ('a'..'h') {
+ $next->{$key} = $holding->{_mfhdh_SUBFIELDS}->{$key}
+ if defined $holding->{_mfhdh_SUBFIELDS}->{$key};
+ }
+ $self->next_date($next, 0, ('a'..'h'));
- return $next;
+ return $next;
}
- foreach my $key ('a' .. 'h') {
- $next->{$key} = $holding->{_mfhdh_SUBFIELDS}->{$key}->{HOLDINGS}
- if defined $holding->{_mfhdh_SUBFIELDS}->{$key};
+ foreach my $key ('a'..'h') {
+ $next->{$key} = $holding->{_mfhdh_SUBFIELDS}->{$key}->{HOLDINGS}
+ if defined $holding->{_mfhdh_SUBFIELDS}->{$key};
}
foreach my $key ('i'..'m') {
- $next->{$key} = $holding->{_mfhdh_SUBFIELDS}->{$key}
- if defined $holding->{_mfhdh_SUBFIELDS}->{$key};
+ $next->{$key} = $holding->{_mfhdh_SUBFIELDS}->{$key}
+ if defined $holding->{_mfhdh_SUBFIELDS}->{$key};
}
if (exists $next->{'h'}) {
- $self->next_alt_enum($next);
+ $self->next_alt_enum($next);
}
$self->next_enum($next);
- return($next);
+ return ($next);
}
1;
Modified: trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Date.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Date.pm 2009-11-14 09:11:53 UTC (rev 14916)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Date.pm 2009-11-14 19:59:50 UTC (rev 14917)
@@ -8,22 +8,22 @@
use base 'Exporter';
-our @EXPORT_OK =qw(dispatch generator incr_date can_increment);
+our @EXPORT_OK = qw(dispatch generator incr_date can_increment);
my %daynames = (
- 'mo' => 1,
- 'tu' => 2,
- 'we' => 3,
- 'th' => 4,
- 'fr' => 5,
- 'sa' => 6,
- 'su' => 7,
- );
+ 'mo' => 1,
+ 'tu' => 2,
+ 'we' => 3,
+ 'th' => 4,
+ 'fr' => 5,
+ 'sa' => 6,
+ 'su' => 7,
+);
-my $daypat = '(mo|tu|we|th|fr|sa|su)';
+my $daypat = '(mo|tu|we|th|fr|sa|su)';
my $weekpat = '(99|98|97|00|01|02|03|04|05)';
my $weeknopat;
-my $monthpat = '(01|02|03|04|05|06|07|08|09|10|11|12)';
+my $monthpat = '(01|02|03|04|05|06|07|08|09|10|11|12)';
my $seasonpat = '(21|22|23|24)';
# Initialize $weeknopat to be '(01|02|03|...|51|52|53)'
@@ -34,113 +34,118 @@
$weeknopat .= '53)';
sub match_day {
- my $pat = shift;
+ my $pat = shift;
my @date = @_;
# Translate daynames into day of week for DateTime
# also used to check if dayname is valid.
if (exists $daynames{$pat}) {
- # dd
- # figure out day of week for date and compare
- my $dt = DateTime->new(year => $date[0],
- month => $date[1],
- day => $date[2]);
- return ($dt->day_of_week == $daynames{$pat});
+ # dd
+ # figure out day of week for date and compare
+ my $dt = DateTime->new(
+ year => $date[0],
+ month => $date[1],
+ day => $date[2]
+ );
+ return ($dt->day_of_week == $daynames{$pat});
} elsif (length($pat) == 2) {
- # DD
- return $pat == $date[2];
+ # DD
+ return $pat == $date[2];
} elsif (length($pat) == 4) {
- # MMDD
- my ($mon, $day) = unpack("a2a2", $pat);
+ # MMDD
+ my ($mon, $day) = unpack("a2a2", $pat);
- return (($mon == $date[1]) && ($day == $date[2]));
+ return (($mon == $date[1]) && ($day == $date[2]));
} else {
- carp "Invalid day pattern '$pat'";
- return 0;
+ carp "Invalid day pattern '$pat'";
+ return 0;
}
}
sub subsequent_day {
my $pat = shift;
my @cur = @_;
- my $dt = DateTime->new(year => $cur[0],
- month => $cur[1],
- day => $cur[2]);
+ my $dt = DateTime->new(
+ year => $cur[0],
+ month => $cur[1],
+ day => $cur[2]
+ );
-# printf("# subsequent_day: pat='%s' cur='%s'\n", $pat, join('/', @cur));
+ # printf("# subsequent_day: pat='%s' cur='%s'\n", $pat, join('/', @cur));
if (exists $daynames{$pat}) {
- # dd: published on the given weekday
- my $dow = $dt->day_of_week;
- my $corr = ($daynames{$pat} - $dow + 7) % 7;
+ # dd: published on the given weekday
+ my $dow = $dt->day_of_week;
+ my $corr = ($daynames{$pat} - $dow + 7) % 7;
- if ($dow == $daynames{$pat}) {
- # the next one is one week hence
- $dt->add(days => 7);
- } else {
- # the next one is later this week,
- # or it is next week (ie, on or after next Monday)
- # $corr will take care of it.
- $dt->add(days => $corr);
- }
- @cur = ($dt->year, $dt->month, $dt->day);
+ if ($dow == $daynames{$pat}) {
+ # the next one is one week hence
+ $dt->add(days => 7);
+ } else {
+ # the next one is later this week,
+ # or it is next week (ie, on or after next Monday)
+ # $corr will take care of it.
+ $dt->add(days => $corr);
+ }
+ @cur = ($dt->year, $dt->month, $dt->day);
} elsif (length($pat) == 2) {
- # DD: published on the give day of every month
- if ($dt->day >= $pat) {
- # current date is on or after $pat: next one is next month
- $dt->set(day => $pat);
- $dt->add(months => 1);
- @cur = ($dt->year, $dt->month, $dt->day);
- } else {
- # current date is before $pat: set day to pattern
- $cur[2] = $pat;
- }
+ # DD: published on the give day of every month
+ if ($dt->day >= $pat) {
+ # current date is on or after $pat: next one is next month
+ $dt->set(day => $pat);
+ $dt->add(months => 1);
+ @cur = ($dt->year, $dt->month, $dt->day);
+ } else {
+ # current date is before $pat: set day to pattern
+ $cur[2] = $pat;
+ }
} elsif (length($pat) == 4) {
- # MMDD: published on the given day of the given month
- my ($mon, $day) = unpack("a2a2", $pat);
+ # MMDD: published on the given day of the given month
+ my ($mon, $day) = unpack("a2a2", $pat);
- if (on_or_after($mon, $day, $cur[1], $cur[2])) {
- # Current date is on or after pattern; next one is next year
- $cur[0] += 1;
- }
- # Year is now right. Either it's next year (because of on_or_after)
- # or it's this year, because the current date is NOT on or after
- # the pattern. Just fix the month and day
- $cur[1] = $mon;
- $cur[2] = $day;
+ if (on_or_after($mon, $day, $cur[1], $cur[2])) {
+ # Current date is on or after pattern; next one is next year
+ $cur[0] += 1;
+ }
+ # Year is now right. Either it's next year (because of on_or_after)
+ # or it's this year, because the current date is NOT on or after
+ # the pattern. Just fix the month and day
+ $cur[1] = $mon;
+ $cur[2] = $day;
} else {
- carp "Invalid day pattern '$pat'";
- return undef;
+ carp "Invalid day pattern '$pat'";
+ return undef;
}
foreach my $i (0..$#cur) {
- $cur[$i] = '0' . (0+$cur[$i]) if $cur[$i] < 10;
+ $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
}
-# printf("subsequent_day: returning '%s'\n", join('/', @cur));
+ # printf("subsequent_day: returning '%s'\n", join('/', @cur));
return @cur;
}
-
# Calculate date of 3rd Friday of the month (for example)
# 1-5: count from beginning of month
# 99-97: count back from end of month
sub nth_week_of_month {
- my $dt = shift;
+ my $dt = shift;
my $week = shift;
- my $day = shift;
+ my $day = shift;
my ($nth_day, $dow);
-# printf("# nth_week_of_month(dt, '%s', '%s')\n", $week, $day);
+ # printf("# nth_week_of_month(dt, '%s', '%s')\n", $week, $day);
if (0 < $week && $week <= 5) {
- $nth_day = $dt->clone->set(day => 1);
+ $nth_day = $dt->clone->set(day => 1);
} elsif ($week >= 97) {
- $nth_day = DateTime->last_day_of_month(year => $dt->year,
- month => $dt->month);
+ $nth_day = DateTime->last_day_of_month(
+ year => $dt->year,
+ month => $dt->month
+ );
} else {
- return undef;
+ return undef;
}
$dow = $nth_day->day_of_week();
@@ -149,23 +154,25 @@
# then use that day for the calculations, otherwise, just use
# the day of the week of the original date (the date $dt).
if (defined($day)) {
- $day = $daynames{$day};
+ $day = $daynames{$day};
} else {
- $day = $dt->day_of_week;
+ $day = $dt->day_of_week;
}
if ($week <= 5) {
- # count forwards
- $nth_day->add(days => ($day - $dow + 7) % 7,
- weeks=> $week - 1);
+ # count forwards
+ $nth_day->add(
+ days => ($day - $dow + 7) % 7,
+ weeks => $week - 1
+ );
} else {
- # count backwards
- $nth_day->subtract(days => ($day - $dow + 7) % 7);
+ # count backwards
+ $nth_day->subtract(days => ($day - $dow + 7) % 7);
- # 99: last week of month, 98: second last, etc.
- for (my $i = 99 - $week; $i > 0; $i--) {
- $nth_day->subtract(weeks => 1);
- }
+ # 99: last week of month, 98: second last, etc.
+ for (my $i = 99 - $week; $i > 0; $i--) {
+ $nth_day->subtract(weeks => 1);
+ }
}
# There is no nth "day" in the month!
@@ -179,74 +186,92 @@
# of month, week, and day
#
sub check_date {
- my $dt = shift;
- my $month = shift;
+ my $dt = shift;
+ my $month = shift;
my $weekno = shift;
- my $day = shift;
+ my $day = shift;
-# printf("check_date('%s', '%s', '%s')\n", $month, $weekno, $day || '');
+ # printf("check_date('%s', '%s', '%s')\n", $month, $weekno, $day || '');
if (!defined $day) {
- # MMWW
- return (($dt->month == $month)
- && (($dt->week_of_month == $weekno)
- || ($weekno >= 97
- && ($dt->week_of_month == nth_week_of_month($dt, $weekno, $day)->week_of_month))));
+ # MMWW
+ return (
+ ($dt->month == $month)
+ && (
+ ($dt->week_of_month == $weekno)
+ || (
+ $weekno >= 97
+ && ($dt->week_of_month ==
+ nth_week_of_month($dt, $weekno, $day)->week_of_month)
+ )
+ )
+ );
}
# simple cases first
if ($daynames{$day} != $dt->day_of_week) {
- # if it's the wrong day of the week, rest doesn't matter
- return 0;
+ # if it's the wrong day of the week, rest doesn't matter
+ return 0;
}
if (!defined $month) {
- # WWdd
- return (($weekno == 0) # Every week
- || ($dt->weekday_of_month == $weekno) # this week
- || (($weekno >= 97) && ($dt->weekday_of_month == nth_week_of_month($dt, $weekno, $day)->weekday_of_month)));
+ # WWdd
+ return (
+ ($weekno == 0) # Every week
+ || ($dt->weekday_of_month == $weekno) # this week
+ || (
+ ($weekno >= 97)
+ && ($dt->weekday_of_month ==
+ nth_week_of_month($dt, $weekno, $day)->weekday_of_month)
+ )
+ );
}
# MMWWdd
if ($month != $dt->month) {
- # If it's the wrong month, then we're done
- return 0;
+ # If it's the wrong month, then we're done
+ return 0;
}
# It's the right day of the week
# It's the right month
- if (($weekno == 0) ||($weekno == $dt->weekday_of_month)) {
- # If this matches, then we're counting from the beginning
- # of the month and it matches and we're done.
- return 1;
+ if (($weekno == 0) || ($weekno == $dt->weekday_of_month)) {
+ # If this matches, then we're counting from the beginning
+ # of the month and it matches and we're done.
+ return 1;
}
# only case left is that the week number is counting from
# the end of the month: eg, second last wednesday
- return (($weekno >= 97)
- && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month == $dt->weekday_of_month));
+ return (
+ ($weekno >= 97)
+ && (nth_week_of_month($dt, $weekno, $day)->weekday_of_month ==
+ $dt->weekday_of_month)
+ );
}
sub match_week {
- my $pat = shift;
+ my $pat = shift;
my @date = @_;
- my $dt = DateTime->new(year => $date[0],
- month => $date[1],
- day => $date[2]);
+ my $dt = DateTime->new(
+ year => $date[0],
+ month => $date[1],
+ day => $date[2]
+ );
if ($pat =~ m/^$weekpat$daypat$/) {
- # WWdd: 03we = Third Wednesday
- return check_date($dt, undef, $1, $2);
+ # WWdd: 03we = Third Wednesday
+ return check_date($dt, undef, $1, $2);
} elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
- # MMWWdd: 0599tu Last Tuesday in May XXX WRITE ME
- return check_date($dt, $1, $2, $3);
+ # MMWWdd: 0599tu Last Tuesday in May XXX WRITE ME
+ return check_date($dt, $1, $2, $3);
} elsif ($pat =~ m/^$monthpat$weekpat$/) {
- # MMWW: 1204: Fourth week in December XXX WRITE ME
- return check_date($dt, $1, $2, undef);
+ # MMWW: 1204: Fourth week in December XXX WRITE ME
+ return check_date($dt, $1, $2, undef);
} else {
- carp "invalid week pattern '$pat'";
- return 0;
+ carp "invalid week pattern '$pat'";
+ return 0;
}
}
@@ -259,80 +284,88 @@
my $candidate;
my $dt;
-# printf("# subsequent_week('%s', '%s', '%s', '%s')\n", $pat, @cur);
+ # printf("# subsequent_week('%s', '%s', '%s', '%s')\n", $pat, @cur);
- $dt = DateTime->new(year => $cur[0],
- month=> $cur[1],
- day => $cur[2]);
+ $dt = DateTime->new(
+ year => $cur[0],
+ month => $cur[1],
+ day => $cur[2]
+ );
if ($pat =~ m/^$weekpat$daypat$/o) {
- # WWdd: published on given weekday of given week of every month
- my ($week, $day) = ($1, $2);
+ # WWdd: published on given weekday of given week of every month
+ my ($week, $day) = ($1, $2);
-# printf("# subsequent_week: matched /WWdd/: week='%s', day='%s'\n",
-# $week, $day);
+ # printf("# subsequent_week: matched /WWdd/: week='%s', day='%s'\n",
+ # $week, $day);
- if ($week eq '00') {
- # Every week
- $candidate = $dt->clone;
+ if ($week eq '00') {
+ # Every week
+ $candidate = $dt->clone;
- if ($dt->day_of_week == $daynames{$day}) {
- # Current is right day, next one is a week hence
- $candidate->add(days => 7);
- } else {
- $candidate->add(days => ($daynames{$day} - $dt->day_of_week + 7) % 7);
- }
- } else {
- # 3rd Friday of the month (eg)
- $candidate = nth_week_of_month($dt, $week, $day);
- }
+ if ($dt->day_of_week == $daynames{$day}) {
+ # Current is right day, next one is a week hence
+ $candidate->add(days => 7);
+ } else {
+ $candidate->add(
+ days => ($daynames{$day} - $dt->day_of_week + 7) % 7);
+ }
+ } else {
+ # 3rd Friday of the month (eg)
+ $candidate = nth_week_of_month($dt, $week, $day);
+ }
- if ($candidate <= $dt) {
- # If the n'th week of the month happens on before the
- # current issue, then the next issue is published next
- # month, otherwise, it's published this month.
- # This will never happen for the "00: every week" pattern
+ if ($candidate <= $dt) {
+# If the n'th week of the month happens on before the
+# current issue, then the next issue is published next
+# month, otherwise, it's published this month.
+# This will never happen for the "00: every week" pattern
# printf("# subsequent_week: candidate (%s) occurs on or before current date (%s)\n",
# join('/', $candidate->year, $candidate->month, $candidate->day),
# join('/', $dt->year, $dt->month, $dt->day));
- $candidate->set(day => 1);
- $candidate->add(months => 1);
- $candidate = nth_week_of_month($candidate, $week, $day);
- }
+ $candidate->set(day => 1);
+ $candidate->add(months => 1);
+ $candidate = nth_week_of_month($candidate, $week, $day);
+ }
} elsif ($pat =~ m/^$monthpat$weekpat$daypat$/) {
- # MMWWdd: published on given weekday of given week of given month
- my ($month, $week, $day) = ($1, $2, $3);
+ # MMWWdd: published on given weekday of given week of given month
+ my ($month, $week, $day) = ($1, $2, $3);
# printf("# subsequent_week: matched /MMWWdd/: month='%s', week='%s', day='%s'\n",
# $month, $week, $day);
- $candidate = DateTime->new(year => $dt->year,
- month=> $month,
- day => 1);
- $candidate = nth_week_of_month($candidate, $week, $day);
- if ($candidate <= $dt) {
- # We've missed it for this year, next one that matches
- # will be next year
- $candidate->add(years => 1)->set(day => 1);
- $candidate = nth_week_of_month($candidate, $week, $day);
- }
+ $candidate = DateTime->new(
+ year => $dt->year,
+ month => $month,
+ day => 1
+ );
+ $candidate = nth_week_of_month($candidate, $week, $day);
+ if ($candidate <= $dt) {
+ # We've missed it for this year, next one that matches
+ # will be next year
+ $candidate->add(years => 1)->set(day => 1);
+ $candidate = nth_week_of_month($candidate, $week, $day);
+ }
} elsif ($pat =~ m/^$monthpat$weekpat$/) {
- # MMWW: published during given week of given month
- my ($month, $week) = ($1, $2);
+ # MMWW: published during given week of given month
+ my ($month, $week) = ($1, $2);
- $candidate = nth_week_of_month(DateTime->new(year => $dt->year,
- month=> $month,
- day => 1),
- $week,
- 'th');
- if ($candidate <= $dt) {
- # Already past the pattern date this year, move to next year
- $candidate->add(years => 1)->set(day => 1);
- $candidate = nth_week_of_month($candidate, $week, 'th');
- }
+ $candidate = nth_week_of_month(
+ DateTime->new(
+ year => $dt->year,
+ month => $month,
+ day => 1
+ ),
+ $week, 'th'
+ );
+ if ($candidate <= $dt) {
+ # Already past the pattern date this year, move to next year
+ $candidate->add(years => 1)->set(day => 1);
+ $candidate = nth_week_of_month($candidate, $week, 'th');
+ }
} else {
- carp "invalid week pattern '$pat'";
- return undef;
+ carp "invalid week pattern '$pat'";
+ return undef;
}
$cur[0] = $candidate->year;
@@ -340,14 +373,14 @@
$cur[2] = $candidate->day;
foreach my $i (0..$#cur) {
- $cur[$i] = '0' . (0+$cur[$i]) if $cur[$i] < 10;
+ $cur[$i] = '0' . (0 + $cur[$i]) if $cur[$i] < 10;
}
return @cur;
}
sub match_month {
- my $pat = shift;
+ my $pat = shift;
my @date = @_;
return ($pat eq $date[1]);
@@ -358,9 +391,9 @@
my @cur = @_;
if ($cur[1] >= $pat) {
- # Current date is on or after the patter date, so the next
- # occurence is next year
- $cur[0] += 1;
+ # Current date is on or after the patter date, so the next
+ # occurence is next year
+ $cur[0] += 1;
}
# The year is right, just set the month to the pattern date.
@@ -370,7 +403,7 @@
}
sub match_season {
- my $pat = shift;
+ my $pat = shift;
my @date = @_;
return ($pat eq $date[1]);
@@ -383,14 +416,14 @@
# printf("# subsequent_season: pat='%s', cur='%s'\n", $pat, join('/', at cur));
if (($pat < 21) || ($pat > 24)) {
- carp "Unexpected season '$pat'";
- return undef;
+ carp "Unexpected season '$pat'";
+ return undef;
}
if ($cur[1] >= $pat) {
- # current season is on or past pattern season in this year,
- # advance to next year
- $cur[0] += 1;
+ # current season is on or past pattern season in this year,
+ # advance to next year
+ $cur[0] += 1;
}
# Either we've advanced to the next year or the current season
# is before the pattern season in the current year. Either way,
@@ -401,7 +434,7 @@
}
sub match_year {
- my $pat = shift;
+ my $pat = shift;
my @date = @_;
# XXX WRITE ME
@@ -417,7 +450,7 @@
}
sub match_issue {
- my $pat = shift;
+ my $pat = shift;
my @date = @_;
# We handle enumeration patterns separately. This just
@@ -435,21 +468,21 @@
}
my %dispatch = (
- d => \&match_day,
- e => \&match_issue, # not really a "chron" code
- w => \&match_week,
- m => \&match_month,
- s => \&match_season,
- y => \&match_year,
+ d => \&match_day,
+ e => \&match_issue, # not really a "chron" code
+ w => \&match_week,
+ m => \&match_month,
+ s => \&match_season,
+ y => \&match_year,
);
my %generators = (
- d => \&subsequent_day,
- e => \&subsequent_issue, # not really a "chron" code
- w => \&subsequent_week,
- m => \&subsequent_month,
- s => \&subsequent_season,
- y => \&subsequent_year,
+ d => \&subsequent_day,
+ e => \&subsequent_issue, # not really a "chron" code
+ w => \&subsequent_week,
+ m => \&subsequent_month,
+ s => \&subsequent_season,
+ y => \&subsequent_year,
);
sub dispatch {
@@ -465,23 +498,23 @@
}
my %increments = (
- a => {years => 1}, # annual
- b => {months => 2}, # bimonthly
- c => {days => 3}, # semiweekly
- d => {days => 1}, # daily
- e => {weeks => 2}, # biweekly
- f => {months => 6}, # semiannual
- g => {years => 2}, # biennial
- h => {years => 3}, # triennial
- i => {days => 2}, # three times / week
- j => {days => 10}, # three times /month
- # k => continuous
- m => {months => 1}, # monthly
- q => {months => 3}, # quarterly
- s => {days => 15}, # semimonthly
- t => {months => 4}, # three times / year
- w => {weeks => 1}, # weekly
- # x => completely irregular
+ a => {years => 1}, # annual
+ b => {months => 2}, # bimonthly
+ c => {days => 3}, # semiweekly
+ d => {days => 1}, # daily
+ e => {weeks => 2}, # biweekly
+ f => {months => 6}, # semiannual
+ g => {years => 2}, # biennial
+ h => {years => 3}, # triennial
+ i => {days => 2}, # three times / week
+ j => {days => 10}, # three times /month
+ # k => continuous
+ m => {months => 1}, # monthly
+ q => {months => 3}, # quarterly
+ s => {days => 15}, # semimonthly
+ t => {months => 4}, # three times / year
+ w => {weeks => 1}, # weekly
+ # x => completely irregular
);
sub can_increment {
@@ -493,49 +526,51 @@
sub incr_date {
my $freq = shift;
my $incr = $increments{$freq};
- my @new = @_;
+ my @new = @_;
if (scalar(@new) == 1) {
- # only a year is specified. Next date is easy
- $new[0] += $incr->{years} || 1;
+ # only a year is specified. Next date is easy
+ $new[0] += $incr->{years} || 1;
} elsif (scalar(@new) == 2) {
- # Year and month or season
- if ($new[1] > 20) {
- # season
- $new[1] += ($incr->{months}/3) || 1;
- if ($new[1] > 24) {
- # carry
- $new[0] += 1;
- $new[1] -= 4; # 25 - 4 == 21 == Spring after Winter
- }
- } else {
- # month
- $new[1] += $incr->{months} || 1;
- if ($new[1] > 12) {
- # carry
- $new[0] += 1;
- $new[1] -= 12;
- }
- }
+ # Year and month or season
+ if ($new[1] > 20) {
+ # season
+ $new[1] += ($incr->{months} / 3) || 1;
+ if ($new[1] > 24) {
+ # carry
+ $new[0] += 1;
+ $new[1] -= 4; # 25 - 4 == 21 == Spring after Winter
+ }
+ } else {
+ # month
+ $new[1] += $incr->{months} || 1;
+ if ($new[1] > 12) {
+ # carry
+ $new[0] += 1;
+ $new[1] -= 12;
+ }
+ }
} elsif (scalar(@new) == 3) {
- # Year, Month, Day: now it gets complicated.
+ # Year, Month, Day: now it gets complicated.
- if ($new[2] =~ /^[0-9]+$/) {
- # A single number for the day of month, relatively simple
- my $dt = DateTime->new(year => $new[0],
- month=> $new[1],
- day => $new[2]);
- $dt->add(%{$incr});
- $new[0] = $dt->year;
- $new[1] = $dt->month;
- $new[2] = $dt->day;
- }
+ if ($new[2] =~ /^[0-9]+$/) {
+ # A single number for the day of month, relatively simple
+ my $dt = DateTime->new(
+ year => $new[0],
+ month => $new[1],
+ day => $new[2]
+ );
+ $dt->add(%{$incr});
+ $new[0] = $dt->year;
+ $new[1] = $dt->month;
+ $new[2] = $dt->day;
+ }
} else {
- warn("Don't know how to cope with @new");
+ warn("Don't know how to cope with @new");
}
foreach my $i (0..$#new) {
- $new[$i] = '0' . (0+$new[$i]) if $new[$i] < 10;
+ $new[$i] = '0' . (0 + $new[$i]) if $new[$i] < 10;
}
return @new;
Modified: trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Holding.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Holding.pm 2009-11-14 09:11:53 UTC (rev 14916)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/Holding.pm 2009-11-14 19:59:50 UTC (rev 14917)
@@ -10,51 +10,54 @@
use base 'MARC::Field';
sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $seqno = shift;
- my $self = shift;
- my $caption = shift;
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $seqno = shift;
+ my $self = shift;
+ my $caption = shift;
my $last_enum = undef;
- $self->{_mfhdh_SEQNO} = $seqno;
- $self->{_mfhdh_CAPTION} = $caption;
- $self->{_mfhdh_DESCR} = {};
- $self->{_mfhdh_COPY} = undef;
- $self->{_mfhdh_BREAK} = undef;
- $self->{_mfhdh_NOTES} = {};
+ $self->{_mfhdh_SEQNO} = $seqno;
+ $self->{_mfhdh_CAPTION} = $caption;
+ $self->{_mfhdh_DESCR} = {};
+ $self->{_mfhdh_COPY} = undef;
+ $self->{_mfhdh_BREAK} = undef;
+ $self->{_mfhdh_NOTES} = {};
$self->{_mfhdh_COPYRIGHT} = [];
foreach my $subfield ($self->subfields) {
- my ($key, $val) = @$subfield;
+ my ($key, $val) = @$subfield;
- if (($caption && $caption->enumeration_is_chronology && $key =~ /[a-h]/) || $key =~ /[i-m]/) {
- # Chronology
- $self->{_mfhdh_SUBFIELDS}->{$key} = $val;
- } elsif ($key =~ /[a-h]/) {
- # Enumeration details of holdings
- $self->{_mfhdh_SUBFIELDS}->{$key} = {HOLDINGS => $val,
- UNIT => undef,};
- $last_enum = $key;
- } elsif ($key eq 'o') {
- warn '$o specified prior to first enumeration'
- unless defined($last_enum);
- $self->{_mfhdh_SUBFIELDS}->{$last_enum}->{UNIT} = $val;
- $last_enum = undef;
- } elsif ($key =~ /[npq]/) {
- $self->{_mfhdh_DESCR}->{$key} = $val;
- } elsif ($key eq 's') {
- push @{$self->{_mfhdh_COPYRIGHT}}, $val;
- } elsif ($key eq 't') {
- $self->{_mfhdh_COPY} = $val;
- } elsif ($key eq 'w') {
- carp "Unrecognized break indicator '$val'"
- unless $val =~ /^[gn]$/;
- $self->{_mfhdh_BREAK} = $val;
- }
+ if (($caption && $caption->enumeration_is_chronology && $key =~ /[a-h]/)
+ || $key =~ /[i-m]/) {
+ # Chronology
+ $self->{_mfhdh_SUBFIELDS}->{$key} = $val;
+ } elsif ($key =~ /[a-h]/) {
+ # Enumeration details of holdings
+ $self->{_mfhdh_SUBFIELDS}->{$key} = {
+ HOLDINGS => $val,
+ UNIT => undef,
+ };
+ $last_enum = $key;
+ } elsif ($key eq 'o') {
+ warn '$o specified prior to first enumeration'
+ unless defined($last_enum);
+ $self->{_mfhdh_SUBFIELDS}->{$last_enum}->{UNIT} = $val;
+ $last_enum = undef;
+ } elsif ($key =~ /[npq]/) {
+ $self->{_mfhdh_DESCR}->{$key} = $val;
+ } elsif ($key eq 's') {
+ push @{$self->{_mfhdh_COPYRIGHT}}, $val;
+ } elsif ($key eq 't') {
+ $self->{_mfhdh_COPY} = $val;
+ } elsif ($key eq 'w') {
+ carp "Unrecognized break indicator '$val'"
+ unless $val =~ /^[gn]$/;
+ $self->{_mfhdh_BREAK} = $val;
+ }
}
- bless ($self, $class);
+ bless($self, $class);
return $self;
}
@@ -71,109 +74,128 @@
}
sub format_chron {
- my $self = shift;
+ my $self = shift;
my $caption = $self->{_mfhdh_CAPTION};
my @keys;
- my $str = '';
- my %month = ( '01' => 'Jan.', '02' => 'Feb.', '03' => 'Mar.',
- '04' => 'Apr.', '05' => 'May ', '06' => 'Jun.',
- '07' => 'Jul.', '08' => 'Aug.', '09' => 'Sep.',
- '10' => 'Oct.', '11' => 'Nov.', '12' => 'Dec.',
- '21' => 'Spring', '22' => 'Summer',
- '23' => 'Autumn', '24' => 'Winter' );
+ my $str = '';
+ my %month = (
+ '01' => 'Jan.',
+ '02' => 'Feb.',
+ '03' => 'Mar.',
+ '04' => 'Apr.',
+ '05' => 'May ',
+ '06' => 'Jun.',
+ '07' => 'Jul.',
+ '08' => 'Aug.',
+ '09' => 'Sep.',
+ '10' => 'Oct.',
+ '11' => 'Nov.',
+ '12' => 'Dec.',
+ '21' => 'Spring',
+ '22' => 'Summer',
+ '23' => 'Autumn',
+ '24' => 'Winter'
+ );
@keys = @_;
- foreach my $i (0 .. @keys) {
- my $key = $keys[$i];
- my $capstr;
- my $chron;
- my $sep;
+ foreach my $i (0.. at keys) {
+ my $key = $keys[$i];
+ my $capstr;
+ my $chron;
+ my $sep;
- last if !defined $caption->capstr($key);
+ last if !defined $caption->capstr($key);
- $capstr = $caption->capstr($key);
- if (substr($capstr,0,1) eq '(') {
- # a caption enclosed in parentheses is not displayed
- $capstr = '';
- }
+ $capstr = $caption->capstr($key);
+ if (substr($capstr, 0, 1) eq '(') {
+ # a caption enclosed in parentheses is not displayed
+ $capstr = '';
+ }
- # If this is the second level of chronology, then it's
- # likely to be a month or season, so we should use the
- # string name rather than the number given.
- if (($i == 1) && exists $month{$self->{_mfhdh_SUBFIELDS}->{$key}}) {
- $chron = $month{$self->{_mfhdh_SUBFIELDS}->{$key}};
- } else {
- $chron = $self->{_mfhdh_SUBFIELDS}->{$key};
- }
+ # If this is the second level of chronology, then it's
+ # likely to be a month or season, so we should use the
+ # string name rather than the number given.
+ if (($i == 1) && exists $month{$self->{_mfhdh_SUBFIELDS}->{$key}}) {
+ $chron = $month{$self->{_mfhdh_SUBFIELDS}->{$key}};
+ } else {
+ $chron = $self->{_mfhdh_SUBFIELDS}->{$key};
+ }
-
- $str .= (($i == 0 || $str =~ /[. ]$/) ? '' : ':') . $capstr . $chron;
+ $str .= (($i == 0 || $str =~ /[. ]$/) ? '' : ':') . $capstr . $chron;
}
return $str;
}
sub format {
- my $self = shift;
+ my $self = shift;
my $caption = $self->{_mfhdh_CAPTION};
- my $str = '';
+ my $str = '';
if ($caption->type_of_unit) {
- $str = $caption->type_of_unit . ' ';
+ $str = $caption->type_of_unit . ' ';
}
if ($caption->enumeration_is_chronology) {
- # if issues are identified by chronology only, then the
- # chronology data is stored in the enumeration subfields,
- # so format those fields as if they were chronological.
- $str = $self->format_chron('a'..'f');
+ # if issues are identified by chronology only, then the
+ # chronology data is stored in the enumeration subfields,
+ # so format those fields as if they were chronological.
+ $str = $self->format_chron('a'..'f');
} else {
- # OK, there is enumeration data and maybe chronology
- # data as well, format both parts appropriately
+ # OK, there is enumeration data and maybe chronology
+ # data as well, format both parts appropriately
- # Enumerations
- foreach my $key ('a'..'f') {
- my $capstr;
- my $chron;
- my $sep;
+ # Enumerations
+ foreach my $key ('a'..'f') {
+ my $capstr;
+ my $chron;
+ my $sep;
- last if !defined $caption->capstr($key);
+ last if !defined $caption->capstr($key);
- $capstr = $caption->capstr($key);
- if (substr($capstr, 0, 1) eq '(') {
- # a caption enclosed in parentheses is not displayed
- $capstr = '';
- }
- $str .= ($key eq 'a' ? '' : ':') . $capstr . $self->{_mfhdh_SUBFIELDS}->{$key}->{HOLDINGS};
- }
+ $capstr = $caption->capstr($key);
+ if (substr($capstr, 0, 1) eq '(') {
+ # a caption enclosed in parentheses is not displayed
+ $capstr = '';
+ }
+ $str .=
+ ($key eq 'a' ? '' : ':')
+ . $capstr
+ . $self->{_mfhdh_SUBFIELDS}->{$key}->{HOLDINGS};
+ }
- # Chronology
- if (defined $caption->capstr('i')) {
- $str .= '(';
- $str .= $self->format_chron('i'..'l');
- $str .= ')';
- }
+ # Chronology
+ if (defined $caption->capstr('i')) {
+ $str .= '(';
+ $str .= $self->format_chron('i'..'l');
+ $str .= ')';
+ }
- if ($caption->capstr('g')) {
- # There's at least one level of alternative enumeration
- $str .= '=';
- foreach my $key ('g', 'h') {
- $str .= ($key eq 'g' ? '' : ':') . $caption->capstr($key) . $self->{_mfhdh_SUBFIELDS}->{$key}->{HOLDINGS};
- }
+ if ($caption->capstr('g')) {
+ # There's at least one level of alternative enumeration
+ $str .= '=';
+ foreach my $key ('g', 'h') {
+ $str .=
+ ($key eq 'g' ? '' : ':')
+ . $caption->capstr($key)
+ . $self->{_mfhdh_SUBFIELDS}->{$key}->{HOLDINGS};
+ }
- # This assumes that alternative chronology is only ever
- # provided if there is an alternative enumeration.
- if ($caption->capstr('m')) {
- # Alternative Chronology
- $str .= '(';
- $str .= $caption->capstr('m') . $self->{_mfhdh_SUBFIELDS}->{m}->{HOLDINGS};
- $str .= ')';
- }
- }
+ # This assumes that alternative chronology is only ever
+ # provided if there is an alternative enumeration.
+ if ($caption->capstr('m')) {
+ # Alternative Chronology
+ $str .= '(';
+ $str .=
+ $caption->capstr('m')
+ . $self->{_mfhdh_SUBFIELDS}->{m}->{HOLDINGS};
+ $str .= ')';
+ }
+ }
}
# Public Note
- $str .= ' '. $caption->capstr('z') if (defined $caption->capstr('z'));
+ $str .= ' ' . $caption->capstr('z') if (defined $caption->capstr('z'));
# Breaks in the sequence
if (defined($self->{_mfhdh_BREAK})) {
@@ -189,13 +211,12 @@
return $str;
}
-
# next: Given a holding statement, return a hash containing the
# enumeration values for the next issues, whether we hold it or not
# Just pass through to Caption::next
#
sub next {
- my $self = shift;
+ my $self = shift;
my $caption = $self->{_mfhdh_CAPTION};
return $caption->next($self);
@@ -208,42 +229,47 @@
#
#
sub match {
- my $self = shift;
- my $pat = shift;
+ my $self = shift;
+ my $pat = shift;
my $caption = $self->{_mfhdh_CAPTION};
foreach my $key ('a'..'f') {
- my $nextkey;
+ my $nextkey;
- ($nextkey = $key)++;
- # If the next smaller enumeration exists, and is numbered
- # continuously, then we don't need to check this one, because
- # gaps in issue numbering matter, not changes in volume numbering
- next if (exists $self->{_mfhdh_SUBFIELDS}->{$nextkey}
- && !$caption->capfield($nextkey)->{RESTART});
+ ($nextkey = $key)++;
+ # If the next smaller enumeration exists, and is numbered
+ # continuously, then we don't need to check this one, because
+ # gaps in issue numbering matter, not changes in volume numbering
+ next
+ if (exists $self->{_mfhdh_SUBFIELDS}->{$nextkey}
+ && !$caption->capfield($nextkey)->{RESTART});
- # If a subfield exists in $self but not in $pat, or vice versa
- # or if the field has different values, then fail
- if (exists($self->{_mfhdh_SUBFIELDS}->{$key}) != exists($pat->{$key})
- || (exists $pat->{$key}
- && ($self->{_mfhdh_SUBFIELDS}->{$key}->{HOLDINGS} ne $pat->{$key}))) {
- return 0;
- }
+ # If a subfield exists in $self but not in $pat, or vice versa
+ # or if the field has different values, then fail
+ if (
+ exists($self->{_mfhdh_SUBFIELDS}->{$key}) != exists($pat->{$key})
+ || (exists $pat->{$key}
+ && ($self->{_mfhdh_SUBFIELDS}->{$key}->{HOLDINGS} ne
+ $pat->{$key}))
+ ) {
+ return 0;
+ }
}
return 1;
}
-#
+#
# Check that all the fields in a holdings statement are
# included in the corresponding caption.
-#
+#
sub validate {
my $self = shift;
foreach my $key (keys %{$self->{_mfhdh_SUBFIELDS}}) {
- if (!$self->{_mfhdh_CAPTION} || !$self->{_mfhdh_CAPTION}->capfield($key)) {
- return 0;
- }
+ if ( !$self->{_mfhdh_CAPTION}
+ || !$self->{_mfhdh_CAPTION}->capfield($key)) {
+ return 0;
+ }
}
return 1;
}
Modified: trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/test/mfhd.t
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/test/mfhd.t 2009-11-14 09:11:53 UTC (rev 14916)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD/test/mfhd.t 2009-11-14 19:59:50 UTC (rev 14917)
@@ -12,13 +12,13 @@
sub right_answer {
my $holding = shift;
- my $answer = {};
+ my $answer = {};
foreach my $subfield (split(/\|/, $holding->subfield('x'))) {
- next unless $subfield;
+ next unless $subfield;
- my ($key, $val) = unpack('aa*', $subfield);
- $answer->{$key} = $val;
+ my ($key, $val) = unpack('aa*', $subfield);
+ $answer->{$key} = $val;
}
return $answer;
@@ -31,8 +31,8 @@
# skim to beginning of record (a non-blank, non comment line)
while ($line = <DATA>) {
- chomp $line;
- last if (!($line =~ /^\s*$/) && !($line =~ /^#/));
+ chomp $line;
+ last if (!($line =~ /^\s*$/) && !($line =~ /^#/));
}
return undef if !$line;
@@ -42,35 +42,39 @@
carp('No record created!') unless $marc;
$marc->leader('01119nas 2200313 a 4500');
- $marc->append_fields(MARC::Field->new('008', '970701c18439999enkwr p 0 a0eng '));
- $marc->append_fields(MARC::Field->new('035', '', '',
- a => sprintf('%04d', $testno)));
+ $marc->append_fields(
+ MARC::Field->new('008', '970701c18439999enkwr p 0 a0eng '));
+ $marc->append_fields(
+ MARC::Field->new('035', '', '', a => sprintf('%04d', $testno)));
while ($line) {
- next if $line =~ /^#/; # allow embedded comments
+ next if $line =~ /^#/; # allow embedded comments
- return $marc if $line =~ /^\s*$/;
+ return $marc if $line =~ /^\s*$/;
- my ($fieldno, $indicators, $rest) = split(/ /, $line, 3);
- my @inds = unpack('cc', $indicators);
- my $field;
- my @subfields;
+ my ($fieldno, $indicators, $rest) = split(/ /, $line, 3);
+ my @inds = unpack('cc', $indicators);
+ my $field;
+ my @subfields;
- @subfields = ();
- foreach my $subfield (split(/\$/, $rest)) {
- next unless $subfield;
+ @subfields = ();
+ foreach my $subfield (split(/\$/, $rest)) {
+ next unless $subfield;
- my ($key, $val) = unpack('aa*', $subfield);
- push @subfields, $key, $val;
- }
+ my ($key, $val) = unpack('aa*', $subfield);
+ push @subfields, $key, $val;
+ }
- $field = MARC::Field->new($fieldno, $inds[0], $inds[1],
- a => 'scratch', @subfields);
+ $field = MARC::Field->new(
+ $fieldno, $inds[0], $inds[1],
+ a => 'scratch',
+ @subfields
+ );
- $marc->append_fields($field);
+ $marc->append_fields($field);
- $line = <DATA>;
- chomp $line if $line;
+ $line = <DATA>;
+ chomp $line if $line;
}
return $marc;
}
@@ -81,22 +85,22 @@
while ($rec = load_MARC_rec) {
$rec = MFHD->new($rec);
- foreach my $cap (sort {$a->tag <=> $b->tag} $rec->field('85.')) {
- my $htag;
- my @holdings;
+ foreach my $cap (sort { $a->tag <=> $b->tag } $rec->field('85.')) {
+ my $htag;
+ my @holdings;
- ($htag = $cap->tag) =~ s/^85/86/;
- @holdings = $rec->holdings($htag, $cap->subfield('8'));
+ ($htag = $cap->tag) =~ s/^85/86/;
+ @holdings = $rec->holdings($htag, $cap->subfield('8'));
- next unless scalar @holdings;
- foreach my $field (@holdings) {
- TODO: {
- local $TODO = "unimplemented"
- if ($field->subfield('z') =~ /^TODO/);
- is_deeply($field->next, right_answer($field),
- $field->subfield('8') . ': ' . $field->subfield('z'));
- }
- }
+ next unless scalar @holdings;
+ foreach my $field (@holdings) {
+ TODO: {
+ local $TODO = "unimplemented"
+ if ($field->subfield('z') =~ /^TODO/);
+ is_deeply($field->next, right_answer($field),
+ $field->subfield('8') . ': ' . $field->subfield('z'));
+ }
+ }
}
}
Modified: trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD.pm 2009-11-14 09:11:53 UTC (rev 14916)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHD.pm 2009-11-14 19:59:50 UTC (rev 14917)
@@ -12,58 +12,60 @@
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
- my $self = shift;
+ my $self = shift;
$self->{_mfhd_CAPTIONS} = {};
$self->{_mfhd_COMPRESSIBLE} = (substr($self->leader, 17, 1) =~ /[45]/);
foreach my $field ('853', '854', '855') {
- my $captions = {};
- foreach my $caption ($self->field($field)) {
- my $cap_id;
+ my $captions = {};
+ foreach my $caption ($self->field($field)) {
+ my $cap_id;
- $cap_id = $caption->subfield('8') || '0';
+ $cap_id = $caption->subfield('8') || '0';
- if (exists $captions->{$cap_id}) {
- carp "Multiple MFHD captions with label '$cap_id'";
- }
+ if (exists $captions->{$cap_id}) {
+ carp "Multiple MFHD captions with label '$cap_id'";
+ }
- $captions->{$cap_id} = new MFHD::Caption($caption);
- if ($self->{_mfhd_COMPRESSIBLE}) {
- $self->{_mfhd_COMPRESSIBLE} &&= $captions->{$cap_id}->compressible;
- }
- }
- $self->{_mfhd_CAPTIONS}->{$field} = $captions;
+ $captions->{$cap_id} = new MFHD::Caption($caption);
+ if ($self->{_mfhd_COMPRESSIBLE}) {
+ $self->{_mfhd_COMPRESSIBLE} &&=
+ $captions->{$cap_id}->compressible;
+ }
+ }
+ $self->{_mfhd_CAPTIONS}->{$field} = $captions;
}
foreach my $field ('863', '864', '865') {
- my $holdings = {};
- my $cap_field;
+ my $holdings = {};
+ my $cap_field;
- ($cap_field = $field) =~ s/6/5/;
+ ($cap_field = $field) =~ s/6/5/;
- foreach my $hfield ($self->field($field)) {
- my ($linkage, $link_id, $seqno);
- my $holding;
+ foreach my $hfield ($self->field($field)) {
+ my ($linkage, $link_id, $seqno);
+ my $holding;
- $linkage = $hfield->subfield('8');
- ($link_id, $seqno) = split(/\./, $linkage);
+ $linkage = $hfield->subfield('8');
+ ($link_id, $seqno) = split(/\./, $linkage);
- if (!exists $holdings->{$link_id}) {
- $holdings->{$link_id} = {};
- }
- $holding = new MFHD::Holding($seqno, $hfield,
- $self->{_mfhd_CAPTIONS}->{$cap_field}->{$link_id});
- $holdings->{$link_id}->{$seqno} = $holding;
+ if (!exists $holdings->{$link_id}) {
+ $holdings->{$link_id} = {};
+ }
+ $holding =
+ new MFHD::Holding($seqno, $hfield,
+ $self->{_mfhd_CAPTIONS}->{$cap_field}->{$link_id});
+ $holdings->{$link_id}->{$seqno} = $holding;
- if ($self->{_mfhd_COMPRESSIBLE}) {
- $self->{_mfhd_COMPRESSIBLE} &&= $holding->validate;
- }
- }
- $self->{_mfhd_HOLDINGS}->{$field} = $holdings;
+ if ($self->{_mfhd_COMPRESSIBLE}) {
+ $self->{_mfhd_COMPRESSIBLE} &&= $holding->validate;
+ }
+ }
+ $self->{_mfhd_HOLDINGS}->{$field} = $holdings;
}
- bless ($self, $class);
+ bless($self, $class);
return $self;
}
@@ -74,18 +76,20 @@
}
sub captions {
- my $self = shift;
+ my $self = shift;
my $field = shift;
- return sort keys %{$self->{_mfhd_CAPTIONS}->{$field}}
+ return sort keys %{$self->{_mfhd_CAPTIONS}->{$field}};
}
sub holdings {
- my $self = shift;
+ my $self = shift;
my $field = shift;
my $capid = shift;
- return sort {$a->seqno <=> $b->seqno} values %{$self->{_mfhd_HOLDINGS}->{$field}->{$capid}};
+ return
+ sort { $a->seqno <=> $b->seqno }
+ values %{$self->{_mfhd_HOLDINGS}->{$field}->{$capid}};
}
1;
Modified: trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHDParser.pm
===================================================================
--- trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHDParser.pm 2009-11-14 09:11:53 UTC (rev 14916)
+++ trunk/Open-ILS/src/perlmods/OpenILS/Utils/MFHDParser.pm 2009-11-14 19:59:50 UTC (rev 14917)
@@ -1,5 +1,6 @@
package OpenILS::Utils::MFHDParser;
-use strict; use warnings;
+use strict;
+use warnings;
use OpenSRF::EX qw/:try/;
use Time::HiRes qw(time);
@@ -11,7 +12,7 @@
use MARC::File::XML (BinaryEncoding => 'utf8');
use Data::Dumper;
-sub new { return bless( {}, shift() ); }
+sub new { return bless({}, shift()); }
=head1 Subroutines
@@ -26,20 +27,20 @@
=cut
sub format_textual_holdings {
- my ($self, $field) = @_;
- my $holdings;
- my $public_note;
+ my ($self, $field) = @_;
+ my $holdings;
+ my $public_note;
- $holdings = $field->subfield('a');
- if (!$holdings) {
- return undef;
- }
+ $holdings = $field->subfield('a');
+ if (!$holdings) {
+ return undef;
+ }
- $public_note = $field->subfield('z');
- if ($public_note) {
- return "$holdings - $public_note";
- }
- return $holdings;
+ $public_note = $field->subfield('z');
+ if ($public_note) {
+ return "$holdings - $public_note";
+ }
+ return $holdings;
}
=over
@@ -51,131 +52,143 @@
Returns a Perl hash containing fields of interest from the MFHD record
=cut
+
sub mfhd_to_hash {
- my ($self, $mfhd_xml) = @_;
+ my ($self, $mfhd_xml) = @_;
- my $marc;
- my $mfhd;
+ my $marc;
+ my $mfhd;
- my $location = '';
- my $holdings = [];
- my $supplements = [];
- my $indexes = [];
- my $current_holdings = [];
- my $current_supplements = [];
- my $current_indexes = [];
- my $online = []; # Laurentian extension to MFHD standard
- my $missing = []; # Laurentian extension to MFHD standard
- my $incomplete = []; # Laurentian extension to MFHD standard
+ my $location = '';
+ my $holdings = [];
+ my $supplements = [];
+ my $indexes = [];
+ my $current_holdings = [];
+ my $current_supplements = [];
+ my $current_indexes = [];
+ my $online = []; # Laurentian extension to MFHD standard
+ my $missing = []; # Laurentian extension to MFHD standard
+ my $incomplete = []; # Laurentian extension to MFHD standard
- try {
- $marc = MARC::Record->new_from_xml($mfhd_xml);
- } otherwise {
- $logger->error("Failed to convert MFHD XML to MARC: " . shift());
- $logger->error("Failed MFHD XML: $mfhd_xml");
- };
+ try {
+ $marc = MARC::Record->new_from_xml($mfhd_xml);
+ }
+ otherwise {
+ $logger->error("Failed to convert MFHD XML to MARC: " . shift());
+ $logger->error("Failed MFHD XML: $mfhd_xml");
+ };
- if (!$marc) {
- return undef;
- }
+ if (!$marc) {
+ return undef;
+ }
- try {
- $mfhd = MFHD->new($marc);
- } otherwise {
- $logger->error("Failed to parse MFHD: " . shift());
- $logger->error("Failed MFHD XML: $mfhd_xml");
- };
+ try {
+ $mfhd = MFHD->new($marc);
+ }
+ otherwise {
+ $logger->error("Failed to parse MFHD: " . shift());
+ $logger->error("Failed MFHD XML: $mfhd_xml");
+ };
- if (!$mfhd) {
- return undef;
- }
+ if (!$mfhd) {
+ return undef;
+ }
- try {
- foreach my $field ($marc->field('852')) {
- foreach my $subfield_ref ($field->subfields) {
- my ($subfield, $data) = @$subfield_ref;
- $location .= $data . " -- ";
- }
- }
- } otherwise {
- $logger->error("MFHD location parsing error: " . shift());
- };
+ try {
+ foreach my $field ($marc->field('852')) {
+ foreach my $subfield_ref ($field->subfields) {
+ my ($subfield, $data) = @$subfield_ref;
+ $location .= $data . " -- ";
+ }
+ }
+ }
+ otherwise {
+ $logger->error("MFHD location parsing error: " . shift());
+ };
- $location =~ s/ -- $//;
+ $location =~ s/ -- $//;
- try {
- foreach my $field ($marc->field('866')) {
- my $textual_holdings = $self->format_textual_holdings($field);
- if ($textual_holdings) {
- push @$holdings, $textual_holdings;
- }
- }
- foreach my $field ($marc->field('867')) {
- my $textual_holdings = $self->format_textual_holdings($field);
- if ($textual_holdings) {
- push @$supplements, $textual_holdings;
- }
- }
- foreach my $field ($marc->field('868')) {
- my $textual_holdings = $self->format_textual_holdings($field);
- if ($textual_holdings) {
- push @$indexes, $textual_holdings;
- }
- }
+ try {
+ foreach my $field ($marc->field('866')) {
+ my $textual_holdings = $self->format_textual_holdings($field);
+ if ($textual_holdings) {
+ push @$holdings, $textual_holdings;
+ }
+ }
+ foreach my $field ($marc->field('867')) {
+ my $textual_holdings = $self->format_textual_holdings($field);
+ if ($textual_holdings) {
+ push @$supplements, $textual_holdings;
+ }
+ }
+ foreach my $field ($marc->field('868')) {
+ my $textual_holdings = $self->format_textual_holdings($field);
+ if ($textual_holdings) {
+ push @$indexes, $textual_holdings;
+ }
+ }
- foreach my $cap_id ($mfhd->captions('853')) {
- my @curr_holdings = $mfhd->holdings('863', $cap_id);
- next unless scalar @curr_holdings;
- foreach (@curr_holdings) {
- push @$current_holdings, $_->format();
- }
- }
+ foreach my $cap_id ($mfhd->captions('853')) {
+ my @curr_holdings = $mfhd->holdings('863', $cap_id);
+ next unless scalar @curr_holdings;
+ foreach (@curr_holdings) {
+ push @$current_holdings, $_->format();
+ }
+ }
- foreach my $cap_id ($mfhd->captions('854')) {
- my @curr_supplements = $mfhd->holdings('864', $cap_id);
- next unless scalar @curr_supplements;
- foreach (@curr_supplements) {
- push @$current_supplements, $_->format();
- }
- }
+ foreach my $cap_id ($mfhd->captions('854')) {
+ my @curr_supplements = $mfhd->holdings('864', $cap_id);
+ next unless scalar @curr_supplements;
+ foreach (@curr_supplements) {
+ push @$current_supplements, $_->format();
+ }
+ }
- foreach my $cap_id ($mfhd->captions('855')) {
- my @curr_indexes = $mfhd->holdings('865', $cap_id);
- next unless scalar @curr_indexes;
- foreach (@curr_indexes) {
- push @$current_indexes, $_->format();
- }
- }
+ foreach my $cap_id ($mfhd->captions('855')) {
+ my @curr_indexes = $mfhd->holdings('865', $cap_id);
+ next unless scalar @curr_indexes;
+ foreach (@curr_indexes) {
+ push @$current_indexes, $_->format();
+ }
+ }
- # Laurentian extensions
- foreach my $field ($marc->field('530')) {
- my $online_stmt = $self->format_textual_holdings($field);
- if ($online_stmt) {
- push @$online, $online_stmt;
- }
- }
+ # Laurentian extensions
+ foreach my $field ($marc->field('530')) {
+ my $online_stmt = $self->format_textual_holdings($field);
+ if ($online_stmt) {
+ push @$online, $online_stmt;
+ }
+ }
- foreach my $field ($marc->field('590')) {
- my $missing_stmt = $self->format_textual_holdings($field);
- if ($missing_stmt) {
- push @$missing, $missing_stmt;
- }
- }
+ foreach my $field ($marc->field('590')) {
+ my $missing_stmt = $self->format_textual_holdings($field);
+ if ($missing_stmt) {
+ push @$missing, $missing_stmt;
+ }
+ }
- foreach my $field ($marc->field('591')) {
- my $incomplete_stmt = $self->format_textual_holdings($field);
- if ($incomplete_stmt) {
- push @$incomplete, $incomplete_stmt;
- }
- }
- } otherwise {
- $logger->error("MFHD statement parsing error: " . shift());
- };
+ foreach my $field ($marc->field('591')) {
+ my $incomplete_stmt = $self->format_textual_holdings($field);
+ if ($incomplete_stmt) {
+ push @$incomplete, $incomplete_stmt;
+ }
+ }
+ }
+ otherwise {
+ $logger->error("MFHD statement parsing error: " . shift());
+ };
- return { location => $location, holdings => $holdings, current_holdings => $current_holdings,
- supplements => $supplements, current_supplements => $current_supplements,
- indexes => $indexes, current_indexes => $current_indexes,
- missing => $missing, incomplete => $incomplete, };
+ return {
+ location => $location,
+ holdings => $holdings,
+ current_holdings => $current_holdings,
+ supplements => $supplements,
+ current_supplements => $current_supplements,
+ indexes => $indexes,
+ current_indexes => $current_indexes,
+ missing => $missing,
+ incomplete => $incomplete,
+ };
}
=over
@@ -187,21 +200,22 @@
Initialize the serial virtual record (svr) instance
=cut
+
sub init_holdings_virtual_record {
- my $record = Fieldmapper::serial::virtual_record->new;
- $record->id();
- $record->location();
- $record->owning_lib();
- $record->holdings([]);
- $record->current_holdings([]);
- $record->supplements([]);
- $record->current_supplements([]);
- $record->indexes([]);
- $record->current_indexes([]);
- $record->online([]);
- $record->missing([]);
- $record->incomplete([]);
- return $record;
+ my $record = Fieldmapper::serial::virtual_record->new;
+ $record->id();
+ $record->location();
+ $record->owning_lib();
+ $record->holdings([]);
+ $record->current_holdings([]);
+ $record->supplements([]);
+ $record->current_supplements([]);
+ $record->indexes([]);
+ $record->current_indexes([]);
+ $record->online([]);
+ $record->missing([]);
+ $record->incomplete([]);
+ return $record;
}
=over
@@ -213,35 +227,36 @@
Given an MFHD record, return a populated svr instance
=cut
+
sub generate_svr {
- my ($self, $id, $mfhd, $owning_lib) = @_;
+ my ($self, $id, $mfhd, $owning_lib) = @_;
- if (!$mfhd) {
- return undef;
- }
+ if (!$mfhd) {
+ return undef;
+ }
- my $record = init_holdings_virtual_record();
- my $holdings = $self->mfhd_to_hash($mfhd);
+ my $record = init_holdings_virtual_record();
+ my $holdings = $self->mfhd_to_hash($mfhd);
- $record->id($id);
- $record->owning_lib($owning_lib);
+ $record->id($id);
+ $record->owning_lib($owning_lib);
- if (!$holdings) {
- return $record;
- }
+ if (!$holdings) {
+ return $record;
+ }
- $record->location($holdings->{location});
- $record->holdings($holdings->{holdings});
- $record->current_holdings($holdings->{current_holdings});
- $record->supplements($holdings->{supplements});
- $record->current_supplements($holdings->{current_supplements});
- $record->indexes($holdings->{indexes});
- $record->current_indexes($holdings->{current_indexes});
- $record->online($holdings->{online});
- $record->missing($holdings->{missing});
- $record->incomplete($holdings->{incomplete});
+ $record->location($holdings->{location});
+ $record->holdings($holdings->{holdings});
+ $record->current_holdings($holdings->{current_holdings});
+ $record->supplements($holdings->{supplements});
+ $record->current_supplements($holdings->{current_supplements});
+ $record->indexes($holdings->{indexes});
+ $record->current_indexes($holdings->{current_indexes});
+ $record->online($holdings->{online});
+ $record->missing($holdings->{missing});
+ $record->incomplete($holdings->{incomplete});
- return $record;
+ return $record;
}
1;
More information about the open-ils-commits
mailing list