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