symphony/serials/parser-serctrl.pl

   1 #!/usr/bin/perl
   2
   3 # Copyright 2009-2012, Equinox Software, Inc.
   4 #
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  18
  19 require 5.10.0;
  20
  21 # This is still very rough.
  22
  23 use Getopt::Std;
  24 use Data::Dumper;
  25 use MARC::Field;
  26 use JSON::XS;
  27
  28 use utf8;
  29
  30 # order of field separators, i think:   ! ; : .
  31
  32 # pubcycle_to_scap() was derived at late hours, and isn't totally right.  It's
  33 # also not commented yet as you can see.  Sorry, but this still needs lots of
  34 # work to be reliable and understandable.
  35 #
  36 # $record is one of the objects loaded from serctl.data.  $field is a
  37 # MARC::Field object.
  38 sub pubcycle_to_scap {
  39     my ($record, $field) = @_;
  40
  41     if ($record->{NAM_TYPE} ne 'NUMERATION') {
  42         $field->update(i => '(year)');
  43         $field->update(x => '01');
  44
  45         if ($record->{NAM_TYPE} =~ /SEASON/) {
  46             $field->update(j => '(season)');
  47         } elsif ($record->{NAM_TYPE} =~ /MONTH|DATE/) {
  48             $field->update(j => '(month)');
  49
  50             $field->update(k => '(day)') if $record->{NAM_TYPE} eq 'DATE';
  51         }
  52     }
  53
  54     my @pfields = split /\!/, $record->{PUBCYCLE_DEF};
  55
  56     my @dow = qw/su mo tu we th fr sa/;
  57     my @yf = qw/X a g h/;
  58     my %periods_mo = ( 1 => 'm', 2 => 'b', 3 => 'q', 6 => 'f' );
  59
  60     if (@pfields == 2) {
  61         if ($pfields[0] =~ /^(\d):M$/ and $pfields[1] =~ /^\d+:D$/ and $record->{NAM_TYPE} =~ /MONTH|CUSTOM|SEASON/) {
  62             $pfields[0] =~ /^(\d):M$/;
  63             my $freq_m = $1;
  64             $pfields[1] =~ /^(\d+):D$/;
  65             my $on = $1;
  66             return 0 unless exists $periods_mo{$freq_m}; # not handled
  67             $field->update(
  68                 w => $periods_mo{$freq_m}, y => sprintf('pd%02d', $on)
  69             );
  70             return 1; # early out
  71         }
  72         elsif ($pfields[0] =~ /^[12]:W$/ and $pfields[1] =~ /^\d+:D$/) {
  73             $pfields[0] =~ /^([12]):W$/;
  74             my $freq_w = $1;
  75             $pfields[1] =~ /^(\d+):D$/;
  76             my $on = $1;
  77             $field->update(
  78                 w => ($freq_m == 1 ? 'w' : 'e'), y => sprintf('pd%s', $dow[$on-1])
  79             );
  80             return 1; # early out
  81         }
  82         elsif ($pfields[0] =~ /^[1-3]:Y$/ and $pfields[1] =~ /^\d+:D\.\d+:M$/) {
  83             $pfields[0] =~ /^([1-3]):Y$/;
  84             my $freq_y = $1;
  85             $pfields[1] =~ /^(\d+):D\.(\d+):M$/;
  86             my $on_day = $1;
  87             my $of_mo = $2;
  88             $field->update(
  89                 w => $yf[$freq_y],
  90                 y => sprintf('pd%02d%02d', $of_mo, $on_day)
  91             );
  92             return 1; # early out
  93         }
  94     } elsif (@pfields == 3) {
  95         if ($pfields[0] =~ /^\d:M$/ && $pfields[1] =~ /^\d+:D(;|$)/) {
  96             $pfields[0] =~ /^(\d):M$/;
  97             my $months = $1;
  98
  99             my @dates;
 100             foreach my $date (split /;/, $pfields[1]) {
 101                 $date =~ /^(\d+):D/ or return 0; # not handled
 102                 push @dates, sprintf("%02d", $1);
 103             }
 104             my $potential = 12 / $months * @dates;
 105             my @combos = split /;/, $pfields[2];
 106             my @cparts, @oparts;
 107             foreach my $combo (@combos) {
 108                 if ($combo =~ /^(\d+):M\.0:Y/) {
 109                     my $squash = $1;
 110                     push @cparts, sprintf("%02d/%02d", $squash - 1, $squash);
 111                 } elsif ($combo =~ /(\d+):D\.(\d+):M\.0:Y/) {
 112                     push @oparts, sprintf("%02d%02d", $2, $1);
 113                 } else {
 114                     return 0; # abort, not handled yet
 115                 }
 116             }
 117             my $u;
 118             $u = $potential - @cparts if @cparts;
 119             $u = $potential - @oparts if @oparts;
 120
 121             my $w;
 122             if ($months == 1) {
 123                 $w = $periods_mo{$months};
 124                 $w = 's' if $u > 12;
 125             } elsif (exists $periods_mo{$months}) {
 126                 $w = $periods_mo{$months};
 127             } else {
 128                 return 0; # abort, not handled
 129             }
 130             $field->update(u => $u, v => 'r', w => $w);
 131             $field->add_subfields(y => 'cm' . join(",", @cparts)) if @cparts;
 132             $field->add_subfields(y => 'od' . join(",", @oparts)) if @oparts;
 133             $field->add_subfields(y => 'pd' . join(",", @dates));
 134             return 1; # early out
 135         }
 136     }
 137
 138     return 0; # fail
 139 }
 140
 141 sub record_bits_to_scap {
 142     my ($record) = @_;
 143
 144     # set up constants
 145     my $field = new MARC::Field(
 146         '853',  # tag doesn't really matter here
 147         2 => '0',
 148         8 => '1',
 149         i => '(year)'
 150     );
 151
 152     # when nam_type is true, use sub_iss for numeric $w
 153     $field->update(a => $record->{SERC_LBL1}) if $record->{SERC_LBL1};
 154     if ($record->{SERC_LBL2}) {
 155         $field->update(b => $record->{SERC_LBL2});
 156         $field->update(u => $record->{SERC_LMT2} || 'var');
 157         $field->update(v => 'r');
 158     }
 159
 160     # return the representation we need
 161     return (new JSON::XS)->encode([
 162         $field->indicator(1),
 163         $field->indicator(2),
 164         map { @$_ } $field->subfields
 165     ]) if pubcycle_to_scap($record, $field);
 166
 167     return "null";
 168 }
 169
 170 # actually parses serctl.data, the file with all the DOCUMENT BOUNDARY and
 171 # other stuff
 172 sub load_serctl_export {
 173     my ($filename) = @_;
 174
 175     open FH, "<$filename" or die ("can't read $filename: $!");
 176
 177     my $entries = [];
 178     my $entry;
 179     while (<FH>) {
 180         chomp;
 181
 182         # If we don't match this regex, move to next entry.
 183         if (not /^\.(\w+)\.(?:.+\|a(.+))?$/) {
 184             push @$entries, $entry if $entry;
 185             $entry = {};
 186             next;
 187         }
 188
 189         # If we don't have a defined $2, just move to next line.
 190         next unless defined $2;
 191
 192         $entry->{$1} = $2;
 193     }
 194     close FH;
 195
 196     return $entries;
 197 }
 198
 199 sub unique_keys {
 200     my ($data) = @_;
 201
 202     my $small = {};
 203     foreach my $hash (@$data) {
 204         foreach (keys %$hash) {
 205             $small->{$_} ||= 0;
 206             $small->{$_}++;
 207         }
 208     }
 209
 210     return $small;
 211 }
 212
 213 # The title key map is a simple text file made up of lines. Each line contains
 214 # two tokens separated by a space.  The first one is the value of
 215 # SERC_TITLE_KEY.  The second one is the id of the biblio.record_entry row
 216 # that corresponds to it.  I don't have a good script for making that yet.
 217 # SERC_TITLE_KEY can be different things (ISxN, 035‡a, etc) so you have to
 218 # build the map by using various database queries (and hand de-duping).
 219
 220 sub load_title_key_map {
 221     my ($filename) = @_;
 222
 223     open FH, "<$filename" or die "$filename: $!";
 224
 225     my $map = {};
 226     while (<FH>) {
 227         /^(\S+) (\d+)/ or next;
 228         $map->{$1} = $2;
 229     }
 230
 231     close FH;
 232
 233     return $map;
 234 }
 235
 236 ############################# MAIN ###############################
 237
 238 my $opts = {
 239     "i" => "-",     # input file
 240     "p" => "dump",  # operation
 241     "t" => undef
 242 };
 243 my $operations = {
 244     "dump" => sub { # Just parse input file (serctl.data) and dump resulting
 245                     # data structure
 246         my ($opts) = @_;
 247         print Dumper(load_serctl_export($opts->{i})), "\n";
 248
 249         return 0;
 250     },
 251     "keys" => sub { # Over the whole list of records, how often do all keys
 252                     # appear?  This is an analysis tool.
 253         my ($opts) = @_;
 254         my $freq = unique_keys(load_serctl_export($opts->{i}));
 255
 256         my @keys = reverse sort { $freq->{$a} <=> $freq->{$b} } keys %$freq;
 257
 258         foreach (@keys) {
 259             printf ("%-19s %d\n", $_, $freq->{$_});
 260         }
 261         return 0;
 262     },
 263     "map" => sub {  # Combine records from input file with title key map and
 264                     # perform transformations suitable for evergreen import.
 265         my ($opts) = @_;
 266
 267         my $title_key_map = load_title_key_map($opts->{t});
 268         my $data = load_serctl_export($opts->{i});
 269
 270         foreach my $record (@$data) {
 271             my $title_key = $record->{SERC_TITLE_KEY};
 272             if (!($record->{bre} = $title_key_map->{$title_key})) {
 273                 $record->{unready} = 1;
 274                 next;
 275             }
 276
 277             $record->{number_of_streams} = $record->{SERC_REC_COP};
 278             $record->{subscription_owning_lib} = $record->{SERC_LIB};
 279             $record->{distribtion_holding_lib} = substr($record->{HOLDING_CODE}, 0, 1);
 280
 281             $record->{scap_active} =
 282                 $record->{SERC_STATUS} eq 'ACTIVE' ? 't' : 'f';
 283             $record->{scap_pattern_code} = record_bits_to_scap($record) if $record->{PUBCYCLE_DEF};
 284
 285             # save uppercase keys' values in a note
 286             my @uc_keys = grep { $_ !~ /[a-z]/ } (keys %$record);
 287             $record->{note_text} = join(
 288                 "\n",
 289                 map { "$_: $record->{$_}" } @uc_keys
 290             );
 291
 292             # and remove uppercase keys now
 293             delete $record->{$_} for @uc_keys;
 294         }
 295
 296         if ($opts->{u}) {
 297             my $unready = [grep { $_->{unready} } @$data];
 298             if ($unready) {
 299                 open FH, ">$opts->{u}" or die "$opts->{u}: $!";
 300                 print FH Dumper($unready), "\n";
 301                 close FH;
 302             }
 303         }
 304
 305         print Dumper($data), "\n";
 306
 307         return 0;
 308     }
 309 };
 310
 311 getopts("i:p:t:u:", $opts) or die("usage: $0\n\t[-i infile]\n\t[-p operation]\n\t[-t title_key_map]\n\t[-u dump_file_for_unmapped_records]");
 312
 313
 314 my $operation = lc $opts->{p};
 315 exit $operations->{$operation}->($opts) if exists $operations->{$operation};
 316 die (
 317     "specify a valid operation\n$0 -p [" .
 318     join(" | ", (keys %$operations)) . "]"
 319 );