Koha/SimpleMARC.pm

   1 package Koha::SimpleMARC;
   2
   3 # Copyright 2009 Kyle M. Hall <kyle.m.hall@gmail.com>
   4
   5 use Modern::Perl;
   6
   7 #use MARC::Record;
   8
   9 require Exporter;
  10
  11 our @ISA = qw(Exporter);
  12 our %EXPORT_TAGS = ( 'all' => [ qw(
  13
  14 ) ] );
  15
  16 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  17
  18 our @EXPORT = qw(
  19   read_field
  20   update_field
  21   copy_field
  22   move_field
  23   delete_field
  24   field_exists
  25   field_equals
  26 );
  27
  28 our $VERSION = '0.01';
  29
  30 our $debug = 0;
  31
  32 =head1 NAME
  33
  34 SimpleMARC - Perl module for making simple MARC record alterations.
  35
  36 =head1 SYNOPSIS
  37
  38   use SimpleMARC;
  39
  40 =head1 DESCRIPTION
  41
  42 SimpleMARC is designed to make writing scripts
  43 to modify MARC records simple and easy.
  44
  45 Every function in the modules requires a
  46 MARC::Record object as its first parameter.
  47
  48 =head1 AUTHOR
  49
  50 Kyle Hall <lt>kyle.m.hall@gmail.com<gt>
  51
  52 =head1 COPYRIGHT AND LICENSE
  53
  54 Copyright (C) 2009 by Kyle Hall
  55
  56 This library is free software; you can redistribute it and/or modify
  57 it under the same terms as Perl itself, either Perl version 5.8.7 or,
  58 at your option, any later version of Perl 5 you may have available.
  59
  60 =head1 FUNCTIONS
  61
  62 =head2 copy_field
  63
  64   copy_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex[, $n ] ] );
  65
  66   Copies a value from one field to another. If a regular expression ( $regex ) is supplied,
  67   the value will be transformed by the given regex before being copied into the new field.
  68   Example: $regex = { search => 'Old Text', replace => 'Replacement Text', modifiers => 'g' };
  69
  70   If $n is passed, copy_field will only copy the Nth field of the list of fields.
  71   E.g. $n = 1 will only use the first field's value, $n = 2 will use only the 2nd field's value.
  72
  73 =cut
  74
  75 sub copy_field {
  76   my ( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName, $regex, $n, $dont_erase ) = @_;
  77
  78   if ( ! ( $record && $fromFieldName && $toFieldName ) ) { return; }
  79
  80   my @values = read_field( $record, $fromFieldName, $fromSubfieldName );
  81   @values = ( $values[$n-1] ) if ( $n );
  82
  83   if ( $regex and $regex->{search} ) {
  84     $regex->{modifiers} //= q||;
  85     my @available_modifiers = qw( i g );
  86     my $modifiers = q||;
  87     for my $modifier ( split //, $regex->{modifiers} ) {
  88         $modifiers .= $modifier
  89             if grep {/$modifier/} @available_modifiers;
  90     }
  91     foreach my $value (@values) {
  92         if ( $modifiers =~ m/^(ig|gi)$/ ) {
  93             $value =~ s/$regex->{search}/$regex->{replace}/ig;
  94         }
  95         elsif ( $modifiers eq 'i' ) {
  96             $value =~ s/$regex->{search}/$regex->{replace}/i;
  97         }
  98         elsif ( $modifiers eq 'g' ) {
  99             $value =~ s/$regex->{search}/$regex->{replace}/g;
 100         }
 101         else {
 102             $value =~ s/$regex->{search}/$regex->{replace}/;
 103         }
 104     }
 105   }
 106   update_field( $record, $toFieldName, $toSubfieldName, $dont_erase, @values );
 107 }
 108
 109 =head2 update_field
 110
 111   update_field( $record, $fieldName, $subfieldName, $dont_erase, $value[, $value,[ $value ... ] ] );
 112
 113   Updates a field with the given value, creating it if neccessary.
 114
 115   If multiple values are supplied, they will be used to update a list of repeatable fields
 116   until either the fields or the values are all used.
 117
 118   If a single value is supplied for a repeated field, that value will be used to update
 119   each of the repeated fields.
 120
 121 =cut
 122
 123 sub update_field {
 124   my ( $record, $fieldName, $subfieldName, $dont_erase, @values ) = @_;
 125
 126   if ( ! ( $record && $fieldName ) ) { return; }
 127
 128   my $i = 0;
 129   my $field;
 130   if ( $subfieldName ) {
 131     if ( my @fields = $record->field( $fieldName ) ) {
 132       unless ( $dont_erase ) {
 133         @values = ($values[0]) x scalar( @fields )
 134           if @values == 1;
 135         foreach my $field ( @fields ) {
 136           $field->update( "$subfieldName" => $values[$i++] );
 137         }
 138       }
 139       if ( $i <= scalar ( @values ) - 1 ) {
 140         foreach my $field ( @fields ) {
 141           foreach my $j ( $i .. scalar( @values ) - 1) {
 142             $field->add_subfields( "$subfieldName" => $values[$j] );
 143           }
 144         }
 145       }
 146     } else {
 147       ## Field does not exist, create it.
 148       foreach my $value ( @values ) {
 149         $field = MARC::Field->new( $fieldName, '', '', "$subfieldName" => $values[$i++] );
 150         $record->append_fields( $field );
 151       }
 152     }
 153   } else { ## No subfield
 154     if ( my @fields = $record->field( $fieldName ) ) {
 155       @values = ($values[0]) x scalar( @fields )
 156         if @values == 1;
 157       foreach my $field ( @fields ) {
 158         $field->update( $values[$i++] );
 159       }
 160     } else {
 161       ## Field does not exists, create it
 162       foreach my $value ( @values ) {
 163         $field = MARC::Field->new( $fieldName, $value );
 164         $record->append_fields( $field );
 165       }
 166     }
 167   }
 168 }
 169
 170 =head2 read_field
 171
 172   my @values = read_field( $record, $fieldName[, $subfieldName, [, $n ] ] );
 173
 174   Returns an array of field values for the given field and subfield
 175
 176   If $n is given, it will return only the $nth value of the array.
 177   E.g. If $n = 1, it return the 1st value, if $n = 3, it will return the 3rd value.
 178
 179 =cut
 180
 181 sub read_field {
 182   my ( $record, $fieldName, $subfieldName, $n ) = @_;
 183
 184   my @fields = $record->field( $fieldName );
 185
 186   return map { $_->data() } @fields unless $subfieldName;
 187
 188   my @subfields;
 189   foreach my $field ( @fields ) {
 190     my @sf = $field->subfield( $subfieldName );
 191     push( @subfields, @sf );
 192   }
 193
 194   if ( $n ) {
 195     return $subfields[$n-1];
 196   } else {
 197     return @subfields;
 198   }
 199 }
 200
 201 =head2 field_exists
 202
 203   $bool = field_exists( $record, $fieldName[, $subfieldName ]);
 204
 205   Returns true if the field exits, false otherwise.
 206
 207 =cut
 208
 209 sub field_exists {
 210   my ( $record, $fieldName, $subfieldName ) = @_;
 211
 212   if ( ! $record ) { return; }
 213
 214   my $return = 0;
 215   if ( $fieldName && $subfieldName ) {
 216     $return = $record->field( $fieldName ) && $record->subfield( $fieldName, $subfieldName );
 217   } elsif ( $fieldName ) {
 218     $return = $record->field( $fieldName ) && 1;
 219   }
 220
 221   return $return;
 222 }
 223
 224 =head2 field_equals
 225
 226   $bool = field_equals( $record, $value, $fieldName[, $subfieldName[, $regex [, $n ] ] ]);
 227
 228   Returns true if the field equals the given value, false otherwise.
 229
 230   If a regular expression ( $regex ) is supplied, the value will be compared using
 231   the given regex. Example: $regex = 'sought_text'
 232
 233   If $n is passed, the Nth field of a repeatable series will be used for comparison.
 234   Set $n to 1 or leave empty for a non-repeatable field.
 235
 236 =cut
 237
 238 sub field_equals {
 239   my ( $record, $value, $fieldName, $subfieldName, $regex, $n ) = @_;
 240   $n = 1 unless ( $n ); ## $n defaults to first field of a repeatable field series
 241
 242   if ( ! $record ) { return; }
 243
 244   my @field_values = read_field( $record, $fieldName, $subfieldName, $n );
 245   my $field_value = $field_values[$n-1];
 246
 247   if ( $regex ) {
 248     return $field_value =~ m/$value/;
 249   } else {
 250     return $field_value eq $value;
 251   }
 252 }
 253
 254 =head2 move_field
 255
 256   move_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex [, $n ] ] );
 257
 258   Moves a value from one field to another. If a regular expression ( $regex ) is supplied,
 259   the value will be transformed by the given regex before being moved into the new field.
 260   Example: $regex = 's/Old Text/Replacement Text/'
 261
 262   If $n is passed, only the Nth field will be moved. $n = 1
 263   will move the first repeatable field, $n = 3 will move the third.
 264
 265 =cut
 266
 267 sub move_field {
 268   my ( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName, $regex, $n ) = @_;
 269   copy_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName, $regex, $n , 'dont_erase' );
 270   delete_field( $record, $fromFieldName, $fromSubfieldName, $n );
 271 }
 272
 273 =head2 delete_field
 274
 275   delete_field( $record, $fieldName[, $subfieldName [, $n ] ] );
 276
 277   Deletes the given field.
 278
 279   If $n is passed, only the Nth field will be deleted. $n = 1
 280   will delete the first repeatable field, $n = 3 will delete the third.
 281
 282 =cut
 283
 284 sub delete_field {
 285   my ( $record, $fieldName, $subfieldName, $n ) = @_;
 286
 287   my @fields = $record->field( $fieldName );
 288
 289   @fields = ( $fields[$n-1] ) if ( $n );
 290
 291   if ( @fields && !$subfieldName ) {
 292     foreach my $field ( @fields ) {
 293       $record->delete_field( $field );
 294     }
 295   } elsif ( @fields && $subfieldName ) {
 296     foreach my $field ( @fields ) {
 297       $field->delete_subfield( code => $subfieldName );
 298     }
 299   }
 300 }
 301
 302 1;
 303 __END__