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