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