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