Koha/SimpleMARC.pm

   1 package Koha::SimpleMARC;
   2
   3 # Copyright 2009 Kyle M. Hall <kyle.m.hall@gmail.com>
   4
   5 # Koha is free software; you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # Koha is distributed in the hope that it will be useful, but
  11 # 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 Koha; if not, see <http://www.gnu.org/licenses>.
  17
  18
  19 use Modern::Perl;
  20
  21 #use MARC::Record;
  22
  23 require Exporter;
  24
  25 our @ISA = qw(Exporter);
  26 our %EXPORT_TAGS = ( 'all' => [ qw(
  27
  28 ) ] );
  29
  30 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  31
  32 our @EXPORT = qw(
  33   read_field
  34   add_field
  35   update_field
  36   copy_field
  37   copy_and_replace_field
  38   move_field
  39   delete_field
  40   field_exists
  41   field_equals
  42 );
  43
  44
  45 our $debug = 0;
  46
  47 =head1 NAME
  48
  49 SimpleMARC - Perl module for making simple MARC record alterations.
  50
  51 =head1 SYNOPSIS
  52
  53   use SimpleMARC;
  54
  55 =head1 DESCRIPTION
  56
  57 SimpleMARC is designed to make writing scripts
  58 to modify MARC records simple and easy.
  59
  60 Every function in the modules requires a
  61 MARC::Record object as its first parameter.
  62
  63 =head1 AUTHOR
  64
  65 Kyle Hall <lt>kyle.m.hall@gmail.com<gt>
  66
  67 =head1 COPYRIGHT AND LICENSE
  68
  69 Copyright (C) 2009 by Kyle Hall
  70
  71 This library is free software; you can redistribute it and/or modify
  72 it under the same terms as Perl itself, either Perl version 5.8.7 or,
  73 at your option, any later version of Perl 5 you may have available.
  74
  75 =head1 FUNCTIONS
  76
  77 =head2 copy_field
  78
  79   copy_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex[, $n ] ] );
  80
  81   Copies a value from one field to another. If a regular expression ( $regex ) is supplied,
  82   the value will be transformed by the given regex before being copied into the new field.
  83   Example: $regex = { search => 'Old Text', replace => 'Replacement Text', modifiers => 'g' };
  84
  85   If $n is passed, copy_field will only copy the Nth field of the list of fields.
  86   E.g. $n = 1 will only use the first field's value, $n = 2 will use only the 2nd field's value.
  87
  88 =cut
  89
  90 sub copy_field {
  91     my ( $params ) = @_;
  92     my $record = $params->{record};
  93     my $fromFieldName = $params->{from_field};
  94     my $fromSubfieldName = $params->{from_subfield};
  95     my $toFieldName = $params->{to_field};
  96     my $toSubfieldName = $params->{to_subfield};
  97     my $regex = $params->{regex};
  98     my $field_numbers = $params->{field_numbers} // [];
  99
 100     if ( ! ( $record && $fromFieldName && $toFieldName ) ) { return; }
 101
 102
 103     if (   not $fromSubfieldName
 104         or $fromSubfieldName eq ''
 105         or not $toSubfieldName
 106         or $toSubfieldName eq '' ) {
 107         _copy_move_field(
 108             {   record        => $record,
 109                 from_field    => $fromFieldName,
 110                 to_field      => $toFieldName,
 111                 regex         => $regex,
 112                 field_numbers => $field_numbers,
 113                 action        => 'copy',
 114             }
 115         );
 116     } else {
 117         _copy_move_subfield(
 118             {   record        => $record,
 119                 from_field    => $fromFieldName,
 120                 from_subfield => $fromSubfieldName,
 121                 to_field      => $toFieldName,
 122                 to_subfield   => $toSubfieldName,
 123                 regex         => $regex,
 124                 field_numbers => $field_numbers,
 125                 action        => 'copy',
 126             }
 127         );
 128     }
 129 }
 130
 131 sub copy_and_replace_field {
 132     my ( $params ) = @_;
 133     my $record = $params->{record};
 134     my $fromFieldName = $params->{from_field};
 135     my $fromSubfieldName = $params->{from_subfield};
 136     my $toFieldName = $params->{to_field};
 137     my $toSubfieldName = $params->{to_subfield};
 138     my $regex = $params->{regex};
 139     my $field_numbers = $params->{field_numbers} // [];
 140
 141     if ( ! ( $record && $fromFieldName && $toFieldName ) ) { return; }
 142
 143
 144     if ( not $fromSubfieldName or $fromSubfieldName eq ''
 145       or not $toSubfieldName or $toSubfieldName eq ''
 146     ) {
 147         _copy_move_field(
 148             {   record        => $record,
 149                 from_field    => $fromFieldName,
 150                 to_field      => $toFieldName,
 151                 regex         => $regex,
 152                 field_numbers => $field_numbers,
 153                 action        => 'replace',
 154             }
 155         );
 156     } else {
 157         _copy_move_subfield(
 158             {   record        => $record,
 159                 from_field    => $fromFieldName,
 160                 from_subfield => $fromSubfieldName,
 161                 to_field      => $toFieldName,
 162                 to_subfield   => $toSubfieldName,
 163                 regex         => $regex,
 164                 field_numbers => $field_numbers,
 165                 action        => 'replace',
 166             }
 167         );
 168     }
 169 }
 170
 171 sub update_field {
 172     my ( $params ) = @_;
 173     my $record = $params->{record};
 174     my $fieldName = $params->{field};
 175     my $subfieldName = $params->{subfield};
 176     my @values = @{ $params->{values} };
 177     my $field_numbers = $params->{field_numbers} // [];
 178
 179     if ( ! ( $record && $fieldName ) ) { return; }
 180
 181     if ( not defined $subfieldName or $subfieldName eq '' ) {
 182         # FIXME I'm not sure the actual implementation is correct.
 183         die "This action is not implemented yet";
 184         #_update_field({ record => $record, field => $fieldName, values => \@values });
 185     } else {
 186         _update_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, values => \@values, field_numbers => $field_numbers });
 187     }
 188 }
 189
 190 =head2 add_field
 191
 192   add_field({
 193       record   => $record,
 194       field    => $fieldName,
 195       subfield => $subfieldName,
 196       values   => \@values,
 197       field_numbers => $field_numbers,
 198   });
 199
 200   Adds a new field/subfield with supplied value(s).
 201   This function always add a new field as opposed to 'update_field' which will
 202   either update if field exists and add if it does not.
 203
 204 =cut
 205
 206
 207 sub add_field {
 208     my ( $params ) = @_;
 209     my $record = $params->{record};
 210     my $fieldName = $params->{field};
 211     my $subfieldName = $params->{subfield};
 212     my @values = @{ $params->{values} };
 213     my $field_numbers = $params->{field_numbers} // [];
 214
 215     if ( ! ( $record && $fieldName ) ) { return; }
 216     if ( $fieldName > 10 ) {
 217         foreach my $value ( @values ) {
 218             my $field = MARC::Field->new( $fieldName, '', '', "$subfieldName" => $value );
 219             $record->append_fields( $field );
 220         }
 221     } else {
 222         foreach my $value ( @values ) {
 223             my $field = MARC::Field->new( $fieldName, $value );
 224             $record->append_fields( $field );
 225         }
 226     }
 227 }
 228
 229 sub _update_field {
 230     my ( $params ) = @_;
 231     my $record = $params->{record};
 232     my $fieldName = $params->{field};
 233     my @values = @{ $params->{values} };
 234
 235     my $i = 0;
 236     if ( my @fields = $record->field( $fieldName ) ) {
 237         @values = ($values[0]) x scalar( @fields )
 238             if @values == 1;
 239         foreach my $field ( @fields ) {
 240             $field->update( $values[$i++] );
 241         }
 242     } else {
 243         ## Field does not exists, create it
 244         if ( $fieldName < 10 ) {
 245             foreach my $value ( @values ) {
 246                 my $field = MARC::Field->new( $fieldName, $value );
 247                 $record->append_fields( $field );
 248             }
 249         } else {
 250             warn "Invalid operation, trying to add a new field without subfield";
 251         }
 252     }
 253 }
 254
 255 sub _update_subfield {
 256     my ( $params ) = @_;
 257     my $record = $params->{record};
 258     my $fieldName = $params->{field};
 259     my $subfieldName = $params->{subfield};
 260     my @values = @{ $params->{values} };
 261     my $dont_erase = $params->{dont_erase};
 262     my $field_numbers = $params->{field_numbers} // [];
 263     my $i = 0;
 264
 265     my @fields = $record->field( $fieldName );
 266
 267     if ( @$field_numbers ) {
 268         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 269     }
 270
 271     if ( @fields ) {
 272         unless ( $dont_erase ) {
 273             @values = ($values[0]) x scalar( @fields )
 274                 if @values == 1;
 275             foreach my $field ( @fields ) {
 276                 $field->update( "$subfieldName" => $values[$i++] );
 277             }
 278         }
 279         if ( $i <= scalar ( @values ) - 1 ) {
 280             foreach my $field ( @fields ) {
 281                 foreach my $j ( $i .. scalar( @values ) - 1) {
 282                     $field->add_subfields( "$subfieldName" => $values[$j] );
 283                 }
 284             }
 285         }
 286     } else {
 287         ## Field does not exist, create it.
 288         foreach my $value ( @values ) {
 289             my $field = MARC::Field->new( $fieldName, '', '', "$subfieldName" => $values[$i++] );
 290             $record->append_fields( $field );
 291         }
 292     }
 293 }
 294
 295 =head2 read_field
 296
 297   my @values = read_field( $record, $fieldName[, $subfieldName, [, $n ] ] );
 298
 299   Returns an array of field values for the given field and subfield
 300
 301   If $n is given, it will return only the $nth value of the array.
 302   E.g. If $n = 1, it return the 1st value, if $n = 3, it will return the 3rd value.
 303
 304 =cut
 305
 306 sub read_field {
 307     my ( $params ) = @_;
 308     my $record = $params->{record};
 309     my $fieldName = $params->{field};
 310     my $subfieldName = $params->{subfield};
 311     my $field_numbers = $params->{field_numbers} // [];
 312
 313     if ( not defined $subfieldName or $subfieldName eq '' ) {
 314         _read_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
 315     } else {
 316         _read_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
 317     }
 318 }
 319
 320 sub _read_field {
 321     my ( $params ) = @_;
 322     my $record = $params->{record};
 323     my $fieldName = $params->{field};
 324     my $field_numbers = $params->{field_numbers} // [];
 325
 326     my @fields = $record->field( $fieldName );
 327
 328     return unless @fields;
 329
 330     return map { $_->data() } @fields
 331         if $fieldName < 10;
 332
 333     my @values;
 334     if ( @$field_numbers ) {
 335         for my $field_number ( @$field_numbers ) {
 336             if ( $field_number <= scalar( @fields ) ) {
 337                 for my $sf ( $fields[$field_number - 1]->subfields ) {
 338                     push @values, $sf->[1];
 339                 }
 340             }
 341         }
 342     } else {
 343         foreach my $field ( @fields ) {
 344             for my $sf ( $field->subfields ) {
 345                 push @values, $sf->[1];
 346             }
 347         }
 348     }
 349
 350     return @values;
 351 }
 352
 353 sub _read_subfield {
 354     my ( $params ) = @_;
 355     my $record = $params->{record};
 356     my $fieldName = $params->{field};
 357     my $subfieldName = $params->{subfield};
 358     my $field_numbers = $params->{field_numbers} // [];
 359
 360     my @fields = $record->field( $fieldName );
 361
 362     return unless @fields;
 363
 364     my @values;
 365     foreach my $field ( @fields ) {
 366         my @sf = $field->subfield( $subfieldName );
 367         push( @values, @sf );
 368     }
 369
 370     if ( @values and @$field_numbers ) {
 371         @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
 372     }
 373
 374     return @values;
 375 }
 376
 377 =head2 field_exists
 378
 379   @field_numbers = field_exists( $record, $fieldName[, $subfieldName ]);
 380
 381   Returns the field numbers or an empty array.
 382
 383 =cut
 384
 385 sub field_exists {
 386   my ( $params ) = @_;
 387   my $record = $params->{record};
 388   my $fieldName = $params->{field};
 389   my $subfieldName = $params->{subfield};
 390
 391   if ( ! $record ) { return; }
 392
 393   my @field_numbers = ();
 394   my $current_field_number = 1;
 395   for my $field ( $record->field( $fieldName ) ) {
 396     if ( $subfieldName ) {
 397       push @field_numbers, $current_field_number
 398         if $field->subfield( $subfieldName );
 399     } else {
 400       push @field_numbers, $current_field_number;
 401     }
 402     $current_field_number++;
 403   }
 404
 405   return \@field_numbers;
 406 }
 407
 408 =head2 field_equals
 409
 410   $bool = field_equals( $record, $value, $fieldName[, $subfieldName[, $regex ] ]);
 411
 412   Returns true if the field equals the given value, false otherwise.
 413
 414   If a regular expression ( $regex ) is supplied, the value will be compared using
 415   the given regex. Example: $regex = 'sought_text'
 416
 417 =cut
 418
 419 sub field_equals {
 420   my ( $params ) = @_;
 421   my $record = $params->{record};
 422   my $value = $params->{value};
 423   my $fieldName = $params->{field};
 424   my $subfieldName = $params->{subfield};
 425   my $is_regex = $params->{is_regex};
 426
 427   if ( ! $record ) { return; }
 428
 429   my @field_numbers = ();
 430   my $current_field_number = 1;
 431   FIELDS: for my $field ( $record->field( $fieldName ) ) {
 432     my @subfield_values;
 433     if ( $field->is_control_field ) {
 434         push @subfield_values, $field->data;
 435     } else {
 436         @subfield_values =
 437             $subfieldName
 438           ? $field->subfield($subfieldName)
 439           : map { $_->[1] } $field->subfields;
 440     }
 441
 442     SUBFIELDS: for my $subfield_value ( @subfield_values ) {
 443       if (
 444           (
 445               $is_regex and $subfield_value =~ m/$value/
 446           ) or (
 447               $subfield_value eq $value
 448           )
 449       ) {
 450           push @field_numbers, $current_field_number;
 451           last SUBFIELDS;
 452       }
 453     }
 454     $current_field_number++;
 455   }
 456
 457   return \@field_numbers;
 458 }
 459
 460 =head2 move_field
 461
 462   move_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex [, $n ] ] );
 463
 464   Moves a value from one field to another. If a regular expression ( $regex ) is supplied,
 465   the value will be transformed by the given regex before being moved into the new field.
 466   Example: $regex = 's/Old Text/Replacement Text/'
 467
 468   If $n is passed, only the Nth field will be moved. $n = 1
 469   will move the first repeatable field, $n = 3 will move the third.
 470
 471 =cut
 472
 473 sub move_field {
 474     my ( $params ) = @_;
 475     my $record = $params->{record};
 476     my $fromFieldName = $params->{from_field};
 477     my $fromSubfieldName = $params->{from_subfield};
 478     my $toFieldName = $params->{to_field};
 479     my $toSubfieldName = $params->{to_subfield};
 480     my $regex = $params->{regex};
 481     my $field_numbers = $params->{field_numbers} // [];
 482
 483     if (   not $fromSubfieldName
 484         or $fromSubfieldName eq ''
 485         or not $toSubfieldName
 486         or $toSubfieldName eq '' ) {
 487         _copy_move_field(
 488             {   record        => $record,
 489                 from_field    => $fromFieldName,
 490                 to_field      => $toFieldName,
 491                 regex         => $regex,
 492                 field_numbers => $field_numbers,
 493                 action        => 'move',
 494             }
 495         );
 496     } else {
 497         _copy_move_subfield(
 498             {   record        => $record,
 499                 from_field    => $fromFieldName,
 500                 from_subfield => $fromSubfieldName,
 501                 to_field      => $toFieldName,
 502                 to_subfield   => $toSubfieldName,
 503                 regex         => $regex,
 504                 field_numbers => $field_numbers,
 505                 action        => 'move',
 506             }
 507         );
 508     }
 509 }
 510
 511 =head2 _delete_field
 512
 513   _delete_field( $record, $fieldName[, $subfieldName [, $n ] ] );
 514
 515   Deletes the given field.
 516
 517   If $n is passed, only the Nth field will be deleted. $n = 1
 518   will delete the first repeatable field, $n = 3 will delete the third.
 519
 520 =cut
 521
 522 sub delete_field {
 523     my ( $params ) = @_;
 524     my $record = $params->{record};
 525     my $fieldName = $params->{field};
 526     my $subfieldName = $params->{subfield};
 527     my $field_numbers = $params->{field_numbers} // [];
 528
 529     if ( not $subfieldName or $subfieldName eq '' ) {
 530         _delete_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
 531     } else {
 532         _delete_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
 533     }
 534 }
 535
 536 sub _delete_field {
 537     my ( $params ) = @_;
 538     my $record = $params->{record};
 539     my $fieldName = $params->{field};
 540     my $field_numbers = $params->{field_numbers} // [];
 541
 542     my @fields = $record->field( $fieldName );
 543
 544     if ( @$field_numbers ) {
 545         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 546     }
 547     foreach my $field ( @fields ) {
 548         $record->delete_field( $field );
 549     }
 550 }
 551
 552 sub _delete_subfield {
 553     my ( $params ) = @_;
 554     my $record = $params->{record};
 555     my $fieldName = $params->{field};
 556     my $subfieldName = $params->{subfield};
 557     my $field_numbers = $params->{field_numbers} // [];
 558
 559     my @fields = $record->field( $fieldName );
 560
 561     if ( @$field_numbers ) {
 562         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 563     }
 564
 565     foreach my $field ( @fields ) {
 566         $field->delete_subfield( code => $subfieldName );
 567     }
 568 }
 569
 570
 571 sub _copy_move_field {
 572     my ( $params ) = @_;
 573     my $record = $params->{record};
 574     my $fromFieldName = $params->{from_field};
 575     my $toFieldName = $params->{to_field};
 576     my $regex = $params->{regex};
 577     my $field_numbers = $params->{field_numbers} // [];
 578     my $action = $params->{action} || 'copy';
 579
 580     my @from_fields = $record->field( $fromFieldName );
 581     if ( @$field_numbers ) {
 582         @from_fields = map { $_ <= @from_fields ? $from_fields[ $_ - 1 ] : () } @$field_numbers;
 583     }
 584
 585     my @new_fields;
 586     for my $from_field ( @from_fields ) {
 587         my $new_field = $from_field->clone;
 588         $new_field->{_tag} = $toFieldName; # Should be replaced by set_tag, introduced by MARC::Field 2.0.4
 589         if ( $regex and $regex->{search} ) {
 590             for my $subfield ( $new_field->subfields ) {
 591                 my $value = $subfield->[1];
 592                 ( $value ) = _modify_values({ values => [ $value ], regex => $regex });
 593                 $new_field->update( $subfield->[0], $value );
 594             }
 595         }
 596         if ( $action eq 'move' ) {
 597             $record->delete_field( $from_field )
 598         }
 599         elsif ( $action eq 'replace' ) {
 600             my @to_fields = $record->field( $toFieldName );
 601             if ( @to_fields ) {
 602                 $record->delete_field( $to_fields[0] );
 603             }
 604         }
 605         push @new_fields, $new_field;
 606     }
 607     $record->append_fields( @new_fields );
 608 }
 609
 610 sub _copy_move_subfield {
 611     my ( $params ) = @_;
 612     my $record = $params->{record};
 613     my $fromFieldName = $params->{from_field};
 614     my $fromSubfieldName = $params->{from_subfield};
 615     my $toFieldName = $params->{to_field};
 616     my $toSubfieldName = $params->{to_subfield};
 617     my $regex = $params->{regex};
 618     my $field_numbers = $params->{field_numbers} // [];
 619     my $action = $params->{action} || 'copy';
 620
 621     my @values = read_field({ record => $record, field => $fromFieldName, subfield => $fromSubfieldName });
 622     if ( @$field_numbers ) {
 623         @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
 624     }
 625     _modify_values({ values => \@values, regex => $regex });
 626     my $dont_erase = $action eq 'copy' ? 1 : 0;
 627     _update_subfield({ record => $record, field => $toFieldName, subfield => $toSubfieldName, values => \@values, dont_erase => $dont_erase });
 628
 629     # And delete if it's a move
 630     if ( $action eq 'move' ) {
 631         _delete_subfield({
 632             record => $record,
 633             field => $fromFieldName,
 634             subfield => $fromSubfieldName,
 635             field_numbers => $field_numbers,
 636         });
 637     }
 638 }
 639
 640 sub _modify_values {
 641     my ( $params ) = @_;
 642     my $values = $params->{values};
 643     my $regex = $params->{regex};
 644
 645     if ( $regex and $regex->{search} ) {
 646         $regex->{modifiers} //= q||;
 647         my @available_modifiers = qw( i g );
 648         my $modifiers = q||;
 649         for my $modifier ( split //, $regex->{modifiers} ) {
 650             $modifiers .= $modifier
 651                 if grep {/$modifier/} @available_modifiers;
 652         }
 653         foreach my $value ( @$values ) {
 654             if ( $modifiers =~ m/^(ig|gi)$/ ) {
 655                 $value =~ s/$regex->{search}/$regex->{replace}/ig;
 656             }
 657             elsif ( $modifiers eq 'i' ) {
 658                 $value =~ s/$regex->{search}/$regex->{replace}/i;
 659             }
 660             elsif ( $modifiers eq 'g' ) {
 661                 $value =~ s/$regex->{search}/$regex->{replace}/g;
 662             }
 663             else {
 664                 $value =~ s/$regex->{search}/$regex->{replace}/;
 665             }
 666         }
 667     }
 668     return @$values;
 669 }
 670 1;
 671 __END__