Equinox-Migration/lib/Equinox/Migration/SubfieldMapper.pm

   1 package Equinox::Migration::SubfieldMapper;
   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 use warnings;
  20 use strict;
  21
  22 =head1 NAME
  23
  24 Equinox::Migration::SubfieldMapper - Generate named-field to MARC tag map from file
  25
  26 =head1 VERSION
  27
  28 Version 1.005
  29
  30 =cut
  31
  32 our $VERSION = '1.005';
  33
  34
  35 =head1 SYNOPSIS
  36
  37 Using a file as input, E::M::SM generates a mapping of MARC subfields
  38 to arbitrary field names, and provides several access mechanisms to
  39 that set.
  40
  41     use Equinox::Migration::SubfieldMapper;
  42     ...
  43
  44
  45 =head1 METHODS
  46
  47 =head2 new
  48
  49 Takes one optional argument, C<file>. If this is speficied, the tag
  50 list will be populated as per that file on instantiation.
  51
  52 Returns a E::M::SM object.
  53
  54 =cut
  55
  56 sub new {
  57     my ($class, %args) = @_;
  58
  59     my $self = bless { conf   => { mods => undef },
  60                        fields => {},
  61                        tags   => {} }, $class;
  62
  63     if ($args{mods}) {
  64         die "Argument 'mods' is wrong type\n"
  65           unless (ref $args{mods} eq "ARRAY");
  66         for my $mod ( @{$args{mods}} )
  67           { $self->{conf}{mods}{$mod} = 1 }
  68     }
  69
  70     if ($args{file}) {
  71         if (-r $args{file}) {
  72             $self->{conf}{file} = $args{file};
  73             $self->generate;
  74         } else {
  75             die "Can't open file: $!\n";
  76         }
  77     }
  78
  79     return $self;
  80 }
  81
  82 =head2 has
  83
  84 Ask it whether your mapping has various things, and it'll let you know.
  85
  86     $sm->has('fieldname')      # is this fieldname mapped?
  87     $sm->has(901)              # are there any mappings for this tag?
  88     $sm->has(650,'c')          # is this tag/subfield combo mapped?
  89     $sm->has('name', 245, 'a') # is this name mapped to 245$a?
  90
  91 Returns 1 if true, 0 if false.
  92
  93 FIXME: use named params instead of positional
  94
  95 =cut
  96
  97 sub has {
  98     my ($self, @chunks) = @_;
  99     return undef unless (defined $chunks[0]);
 100
 101     if ($chunks[0] =~ /^\d/) {
 102         if (defined $chunks[1]) {
 103             return 1 if ( defined $self->{tags}{$chunks[0]}{$chunks[1]} );
 104             return 0;
 105         } else {
 106             return 1 if ( defined $self->{tags}{$chunks[0]} );
 107             return 0;
 108         }
 109     } else {
 110         if (defined $chunks[2]) {
 111             return 1 if ( $self->{fields}{$chunks[0]}{tag} eq $chunks[1] and
 112                           $self->{fields}{$chunks[0]}{sub} eq $chunks[2] );
 113             return 0;
 114         } elsif (defined $chunks[1]) {
 115             return 1 if ( $self->{fields}{$chunks[0]}{tag} eq $chunks[1] );
 116             return 0;
 117         } else {
 118             return 1 if ( defined $self->{fields}{$chunks[0]} );
 119             return 0;
 120         }
 121     }
 122 }
 123
 124 =head2 tags
 125
 126 Returns an arrayref containing the tags defined in the map.
 127
 128     my $tags = $sfm->tags;
 129     for my tag ( @{$tags} ) {
 130         my $subs = $sfm->subfields($tag);
 131         ...
 132     }
 133
 134 =cut
 135
 136 sub tags {
 137     my ($self) = @_;
 138     return [ keys %{$self->{tags}} ];
 139 }
 140
 141 =head2 subfields
 142
 143 Given a tag, return an arrayref of the subfields mapped with that tag.
 144
 145     my $tags = $sfm->tags;
 146     for my tag ( @{$tags} ) {
 147         my $subs = $sfm->subfields($tag);
 148         ...
 149     }
 150
 151 Returns C<undef> if C<tag> is not mapped.
 152
 153 =cut
 154
 155 sub subfields {
 156     my ($self, $tag) = @_;
 157     return undef unless $self->has($tag);
 158     return [ keys %{$self->{tags}{$tag}} ];
 159 }
 160
 161
 162 =head2 field
 163
 164 Given a tag and subfield code,
 165
 166     my $fname = $sm->field(945, 'p')
 167
 168 return the name mapped to them. Returns C<undef> if no mapping exists.
 169
 170 =cut
 171
 172 sub field {
 173     my ($self, $tag, $sub) = @_;
 174     return undef unless (defined $tag and defined $sub);
 175     return undef unless $self->has($tag, $sub);
 176     return $self->{tags}{$tag}{$sub};
 177 }
 178
 179 =head2 mods
 180
 181 With no argument, returns a hashref containing all modifiers for the entire map:
 182
 183     {
 184       modifier => {
 185                     tag => [ list_of subs ],
 186                     ...
 187                   },
 188       ...
 189     }
 190
 191 Given a fieldname, returns a hashref of the modifiers set on that mapping.
 192
 193     $self->mods('fieldname')
 194
 195 Returns undef is nothing is defined.
 196
 197 =cut
 198
 199 sub mods {
 200     my ($self, $field) = @_;
 201     return $self->{allmods} unless defined $field;
 202     return undef unless $self->has($field);
 203     return undef unless (%{ $self->{fields}{$field}{mods} });
 204     return $self->{fields}{$field}{mods};
 205 }
 206
 207 =head2 filters
 208
 209 Returns the content filters set on a mapping
 210
 211     $self->filters('fieldname')
 212
 213 If there are no filters, C<undef> will be returned. Else a listref
 214 will be returned.
 215
 216 =cut
 217
 218 sub filters {
 219     my ($self, $field) = @_;
 220     return undef unless $self->has($field);
 221     return undef unless ($self->{fields}{$field}{filt});
 222     return $self->{fields}{$field}{filt};
 223 }
 224
 225 =head2 sep
 226
 227 Returns the separator string set on a mapping.  Used only
 228 if concatenating.
 229
 230 =cut
 231
 232 sub sep {
 233     my ($self, $field) = @_;
 234     return undef unless $self->has($field);
 235     return $self->{fields}{$field}{sep};
 236 }
 237
 238 =head1 MAP CONSTRUCTION METHODS
 239
 240 These methods are not generally accessed from user code.
 241
 242 =head2 generate
 243
 244 Generate initial mapping from file.
 245
 246 =cut
 247
 248 sub generate {
 249     my ($self, $file) = @_;
 250
 251     open TAGFILE, '<', $self->{conf}{file};
 252     while (<TAGFILE>) {
 253         next if m/^#/;
 254         next if m/^\s*\n$/;
 255
 256         chomp;
 257         my @tokens = split /\s+/;
 258
 259         my $map = { mods => [], filt => [], sep => ' ' };
 260         $map->{field} = shift @tokens;
 261         $map->{tag}   = shift @tokens;
 262         while (defined (my $tok = shift @tokens)) {
 263             last if ($tok =~ m/^#/);
 264             if ($tok =~ m/^[a-zA-Z]:'/ and $tok !~ /^'$/) {
 265                 $tok .= ' ' . shift @tokens
 266                   until ($tokens[0] =~ m/'$/);
 267                 $tok .= ' ' . shift @tokens;
 268                 $tok =~ s/'//;
 269                 $tok =~ s/'$//;
 270             }
 271             if ($tok =~ m/^m:/)
 272               { push @{$map->{mods}}, $tok }
 273             elsif ($tok =~ m/^f:/)
 274               { push @{$map->{filt}}, $tok }
 275             elsif ($tok =~ m/^[a-zA-Z0-9]$/)
 276               { $map->{sub} = $tok }
 277             elsif ($tok =~ /^c:(.*)$/)
 278               { $map->{sep} = $1 }
 279             else
 280               { die "Unknown chunk '$tok' at line $.\n" }
 281         }
 282         $self->add($map);
 283     }
 284 }
 285
 286 =head2 add
 287
 288 Add new item to mapping. Not usually called directly from user code.
 289
 290     $sm->add( $map );
 291
 292 Where C<$map> is a hashref that, at a minimum, looks like
 293
 294     { field => "value", tag => NNN, sub => X }
 295
 296 and may also have the key/value pairs
 297
 298     mods => [ ITEMS ]
 299     filt => [ ITEMS ]
 300
 301 =cut
 302
 303 sub add {
 304     my ($self, $map) = @_;
 305
 306     # trim the mods and filters
 307     my $mods = {};
 308     my $filt = []; my %filt = ();
 309     for my $m (@{$map->{mods}}) {
 310         die "Modifier collision '$m' at line $." if $mods->{$m};
 311         $m =~ s/^m://;
 312         $mods->{$m} = 1;
 313         push @{$self->{allmods}{$m}{ $map->{tag} }}, $map->{sub};
 314     }
 315     for my $f (@{$map->{filt}}) {
 316         die "Filter collision '$f' at line $." if $filt{$f};
 317         $f =~ s/^f://;
 318         push @{$filt}, $f; $filt{$f} = 1;
 319     }
 320     $map->{mods} = $mods;
 321     $map->{filt} = $filt;
 322
 323     # check bits for validity
 324     $self->validate($map);
 325
 326     # add data to the fields hash
 327     $self->{fields}{ $map->{field} } = { tag => $map->{tag},
 328                                          sub => $map->{sub},
 329                                          mods => $map->{mods},
 330                                          filt => $map->{filt},
 331                                          sep => $map->{sep},
 332                                        };
 333     # and to the tags hash
 334     $self->{tags}{ $map->{tag} }{ $map->{sub} } = $map->{field};
 335 }
 336
 337 =head2 validate
 338
 339 Passed a reference to the hash given to C<add>, validate scans its
 340 contents for common errors and dies if there is an issue.
 341
 342     * field, tag, and sub are required
 343     * fieldnames must start with a letter
 344     * fieldnames must be unique
 345     * tag must be between 0 and 999
 346     * subfield code must be a single alphanumeric character
 347     * tag+subfield can only be mapped once
 348     * if a list of allowable mod values was given in the call to
 349       C<new>, any modifiers must be on that list
 350
 351 =cut
 352
 353 sub validate {
 354     my ($self, $map) = @_;
 355
 356     $.= 1 unless defined $.;
 357
 358     die "Required field missing (line $.)\n"
 359       unless (defined $map->{field} and defined $map->{tag} and defined $map->{sub});
 360
 361     die "Fieldnames must start with letter (line $.)\n"
 362      unless ($map->{field} =~ /^[a-zA-z]/);
 363
 364     die "Invalid tag (line $.)\n"
 365       if ($map->{tag} =~ /[^\d\-]/ or $map->{tag} < 0 or $map->{tag} > 999);
 366
 367     die "Invalid subfield code (line $.)\n"
 368       if (length $map->{sub} != 1 or $map->{sub} =~ /[^a-zA-Z0-9]/);
 369
 370     # test mod names if we have a set to check against
 371     if (defined $self->{conf}{mods}) {
 372         for my $mod ( keys %{$map->{mods}} ) {
 373             die "Modifier '$mod' not allowed\n"
 374               unless $self->{conf}{mods}{$mod};
 375         }
 376     }
 377
 378     die "Fieldnames must be unique (line $.)\n"
 379       if (defined $self->{fields}{$map->{field}});
 380
 381     die "Subfields cannot be mapped twice (line $.)\n"
 382       if (defined $self->{tags}{$map->{tag}}{$map->{sub}});
 383
 384 }
 385
 386
 387 =head1 AUTHOR
 388
 389 Shawn Boyette, C<< <sboyette at esilibrary.com> >>
 390
 391 =head1 BUGS
 392
 393 Please report any bugs or feature requests to the above email address.
 394
 395 =head1 SUPPORT
 396
 397 You can find documentation for this module with the perldoc command.
 398
 399     perldoc Equinox::Migration::SubfieldMapper
 400
 401
 402 =head1 COPYRIGHT & LICENSE
 403
 404 Copyright 2009 Equinox, all rights reserved.
 405
 406 This program is free software; you can redistribute it and/or modify it
 407 under the same terms as Perl itself.
 408
 409
 410 =cut
 411
 412 1; # End of Equinox::Migration::SimpleTagList