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;
 419     if ( $field->is_control_field ) {
 420         push @subfield_values, $field->data;
 421     } else {
 422         @subfield_values =
 423             $subfieldName
 424           ? $field->subfield($subfieldName)
 425           : map { $_->[1] } $field->subfields;
 426     }
 427
 428     SUBFIELDS: for my $subfield_value ( @subfield_values ) {
 429       if (
 430           (
 431               $is_regex and $subfield_value =~ m/$value/
 432           ) or (
 433               $subfield_value eq $value
 434           )
 435       ) {
 436           push @field_numbers, $current_field_number;
 437           last SUBFIELDS;
 438       }
 439     }
 440     $current_field_number++;
 441   }
 442
 443   return \@field_numbers;
 444 }
 445
 446 =head2 move_field
 447
 448   move_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex [, $n ] ] );
 449
 450   Moves a value from one field to another. If a regular expression ( $regex ) is supplied,
 451   the value will be transformed by the given regex before being moved into the new field.
 452   Example: $regex = 's/Old Text/Replacement Text/'
 453
 454   If $n is passed, only the Nth field will be moved. $n = 1
 455   will move the first repeatable field, $n = 3 will move the third.
 456
 457 =cut
 458
 459 sub move_field {
 460     my ( $params ) = @_;
 461     my $record = $params->{record};
 462     my $fromFieldName = $params->{from_field};
 463     my $fromSubfieldName = $params->{from_subfield};
 464     my $toFieldName = $params->{to_field};
 465     my $toSubfieldName = $params->{to_subfield};
 466     my $regex = $params->{regex};
 467     my $field_numbers = $params->{field_numbers} // [];
 468
 469     if (   not $fromSubfieldName
 470         or $fromSubfieldName eq ''
 471         or not $toSubfieldName
 472         or $toSubfieldName eq '' ) {
 473         _copy_move_field(
 474             {   record        => $record,
 475                 from_field    => $fromFieldName,
 476                 to_field      => $toFieldName,
 477                 regex         => $regex,
 478                 field_numbers => $field_numbers,
 479                 action        => 'move',
 480             }
 481         );
 482     } else {
 483         _copy_move_subfield(
 484             {   record        => $record,
 485                 from_field    => $fromFieldName,
 486                 from_subfield => $fromSubfieldName,
 487                 to_field      => $toFieldName,
 488                 to_subfield   => $toSubfieldName,
 489                 regex         => $regex,
 490                 field_numbers => $field_numbers,
 491                 action        => 'move',
 492             }
 493         );
 494     }
 495 }
 496
 497 =head2 _delete_field
 498
 499   _delete_field( $record, $fieldName[, $subfieldName [, $n ] ] );
 500
 501   Deletes the given field.
 502
 503   If $n is passed, only the Nth field will be deleted. $n = 1
 504   will delete the first repeatable field, $n = 3 will delete the third.
 505
 506 =cut
 507
 508 sub delete_field {
 509     my ( $params ) = @_;
 510     my $record = $params->{record};
 511     my $fieldName = $params->{field};
 512     my $subfieldName = $params->{subfield};
 513     my $field_numbers = $params->{field_numbers} // [];
 514
 515     if ( not $subfieldName or $subfieldName eq '' ) {
 516         _delete_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
 517     } else {
 518         _delete_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
 519     }
 520 }
 521
 522 sub _delete_field {
 523     my ( $params ) = @_;
 524     my $record = $params->{record};
 525     my $fieldName = $params->{field};
 526     my $field_numbers = $params->{field_numbers} // [];
 527
 528     my @fields = $record->field( $fieldName );
 529
 530     if ( @$field_numbers ) {
 531         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 532     }
 533     foreach my $field ( @fields ) {
 534         $record->delete_field( $field );
 535     }
 536 }
 537
 538 sub _delete_subfield {
 539     my ( $params ) = @_;
 540     my $record = $params->{record};
 541     my $fieldName = $params->{field};
 542     my $subfieldName = $params->{subfield};
 543     my $field_numbers = $params->{field_numbers} // [];
 544
 545     my @fields = $record->field( $fieldName );
 546
 547     if ( @$field_numbers ) {
 548         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 549     }
 550
 551     foreach my $field ( @fields ) {
 552         $field->delete_subfield( code => $subfieldName );
 553     }
 554 }
 555
 556
 557 sub _copy_move_field {
 558     my ( $params ) = @_;
 559     my $record = $params->{record};
 560     my $fromFieldName = $params->{from_field};
 561     my $toFieldName = $params->{to_field};
 562     my $regex = $params->{regex};
 563     my $field_numbers = $params->{field_numbers} // [];
 564     my $action = $params->{action} || 'copy';
 565
 566     my @from_fields = $record->field( $fromFieldName );
 567     if ( @$field_numbers ) {
 568         @from_fields = map { $_ <= @from_fields ? $from_fields[ $_ - 1 ] : () } @$field_numbers;
 569     }
 570
 571     my @new_fields;
 572     for my $from_field ( @from_fields ) {
 573         my $new_field = $from_field->clone;
 574         $new_field->{_tag} = $toFieldName; # Should be replaced by set_tag, introduced by MARC::Field 2.0.4
 575         if ( $regex and $regex->{search} ) {
 576             for my $subfield ( $new_field->subfields ) {
 577                 my $value = $subfield->[1];
 578                 ( $value ) = _modify_values({ values => [ $value ], regex => $regex });
 579                 $new_field->update( $subfield->[0], $value );
 580             }
 581         }
 582         if ( $action eq 'move' ) {
 583             $record->delete_field( $from_field )
 584         }
 585         elsif ( $action eq 'replace' ) {
 586             my @to_fields = $record->field( $toFieldName );
 587             if ( @to_fields ) {
 588                 $record->delete_field( $to_fields[0] );
 589             }
 590         }
 591         push @new_fields, $new_field;
 592     }
 593     $record->append_fields( @new_fields );
 594 }
 595
 596 sub _copy_move_subfield {
 597     my ( $params ) = @_;
 598     my $record = $params->{record};
 599     my $fromFieldName = $params->{from_field};
 600     my $fromSubfieldName = $params->{from_subfield};
 601     my $toFieldName = $params->{to_field};
 602     my $toSubfieldName = $params->{to_subfield};
 603     my $regex = $params->{regex};
 604     my $field_numbers = $params->{field_numbers} // [];
 605     my $action = $params->{action} || 'copy';
 606
 607     my @values = read_field({ record => $record, field => $fromFieldName, subfield => $fromSubfieldName });
 608     if ( @$field_numbers ) {
 609         @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
 610     }
 611     _modify_values({ values => \@values, regex => $regex });
 612     my $dont_erase = $action eq 'copy' ? 1 : 0;
 613     _update_subfield({ record => $record, field => $toFieldName, subfield => $toSubfieldName, values => \@values, dont_erase => $dont_erase });
 614
 615     # And delete if it's a move
 616     if ( $action eq 'move' ) {
 617         _delete_subfield({
 618             record => $record,
 619             field => $fromFieldName,
 620             subfield => $fromSubfieldName,
 621             field_numbers => $field_numbers,
 622         });
 623     }
 624 }
 625
 626 sub _modify_values {
 627     my ( $params ) = @_;
 628     my $values = $params->{values};
 629     my $regex = $params->{regex};
 630
 631     if ( $regex and $regex->{search} ) {
 632         $regex->{modifiers} //= q||;
 633         my @available_modifiers = qw( i g );
 634         my $modifiers = q||;
 635         for my $modifier ( split //, $regex->{modifiers} ) {
 636             $modifiers .= $modifier
 637                 if grep {/$modifier/} @available_modifiers;
 638         }
 639         foreach my $value ( @$values ) {
 640             if ( $modifiers =~ m/^(ig|gi)$/ ) {
 641                 $value =~ s/$regex->{search}/$regex->{replace}/ig;
 642             }
 643             elsif ( $modifiers eq 'i' ) {
 644                 $value =~ s/$regex->{search}/$regex->{replace}/i;
 645             }
 646             elsif ( $modifiers eq 'g' ) {
 647                 $value =~ s/$regex->{search}/$regex->{replace}/g;
 648             }
 649             else {
 650                 $value =~ s/$regex->{search}/$regex->{replace}/;
 651             }
 652         }
 653     }
 654     return @$values;
 655 }
 656 1;
 657 __END__