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

   1 package Equinox::Migration::SubfieldMapper;
   2
   3 use warnings;
   4 use strict;
   5
   6 =head1 NAME
   7
   8 Equinox::Migration::SubfieldMapper - Generate named-field to MARC tag map from file
   9
  10 =head1 VERSION
  11
  12 Version 1.000
  13
  14 =cut
  15
  16 our $VERSION = '1.000';
  17
  18
  19 =head1 SYNOPSIS
  20
  21 Using a file as input, E::M::SM generates a mapping of MARC subfields
  22 to arbitrary field names, and provides several access mechanisms to
  23 that set.
  24
  25     use Equinox::Migration::SubfieldMapper;
  26
  27     my $stl = Equinox::Migration::SubfieldMapper->new( file => ".txt" );
  28     my $tags = $stl->as_hashref;
  29
  30 or
  31
  32     my $stl = Equinox::Migration::SubfieldMapper->new( file => ".txt" );
  33     if ( $stl->has($foo) ) {
  34         # if $foo is an element of $stl's parsed list
  35         # do stuff ...
  36     }
  37
  38
  39 =head1 ROUTINES
  40
  41
  42 =head2 new
  43
  44 Takes one optional argument, C<file>. If this is speficied, the tag
  45 list will be populated as per that file on instantiation.
  46
  47 Returns a E::M::STL object.
  48
  49 =cut
  50
  51 sub new {
  52     my ($class, %args) = @_;
  53
  54     my $self = bless { conf   => { mods => { multi => 1, bib => 1, req => 1, bibreq => 1 } },
  55                        fields => {},
  56                        tags   => {} }, $class;
  57
  58     if ($args{file}) {
  59         if (-r $args{file}) {
  60             $self->{conf}{file} = $args{file};
  61             $self->generate;
  62         } else {
  63             die "Can't open file: $!\n";
  64         }
  65     }
  66
  67     return $self;
  68 }
  69
  70 =head2 has
  71
  72 Ask it whether you mapping has various things, and it'll let you know.
  73
  74     $sm->has('fieldname')      # is this fieldname mapped?
  75     $sm->has(901)              # are there any mappings for this tag?
  76     $sm->has(650,'c')          # is this tag/subfield combo mapped?
  77     $sm->has('name', 245, 'a') # is this name mapped to 245$a?
  78
  79 Returns 1 if true, 0 if false.
  80
  81 FIXME: use named params instead of positional
  82
  83 =cut
  84
  85 sub has {
  86     my ($self, @chunks) = @_;
  87     return undef unless (defined $chunks[0]);
  88
  89     if ($chunks[0] =~ /^\d/) {
  90         if (defined $chunks[1]) {
  91             return 1 if ( defined $self->{tags}{$chunks[0]}{$chunks[1]} );
  92             return 0;
  93         } else {
  94             return 1 if ( defined $self->{tags}{$chunks[0]} );
  95             return 0;
  96         }
  97     } else {
  98         if (defined $chunks[2]) {
  99             return 1 if ( $self->{fields}{$chunks[0]}{tag} eq $chunks[1] and
 100                           $self->{fields}{$chunks[0]}{sub} eq $chunks[2] );
 101             return 0;
 102         } elsif (defined $chunks[1]) {
 103             return 1 if ( $self->{fields}{$chunks[0]}{tag} eq $chunks[1] );
 104             return 0;
 105         } else {
 106             return 1 if ( defined $self->{fields}{$chunks[0]} );
 107             return 0;
 108         }
 109     }
 110 }
 111
 112 =head2 field
 113
 114 Given a tag and subfield code,
 115
 116     my $fname = $sm->field(945, 'p')
 117
 118 return the name mapped to them. Returns C<undef> if no mapping exists.
 119
 120 =cut
 121
 122 sub field {
 123     my ($self, $tag, $sub) = @_;
 124     return undef unless (defined $tag and defined $sub);
 125     return undef unless $self->has($tag, $sub);
 126     return $self->{tags}{$tag}{$sub};
 127 }
 128
 129 =head2 mod
 130
 131 Returns the modifier set on a mapping.
 132
 133     if ($sm->mod('field) eq "bib")
 134
 135 If there is no modifier, C<0> will be returned. At the moment, the
 136 valid mappings are
 137
 138     * multi - This field is expected to be seen multiple times per
 139               datafield
 140
 141     * bib - This is a bib-level field, and is expected to be seen only
 142             once per record (normal is once per datafield)
 143
 144     * req - This field is required to occur before output
 145
 146     * bibreq - Both 'bib' and 'req'
 147
 148 =cut
 149
 150 sub mod {
 151     my ($self, $field) = @_;
 152     return undef unless $self->has($field);
 153     return $self->{fields}{$field}{mod};
 154 }
 155
 156 =head2 generate
 157
 158 Generate initial mapping from file.
 159
 160 =cut
 161
 162 sub generate {
 163     my ($self, $file) = @_;
 164
 165     open TAGFILE, '<', $self->{conf}{file};
 166     while (<TAGFILE>) {
 167         next if m/^#/;
 168         next if m/^\s*\n$/;
 169
 170         chomp;
 171         my @tokens = split /\s+/;
 172
 173         if (defined $tokens[3]) {
 174             $self->add( field => $tokens[0], tag => $tokens[1],
 175                         sub   => $tokens[2], mod => $tokens[3] );
 176         } else {
 177             $self->add( field => $tokens[0], tag => $tokens[1], sub => $tokens[2] );
 178         }
 179     }
 180
 181 }
 182
 183 =head2 add
 184
 185 Add new item to mapping. Not usually called directly from user code.
 186
 187     $sm->add( field => 'value', tag => num, sub => 'c' );
 188     $sm->add( field => 'value', tag => num,
 189               sub => 'c', mod => 'modifier' );
 190
 191 =cut
 192
 193 sub add {
 194     my ($self, %toks) = @_;
 195
 196     # check bits for validity
 197     $self->validate(\%toks);
 198
 199     $toks{mod} = (defined $toks{mod} and $toks{mod} !~ /^#/) ? $toks{mod} : 0;
 200
 201     $self->{fields}{$toks{field}} = { tag => $toks{tag}, sub => $toks{sub}, mod => $toks{mod}};
 202     $self->{tags}{$toks{tag}}{$toks{sub}} = $toks{field};
 203 }
 204
 205 =head2 validate
 206
 207 Passed a reference to the hash given to C<add>, validate scans its
 208 contents for common errors and dies if there is an issue.
 209
 210     * field, tag, and sub are required
 211     * fieldnames must start with a letter
 212     * fieldnames must be unique
 213     * tag must be between 0 and 999
 214     * subfield code must be a single alphanumeric character
 215     * tag+subfield can only be mapped once
 216
 217 =cut
 218
 219 sub validate {
 220     my ($self, $toks) = @_;
 221
 222     $.= 1 unless defined $.;
 223
 224     die "Required field missing (line $.)\n"
 225       unless (defined $toks->{field} and defined $toks->{tag} and defined $toks->{sub});
 226
 227     die "Fieldnames must start with letter (line $.)\n"
 228      unless ($toks->{field} =~ /^[a-zA-z]/);
 229
 230     die "Invalid tag (line $.)\n"
 231       if ($toks->{tag} =~ /[^\d\-]/ or $toks->{tag} < 0 or $toks->{tag} > 999);
 232
 233     die "Invalid subfield code (line $.)\n"
 234       if (length $toks->{sub} != 1 or $toks->{sub} =~ /[^a-zA-Z0-9]/);
 235
 236     # the next thing (if it exists), must be a comment or valid modifier
 237     if (defined $toks->{mod}) {
 238         die "Unknown chunk (line $.)\n"
 239           unless (defined $self->{conf}{mods}{$toks->{mod}} or $toks->{mod} =~ /^#/);
 240     }
 241
 242     die "Fieldnames must be unique (line $.)\n"
 243       if (defined $self->{fields}{$toks->{field}});
 244
 245     die "Subfields cannot be multimapped (line $.)\n"
 246       if (defined $self->{tags}{$toks->{tag}}{$toks->{sub}});
 247 }
 248
 249
 250 =head1 AUTHOR
 251
 252 Shawn Boyette, C<< <sboyette at esilibrary.com> >>
 253
 254 =head1 BUGS
 255
 256 Please report any bugs or feature requests to the above email address.
 257
 258 =head1 SUPPORT
 259
 260 You can find documentation for this module with the perldoc command.
 261
 262     perldoc Equinox::Migration::SubfieldMapper
 263
 264
 265 =head1 COPYRIGHT & LICENSE
 266
 267 Copyright 2009 Equinox, all rights reserved.
 268
 269 This program is free software; you can redistribute it and/or modify it
 270 under the same terms as Perl itself.
 271
 272
 273 =cut
 274
 275 1; # End of Equinox::Migration::SimpleTagList