Equinox-Migration/lib/Equinox/Migration/MapDrivenMARCXMLProc.pm

   1 package Equinox::Migration::MapDrivenMARCXMLProc;
   2
   3 use warnings;
   4 use strict;
   5
   6 use XML::Twig;
   7 use Equinox::Migration::SubfieldMapper 1.004;
   8
   9
  10 =head1 NAME
  11
  12 Equinox::Migration::MapDrivenMARCXMLProc
  13
  14 =head1 VERSION
  15
  16 Version 1.005
  17
  18 =cut
  19
  20 our $VERSION = '1.005';
  21
  22 my $dstore;
  23 my $sfmap;
  24 my @modlist = qw( multi ignoremulti bib required first concatenate );
  25 my %allmods = ();
  26 my $multis = {};
  27 my $reccount;
  28 my $verbose = 0;
  29
  30
  31 =head1 SYNOPSIS
  32
  33 Foo
  34
  35     use Equinox::Migration::MapDrivenMARCXMLProc;
  36
  37
  38 =head1 METHODS
  39
  40
  41 =head2 new
  42
  43 Takes two required arguments: C<mapfile> (which will be passed along
  44 to L<Equinox::Migration::SubfieldMapper> as the basis for its map),
  45 and C<marcfile> (the MARC data to be processed).
  46
  47     my $m = Equinox::Migration::MapDrivenMARCXMLProc->new( mapfile  => FILE,
  48                                                            marcfile => FILE );
  49
  50 =cut
  51
  52 sub new {
  53     my ($class, %args) = @_;
  54
  55     $verbose = 1 if $args{verbose};
  56
  57     my $self = bless { multis => \$multis,
  58                      }, $class;
  59
  60     # initialize map and taglist
  61     die "Argument 'mapfile' must be specified\n" unless ($args{mapfile});
  62     $sfmap = Equinox::Migration::SubfieldMapper->new( file => $args{mapfile},
  63                                                       mods => \@modlist );
  64
  65     # initialize datastore
  66     $dstore = {};
  67     $reccount = 0;            # next record ptr
  68     $dstore->{tags} = $sfmap->tags; # list of all tags
  69     $self->{data} = $dstore;
  70
  71     # initialize twig
  72     die "Argument 'marcfile' must be specified\n" unless ($args{marcfile});
  73     if (-r $args{marcfile}) {
  74         my $xmltwig = XML::Twig->new( twig_handlers => { record => \&parse_record } );
  75         $xmltwig->parsefile( $args{marcfile} );
  76     } else {
  77         die "Can't open marc file: $!\n";
  78     }
  79
  80     return $self;
  81 }
  82
  83 =head2 parse_record
  84
  85 Extracts data from the next record, per the mapping file.
  86
  87 =cut
  88
  89 sub parse_record {
  90     my ($twig, $record) = @_;
  91     my $crec = {}; # current record
  92
  93     my @fields = $record->children;
  94     for my $f (@fields)
  95       { process_field($f, $crec) }
  96
  97     # fill in blank values if needed
  98     for my $mappedtag ( @{ $sfmap->tags }) {
  99         unless (exists $crec->{tmap}{$mappedtag}) {
 100             push @{ $crec->{tags} }, {};
 101             for my $mappedsub ( @{ $sfmap->subfields($mappedtag) } ) {
 102                 my $fieldname = $sfmap->field($mappedtag, $mappedsub);
 103                 my $mods = $sfmap->mods($fieldname);
 104                 next if $mods->{multi};
 105                 $crec->{tags}[-1]{uni}{$mappedsub} = '';
 106                 $crec->{tags}[-1]{multi} = undef;
 107                 $crec->{tags}[-1]{tag} = $mappedtag;
 108             }
 109             push @{ $crec->{tmap}{$mappedtag} }, $#{ $crec->{tags} };
 110         }
 111     }
 112
 113     # cleanup memory and increment pointer
 114     $record->purge;
 115     $reccount++;
 116
 117     # check for required fields
 118     check_required($crec);
 119     push @{ $dstore->{recs} }, $crec;
 120
 121     print STDERR "$reccount\n"
 122       if ($verbose and !($reccount % 1000));
 123 }
 124
 125 sub process_field {
 126     my ($field, $crec) = @_;
 127     my $tag = $field->{'att'}->{'tag'};
 128
 129     # leader
 130     unless (defined $tag) {
 131         #FIXME
 132         return;
 133     }
 134
 135     # datafields
 136     if ($tag == 903) {
 137         my $sub = $field->first_child('subfield');
 138         $crec->{egid} = $sub->text;
 139         return;
 140     }
 141     if ($sfmap->has($tag)) {
 142         push @{$crec->{tags}}, { tag => $tag, uni => undef, multi => undef };
 143         push @{$crec->{tmap}{$tag}}, (@{$crec->{tags}} - 1);
 144         my @subs = $field->children('subfield');
 145         for my $sub (@subs)
 146           { process_subs($tag, $sub, $crec) }
 147
 148         # check map to ensure all declared tags and subs have a value
 149         for my $mappedsub ( @{ $sfmap->subfields($tag) } ) {
 150             my $fieldname = $sfmap->field($tag, $mappedsub);
 151             my $mods = $sfmap->mods($fieldname);
 152             next if $mods->{multi};
 153             $crec->{tags}[-1]{uni}{$mappedsub} = ''
 154               unless defined $crec->{tags}[-1]{uni}{$mappedsub};
 155         }
 156     }
 157 }
 158
 159 sub process_subs {
 160     my ($tag, $sub, $crec) = @_;
 161     my $code = $sub->{'att'}->{'code'};
 162
 163     # handle unmapped tag/subs
 164     return unless ($sfmap->has($tag, $code));
 165
 166     # fetch our datafield struct and field and mods
 167     my $dataf = $crec->{tags}[-1];
 168     my $field = $sfmap->field($tag, $code);
 169     my $sep = $sfmap->sep($field);
 170     $allmods{$field} = $sfmap->mods($field) unless $allmods{$field};
 171     my $mods = $allmods{$field};
 172
 173     # test filters
 174     for my $filter ( @{$sfmap->filters($field)} ) {
 175         return if ($sub->text =~ /$filter/i);
 176     }
 177
 178     # handle multi modifier
 179     if ($mods->{multi}) {
 180         $multis->{$tag}{$code} = 1;
 181         if ($mods->{concatenate}) {
 182             if (exists($dataf->{multi}{$code})) {
 183                 $dataf->{multi}{$code}[0] .= $sep . $sub->text;
 184             } else {
 185                 push @{$dataf->{multi}{$code}}, $sub->text;
 186             }
 187             $multis->{$tag}{$code} = 1;
 188         } else {
 189             push @{$dataf->{multi}{$code}}, $sub->text;
 190         }
 191         return;
 192     }
 193
 194
 195     if ($mods->{concatenate}) {
 196         if (exists($dataf->{uni}{$code})) {
 197             $dataf->{uni}{$code} .= $sep . $sub->text;
 198         } else {
 199             $dataf->{uni}{$code} = $sub->text;
 200         }
 201         return;
 202     }
 203
 204     # if this were a multi field, it would be handled already. make sure its a singleton
 205     die "Multiple occurances of a non-multi field: $tag$code at rec ",
 206       ($reccount + 1),"\n" if (defined $dataf->{uni}{$code} and !$mods->{ignoremulti});
 207
 208     # everything seems okay
 209     $dataf->{uni}{$code} = $sub->text;
 210 }
 211
 212
 213 sub check_required {
 214     my ($crec) = @_;
 215     my $mods = $sfmap->mods;
 216
 217     for my $tag_id (keys %{$mods->{required}}) {
 218         for my $code (@{$mods->{required}{$tag_id}}) {
 219             my $found = 0;
 220
 221             for my $tag (@{$crec->{tags}}) {
 222                 $found = 1 if ($tag->{multi}{($tag_id . $code)});
 223                 $found = 1 if ($tag->{uni}{$code});
 224             }
 225
 226             die "Required mapping $tag_id$code not found in rec ",$reccount,"\n"
 227               unless ($found);
 228         }
 229     }
 230
 231 }
 232
 233 =head2 recno
 234
 235 Returns current record number (starting from zero)
 236
 237 =cut
 238
 239 sub recno { my ($self) = @_; return $self->{data}{rcnt} }
 240
 241 =head2 name
 242
 243 Returns mapped fieldname when passed a tag, and code
 244
 245     my $name = $m->name(999,'a');
 246
 247 =cut
 248
 249 sub name { my ($self, $t, $c) = @_; return $sfmap->field($t, $c) }
 250
 251 =head2 first_only
 252
 253 Returns whether mapped fieldname is to be applied only to first
 254 item in a bib
 255
 256 =cut
 257
 258 sub first_only {
 259     my ($self, $t, $c) = @_;
 260     my $field = $sfmap->field($t, $c);
 261     my $mods = $sfmap->mods($field);
 262     return exists($mods->{first});
 263 }
 264
 265 =head2 get_multis
 266
 267 Returns hashref of C<{tag}{code}> for all mapped multi fields
 268
 269 =cut
 270
 271 sub get_multis {
 272     my ($self) = @_;
 273     return $multis;
 274 }
 275
 276 =head1 MODIFIERS
 277
 278 MapDrivenMARCXMLProc implements the following modifiers, and passes
 279 them to L<Equinox::Migration::SubfieldMapper>, meaning that specifying
 280 any other modifiers in a MDMP map file will cause a fatal error when
 281 it is processed.
 282
 283 =head2 multi
 284
 285 If a mapping is declared to be C<multi>, then MDMP expects to see more
 286 than one instance of that subfield per datafield, and the data is
 287 handled accordingly (see L</PARSED RECORDS> below).
 288
 289 Occurring zero or one time is legal for a C<multi> mapping.
 290
 291 A mapping which is not flagged as C<multi>, but which occurs more than
 292 once per datafield will cause a fatal error.
 293
 294 =head2 required
 295
 296 By default, if a mapping does not occur in a datafield, processing
 297 continues normally. if a mapping has the C<required> modifier,
 298 however, it must appear, or a fatal error will occur.
 299
 300 =head1 PARSED RECORDS
 301
 302 Given:
 303
 304     my $m = Equinox::Migration::MapDrivenMARCXMLProc->new(ARGUMENTS);
 305     $rec = $m->parse_record;
 306
 307 Then C<$rec> will look like:
 308
 309     {
 310       egid => evergreen_record_id,
 311       tags => [
 312                 {
 313                   tag   => tag_id,
 314                   multi => { code => [ val1, val2, ... ] },
 315                   uni   => { code => value, code2 => value2, ... },
 316                 },
 317                 ...
 318               ],
 319       tmap => { tag_id => [ INDEX_LIST ], tag_id2 => [ INDEX_LIST ], ... }
 320     }
 321
 322 That is, there is an C<egid> key which points to the Evergreen ID of
 323 that record, a C<tags> key which points to an arrayref, and a C<tmap>
 324 key which points to a hashref.
 325
 326 =head3 C<tags>
 327
 328 A reference to a list of anonymous hashes, one for each instance of
 329 each tag which occurs in the map.
 330
 331 Each tag hash holds its own id (e.g. C<998>), and two references to
 332 two more hashrefs, C<multi> and C<uni>.
 333
 334 The C<multi> hash holds the extracted data for tag/sub mappings which
 335 have the C<multiple> modifier on them. The keys in C<multi> subfield
 336 codes.  The values are arrayrefs containing the content of all
 337 instances of that subfield in that instance of that tag. If no tags
 338 are defined as C<multi>, it will be C<undef>.
 339
 340 The C<uni> hash holds data for tag/sub mappings which occur only once
 341 per instance of a tag (but may occur multiple times in a record due to
 342 there being multiple instances of that tag in a record). Keys are
 343 subfield codes and values are subfield content.
 344
 345 All C<uni> subfields occuring in the map are guaranteed to be
 346 defined. Sufields which are mapped but do not occur in a particular
 347 datafield will be given a value of '' (the null string) in the current
 348 record struct. Oppose subfields which are not mapped, which will be
 349 C<undef>.
 350
 351 =head3 tmap
 352
 353 A hashref, where each key (a tag id like "650") points to a listref
 354 containing the index (or indices) of C<tags> where that tag has
 355 extracted data.
 356
 357 The intended use of this is to simplify the processing of data from
 358 tags which can appear more than once in a MARC record, like
 359 holdings. If your holdings data is in 852, C<tmap->{852}> will be a
 360 listref with the indices of C<tags> which hold the data from the 852
 361 datafields.
 362
 363 Complimentarily, C<tmap> prevents data from singular datafields from
 364 having to be copied for every instance of a multiple datafield, as it
 365 lets you get the data from that record's one instance of whichever
 366 field you're looking for.
 367
 368 =head1 AUTHOR
 369
 370 Shawn Boyette, C<< <sboyette at esilibrary.com> >>
 371
 372 =head1 BUGS
 373
 374 Please report any bugs or feature requests to the above email address.
 375
 376 =head1 SUPPORT
 377
 378 You can find documentation for this module with the perldoc command.
 379
 380     perldoc Equinox::Migration::MapDrivenMARCXMLProc
 381
 382
 383 =head1 COPYRIGHT & LICENSE
 384
 385 Copyright 2009 Equinox, all rights reserved.
 386
 387 This program is free software; you can redistribute it and/or modify it
 388 under the same terms as Perl itself.
 389
 390
 391 =cut
 392
 393 1; # End of Equinox::Migration::MapDrivenMARCXMLProc