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