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 ( $params ) = @_;
  77     my $record = $params->{record};
  78     my $fromFieldName = $params->{from_field};
  79     my $fromSubfieldName = $params->{from_subfield};
  80     my $toFieldName = $params->{to_field};
  81     my $toSubfieldName = $params->{to_subfield};
  82     my $regex = $params->{regex};
  83     my $field_numbers = $params->{field_numbers} // [];
  84
  85     if ( ! ( $record && $fromFieldName && $toFieldName ) ) { return; }
  86
  87
  88     if ( not $fromSubfieldName or $fromSubfieldName eq ''
  89       or not $toSubfieldName or $toSubfieldName eq ''
  90     ) {
  91         _copy_field({
  92             record => $record,
  93             from_field => $fromFieldName,
  94             to_field => $toFieldName,
  95             regex => $regex,
  96             field_numbers => $field_numbers,
  97         });
  98     } else {
  99         _copy_subfield({
 100             record => $record,
 101             from_field => $fromFieldName,
 102             from_subfield => $fromSubfieldName,
 103             to_field => $toFieldName,
 104             to_subfield => $toSubfieldName,
 105             regex => $regex,
 106             field_numbers => $field_numbers,
 107         });
 108     }
 109
 110 }
 111
 112 sub _copy_field {
 113     my ( $params ) = @_;
 114     my $record = $params->{record};
 115     my $fromFieldName = $params->{from_field};
 116     my $toFieldName = $params->{to_field};
 117     my $regex = $params->{regex};
 118     my $field_numbers = $params->{field_numbers} // [];
 119
 120     _copy_move_field({
 121         record => $record,
 122         from_field => $fromFieldName,
 123         to_field => $toFieldName,
 124         regex => $regex,
 125         field_numbers => $field_numbers,
 126     });
 127 }
 128
 129 sub _copy_subfield {
 130     my ( $params ) = @_;
 131     my $record = $params->{record};
 132     my $fromFieldName = $params->{from_field};
 133     my $fromSubfieldName = $params->{from_subfield};
 134     my $toFieldName = $params->{to_field};
 135     my $toSubfieldName = $params->{to_subfield};
 136     my $regex = $params->{regex};
 137     my $field_numbers = $params->{field_numbers} // [];
 138
 139     my @values = read_field({ record => $record, field => $fromFieldName, subfield => $fromSubfieldName });
 140     if ( @$field_numbers ) {
 141         @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
 142     }
 143     _modify_values({ values => \@values, regex => $regex });
 144
 145     update_field({ record => $record, field => $toFieldName, subfield => $toSubfieldName, values => \@values });
 146 }
 147
 148 sub update_field {
 149     my ( $params ) = @_;
 150     my $record = $params->{record};
 151     my $fieldName = $params->{field};
 152     my $subfieldName = $params->{subfield};
 153     my @values = @{ $params->{values} };
 154     my $field_numbers = $params->{field_numbers} // [];
 155
 156     if ( ! ( $record && $fieldName ) ) { return; }
 157
 158     if ( not $subfieldName or $subfieldName eq '' ) {
 159         # FIXME I'm not sure the actual implementation is correct.
 160         die "This action is not implemented yet";
 161         #_update_field({ record => $record, field => $fieldName, values => \@values });
 162     } else {
 163         _update_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, values => \@values, field_numbers => $field_numbers });
 164     }
 165 }
 166
 167 sub _update_field {
 168     my ( $params ) = @_;
 169     my $record = $params->{record};
 170     my $fieldName = $params->{field};
 171     my @values = @{ $params->{values} };
 172
 173     my $i = 0;
 174     if ( my @fields = $record->field( $fieldName ) ) {
 175         @values = ($values[0]) x scalar( @fields )
 176             if @values == 1;
 177         foreach my $field ( @fields ) {
 178             $field->update( $values[$i++] );
 179         }
 180     } else {
 181         ## Field does not exists, create it
 182         if ( $fieldName < 10 ) {
 183             foreach my $value ( @values ) {
 184                 my $field = MARC::Field->new( $fieldName, $value );
 185                 $record->append_fields( $field );
 186             }
 187         } else {
 188             warn "Invalid operation, trying to add a new field without subfield";
 189         }
 190     }
 191 }
 192
 193 sub _update_subfield {
 194     my ( $params ) = @_;
 195     my $record = $params->{record};
 196     my $fieldName = $params->{field};
 197     my $subfieldName = $params->{subfield};
 198     my @values = @{ $params->{values} };
 199     my $dont_erase = $params->{dont_erase};
 200     my $field_numbers = $params->{field_numbers} // [];
 201     my $i = 0;
 202
 203     my @fields = $record->field( $fieldName );
 204
 205     if ( @$field_numbers ) {
 206         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 207     }
 208
 209     if ( @fields ) {
 210         unless ( $dont_erase ) {
 211             @values = ($values[0]) x scalar( @fields )
 212                 if @values == 1;
 213             foreach my $field ( @fields ) {
 214                 $field->update( "$subfieldName" => $values[$i++] );
 215             }
 216         }
 217         if ( $i <= scalar ( @values ) - 1 ) {
 218             foreach my $field ( @fields ) {
 219                 foreach my $j ( $i .. scalar( @values ) - 1) {
 220                     $field->add_subfields( "$subfieldName" => $values[$j] );
 221                 }
 222             }
 223         }
 224     } else {
 225         ## Field does not exist, create it.
 226         foreach my $value ( @values ) {
 227             my $field = MARC::Field->new( $fieldName, '', '', "$subfieldName" => $values[$i++] );
 228             $record->append_fields( $field );
 229         }
 230     }
 231 }
 232
 233 =head2 read_field
 234
 235   my @values = read_field( $record, $fieldName[, $subfieldName, [, $n ] ] );
 236
 237   Returns an array of field values for the given field and subfield
 238
 239   If $n is given, it will return only the $nth value of the array.
 240   E.g. If $n = 1, it return the 1st value, if $n = 3, it will return the 3rd value.
 241
 242 =cut
 243
 244 sub read_field {
 245     my ( $params ) = @_;
 246     my $record = $params->{record};
 247     my $fieldName = $params->{field};
 248     my $subfieldName = $params->{subfield};
 249     my $field_numbers = $params->{field_numbers} // [];
 250
 251     if ( not $subfieldName or $subfieldName eq '' ) {
 252         _read_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
 253     } else {
 254         _read_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
 255     }
 256 }
 257
 258 sub _read_field {
 259     my ( $params ) = @_;
 260     my $record = $params->{record};
 261     my $fieldName = $params->{field};
 262     my $field_numbers = $params->{field_numbers} // [];
 263
 264     my @fields = $record->field( $fieldName );
 265
 266     return unless @fields;
 267
 268     return map { $_->data() } @fields
 269         if $fieldName < 10;
 270
 271     my @values;
 272     if ( @$field_numbers ) {
 273         for my $field_number ( @$field_numbers ) {
 274             if ( $field_number <= scalar( @fields ) ) {
 275                 for my $sf ( $fields[$field_number - 1]->subfields ) {
 276                     push @values, $sf->[1];
 277                 }
 278             }
 279         }
 280     } else {
 281         foreach my $field ( @fields ) {
 282             for my $sf ( $field->subfields ) {
 283                 push @values, $sf->[1];
 284             }
 285         }
 286     }
 287
 288     return @values;
 289 }
 290
 291 sub _read_subfield {
 292     my ( $params ) = @_;
 293     my $record = $params->{record};
 294     my $fieldName = $params->{field};
 295     my $subfieldName = $params->{subfield};
 296     my $field_numbers = $params->{field_numbers} // [];
 297
 298     my @fields = $record->field( $fieldName );
 299
 300     return unless @fields;
 301
 302     my @values;
 303     foreach my $field ( @fields ) {
 304         my @sf = $field->subfield( $subfieldName );
 305         push( @values, @sf );
 306     }
 307
 308     if ( @values and @$field_numbers ) {
 309         @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
 310     }
 311
 312     return @values;
 313 }
 314
 315 =head2 field_exists
 316
 317   @field_numbers = field_exists( $record, $fieldName[, $subfieldName ]);
 318
 319   Returns the field numbers or an empty array.
 320
 321 =cut
 322
 323 sub field_exists {
 324   my ( $params ) = @_;
 325   my $record = $params->{record};
 326   my $fieldName = $params->{field};
 327   my $subfieldName = $params->{subfield};
 328
 329   if ( ! $record ) { return; }
 330
 331   my @field_numbers = ();
 332   my $current_field_number = 1;
 333   for my $field ( $record->field( $fieldName ) ) {
 334     if ( $subfieldName ) {
 335       push @field_numbers, $current_field_number
 336         if $field->subfield( $subfieldName );
 337     } else {
 338       push @field_numbers, $current_field_number;
 339     }
 340     $current_field_number++;
 341   }
 342
 343   return \@field_numbers;
 344 }
 345
 346 =head2 field_equals
 347
 348   $bool = field_equals( $record, $value, $fieldName[, $subfieldName[, $regex ] ]);
 349
 350   Returns true if the field equals the given value, false otherwise.
 351
 352   If a regular expression ( $regex ) is supplied, the value will be compared using
 353   the given regex. Example: $regex = 'sought_text'
 354
 355 =cut
 356
 357 sub field_equals {
 358   my ( $params ) = @_;
 359   my $record = $params->{record};
 360   my $value = $params->{value};
 361   my $fieldName = $params->{field};
 362   my $subfieldName = $params->{subfield};
 363   my $is_regex = $params->{is_regex};
 364
 365   if ( ! $record ) { return; }
 366
 367   my @field_numbers = ();
 368   my $current_field_number = 1;
 369   FIELDS: for my $field ( $record->field( $fieldName ) ) {
 370     my @subfield_values = $subfieldName
 371         ? $field->subfield( $subfieldName )
 372         : map { $_->[1] } $field->subfields;
 373
 374     SUBFIELDS: for my $subfield_value ( @subfield_values ) {
 375       if (
 376           (
 377               $is_regex and $subfield_value =~ m/$value/
 378           ) or (
 379               $subfield_value eq $value
 380           )
 381       ) {
 382           push @field_numbers, $current_field_number;
 383           last SUBFIELDS;
 384       }
 385     }
 386     $current_field_number++;
 387   }
 388
 389   return \@field_numbers;
 390 }
 391
 392 =head2 move_field
 393
 394   move_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex [, $n ] ] );
 395
 396   Moves a value from one field to another. If a regular expression ( $regex ) is supplied,
 397   the value will be transformed by the given regex before being moved into the new field.
 398   Example: $regex = 's/Old Text/Replacement Text/'
 399
 400   If $n is passed, only the Nth field will be moved. $n = 1
 401   will move the first repeatable field, $n = 3 will move the third.
 402
 403 =cut
 404
 405 sub move_field {
 406     my ( $params ) = @_;
 407     my $record = $params->{record};
 408     my $fromFieldName = $params->{from_field};
 409     my $fromSubfieldName = $params->{from_subfield};
 410     my $toFieldName = $params->{to_field};
 411     my $toSubfieldName = $params->{to_subfield};
 412     my $regex = $params->{regex};
 413     my $field_numbers = $params->{field_numbers} // [];
 414
 415     if ( not $fromSubfieldName or $fromSubfieldName eq ''
 416         or not $toSubfieldName or $toSubfieldName eq ''
 417     ) {
 418         _move_field({
 419             record => $record,
 420             from_field => $fromFieldName,
 421             to_field => $toFieldName,
 422             regex => $regex,
 423             field_numbers => $field_numbers,
 424         });
 425     } else {
 426         _move_subfield({
 427             record => $record,
 428             from_field => $fromFieldName,
 429             from_subfield => $fromSubfieldName,
 430             to_field => $toFieldName,
 431             to_subfield => $toSubfieldName,
 432             regex => $regex,
 433             field_numbers => $field_numbers,
 434         });
 435     }
 436 }
 437
 438 sub _move_field {
 439     my ( $params ) = @_;
 440     my $record = $params->{record};
 441     my $fromFieldName = $params->{from_field};
 442     my $toFieldName = $params->{to_field};
 443     my $regex = $params->{regex};
 444     my $field_numbers = $params->{field_numbers} // [];
 445
 446     _copy_move_field({
 447         record => $record,
 448         from_field => $fromFieldName,
 449         to_field => $toFieldName,
 450         regex => $regex,
 451         field_numbers => $field_numbers,
 452         action => 'move',
 453     });
 454 }
 455
 456 sub _move_subfield {
 457     my ( $params ) = @_;
 458     my $record = $params->{record};
 459     my $fromFieldName = $params->{from_field};
 460     my $fromSubfieldName = $params->{from_subfield};
 461     my $toFieldName = $params->{to_field};
 462     my $toSubfieldName = $params->{to_subfield};
 463     my $regex = $params->{regex};
 464     my $field_numbers = $params->{field_numbers} // [];
 465
 466     # Copy
 467     my @values = read_field({ record => $record, field => $fromFieldName, subfield => $fromSubfieldName });
 468     if ( @$field_numbers ) {
 469         @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
 470     }
 471     _modify_values({ values => \@values, regex => $regex });
 472     _update_subfield({ record => $record, field => $toFieldName, subfield => $toSubfieldName, dont_erase => 1, values => \@values });
 473
 474     # And delete
 475     _delete_subfield({
 476         record => $record,
 477         field => $fromFieldName,
 478         subfield => $fromSubfieldName,
 479         field_numbers => $field_numbers,
 480     });
 481 }
 482
 483 =head2 _delete_field
 484
 485   _delete_field( $record, $fieldName[, $subfieldName [, $n ] ] );
 486
 487   Deletes the given field.
 488
 489   If $n is passed, only the Nth field will be deleted. $n = 1
 490   will delete the first repeatable field, $n = 3 will delete the third.
 491
 492 =cut
 493
 494 sub delete_field {
 495     my ( $params ) = @_;
 496     my $record = $params->{record};
 497     my $fieldName = $params->{field};
 498     my $subfieldName = $params->{subfield};
 499     my $field_numbers = $params->{field_numbers} // [];
 500
 501     if ( not $subfieldName or $subfieldName eq '' ) {
 502         _delete_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
 503     } else {
 504         _delete_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
 505     }
 506 }
 507
 508 sub _delete_field {
 509     my ( $params ) = @_;
 510     my $record = $params->{record};
 511     my $fieldName = $params->{field};
 512     my $field_numbers = $params->{field_numbers} // [];
 513
 514     my @fields = $record->field( $fieldName );
 515
 516     if ( @$field_numbers ) {
 517         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 518     }
 519     foreach my $field ( @fields ) {
 520         $record->delete_field( $field );
 521     }
 522 }
 523
 524 sub _delete_subfield {
 525     my ( $params ) = @_;
 526     my $record = $params->{record};
 527     my $fieldName = $params->{field};
 528     my $subfieldName = $params->{subfield};
 529     my $field_numbers = $params->{field_numbers} // [];
 530
 531     my @fields = $record->field( $fieldName );
 532
 533     if ( @$field_numbers ) {
 534         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 535     }
 536
 537     foreach my $field ( @fields ) {
 538         $field->delete_subfield( code => $subfieldName );
 539     }
 540 }
 541
 542
 543 sub _copy_move_field {
 544     my ( $params ) = @_;
 545     my $record = $params->{record};
 546     my $fromFieldName = $params->{from_field};
 547     my $toFieldName = $params->{to_field};
 548     my $regex = $params->{regex};
 549     my $field_numbers = $params->{field_numbers} // [];
 550     my $action = $params->{action} || 'copy';
 551
 552     my @fields = $record->field( $fromFieldName );
 553     if ( @$field_numbers ) {
 554         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 555     }
 556
 557     for my $field ( @fields ) {
 558         my $new_field = $field->clone;
 559         $new_field->{_tag} = $toFieldName; # Should be replaced by set_tag, introduced by MARC::Field 2.0.4
 560         if ( $regex and $regex->{search} ) {
 561             for my $subfield ( $new_field->subfields ) {
 562                 my $value = $subfield->[1];
 563                 ( $value ) = _modify_values({ values => [ $value ], regex => $regex });
 564                 $new_field->update( $subfield->[0], $value );
 565             }
 566         }
 567         $record->append_fields( $new_field );
 568         $record->delete_field( $field )
 569             if $action eq 'move';
 570     }
 571 }
 572
 573 sub _modify_values {
 574     my ( $params ) = @_;
 575     my $values = $params->{values};
 576     my $regex = $params->{regex};
 577
 578     if ( $regex and $regex->{search} ) {
 579         $regex->{modifiers} //= q||;
 580         my @available_modifiers = qw( i g );
 581         my $modifiers = q||;
 582         for my $modifier ( split //, $regex->{modifiers} ) {
 583             $modifiers .= $modifier
 584                 if grep {/$modifier/} @available_modifiers;
 585         }
 586         foreach my $value ( @$values ) {
 587             if ( $modifiers =~ m/^(ig|gi)$/ ) {
 588                 $value =~ s/$regex->{search}/$regex->{replace}/ig;
 589             }
 590             elsif ( $modifiers eq 'i' ) {
 591                 $value =~ s/$regex->{search}/$regex->{replace}/i;
 592             }
 593             elsif ( $modifiers eq 'g' ) {
 594                 $value =~ s/$regex->{search}/$regex->{replace}/g;
 595             }
 596             else {
 597                 $value =~ s/$regex->{search}/$regex->{replace}/;
 598             }
 599         }
 600     }
 601     return @$values;
 602 }
 603 1;
 604 __END__