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   copy_and_replace_field
  23   move_field
  24   delete_field
  25   field_exists
  26   field_equals
  27 );
  28
  29 our $VERSION = '0.01';
  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 sub _update_field {
 177     my ( $params ) = @_;
 178     my $record = $params->{record};
 179     my $fieldName = $params->{field};
 180     my @values = @{ $params->{values} };
 181
 182     my $i = 0;
 183     if ( my @fields = $record->field( $fieldName ) ) {
 184         @values = ($values[0]) x scalar( @fields )
 185             if @values == 1;
 186         foreach my $field ( @fields ) {
 187             $field->update( $values[$i++] );
 188         }
 189     } else {
 190         ## Field does not exists, create it
 191         if ( $fieldName < 10 ) {
 192             foreach my $value ( @values ) {
 193                 my $field = MARC::Field->new( $fieldName, $value );
 194                 $record->append_fields( $field );
 195             }
 196         } else {
 197             warn "Invalid operation, trying to add a new field without subfield";
 198         }
 199     }
 200 }
 201
 202 sub _update_subfield {
 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 $dont_erase = $params->{dont_erase};
 209     my $field_numbers = $params->{field_numbers} // [];
 210     my $i = 0;
 211
 212     my @fields = $record->field( $fieldName );
 213
 214     if ( @$field_numbers ) {
 215         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 216     }
 217
 218     if ( @fields ) {
 219         unless ( $dont_erase ) {
 220             @values = ($values[0]) x scalar( @fields )
 221                 if @values == 1;
 222             foreach my $field ( @fields ) {
 223                 $field->update( "$subfieldName" => $values[$i++] );
 224             }
 225         }
 226         if ( $i <= scalar ( @values ) - 1 ) {
 227             foreach my $field ( @fields ) {
 228                 foreach my $j ( $i .. scalar( @values ) - 1) {
 229                     $field->add_subfields( "$subfieldName" => $values[$j] );
 230                 }
 231             }
 232         }
 233     } else {
 234         ## Field does not exist, create it.
 235         foreach my $value ( @values ) {
 236             my $field = MARC::Field->new( $fieldName, '', '', "$subfieldName" => $values[$i++] );
 237             $record->append_fields( $field );
 238         }
 239     }
 240 }
 241
 242 =head2 read_field
 243
 244   my @values = read_field( $record, $fieldName[, $subfieldName, [, $n ] ] );
 245
 246   Returns an array of field values for the given field and subfield
 247
 248   If $n is given, it will return only the $nth value of the array.
 249   E.g. If $n = 1, it return the 1st value, if $n = 3, it will return the 3rd value.
 250
 251 =cut
 252
 253 sub read_field {
 254     my ( $params ) = @_;
 255     my $record = $params->{record};
 256     my $fieldName = $params->{field};
 257     my $subfieldName = $params->{subfield};
 258     my $field_numbers = $params->{field_numbers} // [];
 259
 260     if ( not $subfieldName or $subfieldName eq '' ) {
 261         _read_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
 262     } else {
 263         _read_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
 264     }
 265 }
 266
 267 sub _read_field {
 268     my ( $params ) = @_;
 269     my $record = $params->{record};
 270     my $fieldName = $params->{field};
 271     my $field_numbers = $params->{field_numbers} // [];
 272
 273     my @fields = $record->field( $fieldName );
 274
 275     return unless @fields;
 276
 277     return map { $_->data() } @fields
 278         if $fieldName < 10;
 279
 280     my @values;
 281     if ( @$field_numbers ) {
 282         for my $field_number ( @$field_numbers ) {
 283             if ( $field_number <= scalar( @fields ) ) {
 284                 for my $sf ( $fields[$field_number - 1]->subfields ) {
 285                     push @values, $sf->[1];
 286                 }
 287             }
 288         }
 289     } else {
 290         foreach my $field ( @fields ) {
 291             for my $sf ( $field->subfields ) {
 292                 push @values, $sf->[1];
 293             }
 294         }
 295     }
 296
 297     return @values;
 298 }
 299
 300 sub _read_subfield {
 301     my ( $params ) = @_;
 302     my $record = $params->{record};
 303     my $fieldName = $params->{field};
 304     my $subfieldName = $params->{subfield};
 305     my $field_numbers = $params->{field_numbers} // [];
 306
 307     my @fields = $record->field( $fieldName );
 308
 309     return unless @fields;
 310
 311     my @values;
 312     foreach my $field ( @fields ) {
 313         my @sf = $field->subfield( $subfieldName );
 314         push( @values, @sf );
 315     }
 316
 317     if ( @values and @$field_numbers ) {
 318         @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
 319     }
 320
 321     return @values;
 322 }
 323
 324 =head2 field_exists
 325
 326   @field_numbers = field_exists( $record, $fieldName[, $subfieldName ]);
 327
 328   Returns the field numbers or an empty array.
 329
 330 =cut
 331
 332 sub field_exists {
 333   my ( $params ) = @_;
 334   my $record = $params->{record};
 335   my $fieldName = $params->{field};
 336   my $subfieldName = $params->{subfield};
 337
 338   if ( ! $record ) { return; }
 339
 340   my @field_numbers = ();
 341   my $current_field_number = 1;
 342   for my $field ( $record->field( $fieldName ) ) {
 343     if ( $subfieldName ) {
 344       push @field_numbers, $current_field_number
 345         if $field->subfield( $subfieldName );
 346     } else {
 347       push @field_numbers, $current_field_number;
 348     }
 349     $current_field_number++;
 350   }
 351
 352   return \@field_numbers;
 353 }
 354
 355 =head2 field_equals
 356
 357   $bool = field_equals( $record, $value, $fieldName[, $subfieldName[, $regex ] ]);
 358
 359   Returns true if the field equals the given value, false otherwise.
 360
 361   If a regular expression ( $regex ) is supplied, the value will be compared using
 362   the given regex. Example: $regex = 'sought_text'
 363
 364 =cut
 365
 366 sub field_equals {
 367   my ( $params ) = @_;
 368   my $record = $params->{record};
 369   my $value = $params->{value};
 370   my $fieldName = $params->{field};
 371   my $subfieldName = $params->{subfield};
 372   my $is_regex = $params->{is_regex};
 373
 374   if ( ! $record ) { return; }
 375
 376   my @field_numbers = ();
 377   my $current_field_number = 1;
 378   FIELDS: for my $field ( $record->field( $fieldName ) ) {
 379     my @subfield_values = $subfieldName
 380         ? $field->subfield( $subfieldName )
 381         : map { $_->[1] } $field->subfields;
 382
 383     SUBFIELDS: for my $subfield_value ( @subfield_values ) {
 384       if (
 385           (
 386               $is_regex and $subfield_value =~ m/$value/
 387           ) or (
 388               $subfield_value eq $value
 389           )
 390       ) {
 391           push @field_numbers, $current_field_number;
 392           last SUBFIELDS;
 393       }
 394     }
 395     $current_field_number++;
 396   }
 397
 398   return \@field_numbers;
 399 }
 400
 401 =head2 move_field
 402
 403   move_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex [, $n ] ] );
 404
 405   Moves a value from one field to another. If a regular expression ( $regex ) is supplied,
 406   the value will be transformed by the given regex before being moved into the new field.
 407   Example: $regex = 's/Old Text/Replacement Text/'
 408
 409   If $n is passed, only the Nth field will be moved. $n = 1
 410   will move the first repeatable field, $n = 3 will move the third.
 411
 412 =cut
 413
 414 sub move_field {
 415     my ( $params ) = @_;
 416     my $record = $params->{record};
 417     my $fromFieldName = $params->{from_field};
 418     my $fromSubfieldName = $params->{from_subfield};
 419     my $toFieldName = $params->{to_field};
 420     my $toSubfieldName = $params->{to_subfield};
 421     my $regex = $params->{regex};
 422     my $field_numbers = $params->{field_numbers} // [];
 423
 424     if (   not $fromSubfieldName
 425         or $fromSubfieldName eq ''
 426         or not $toSubfieldName
 427         or $toSubfieldName eq '' ) {
 428         _copy_move_field(
 429             {   record        => $record,
 430                 from_field    => $fromFieldName,
 431                 to_field      => $toFieldName,
 432                 regex         => $regex,
 433                 field_numbers => $field_numbers,
 434                 action        => 'move',
 435             }
 436         );
 437     } else {
 438         _copy_move_subfield(
 439             {   record        => $record,
 440                 from_field    => $fromFieldName,
 441                 from_subfield => $fromSubfieldName,
 442                 to_field      => $toFieldName,
 443                 to_subfield   => $toSubfieldName,
 444                 regex         => $regex,
 445                 field_numbers => $field_numbers,
 446                 action        => 'move',
 447             }
 448         );
 449     }
 450 }
 451
 452 =head2 _delete_field
 453
 454   _delete_field( $record, $fieldName[, $subfieldName [, $n ] ] );
 455
 456   Deletes the given field.
 457
 458   If $n is passed, only the Nth field will be deleted. $n = 1
 459   will delete the first repeatable field, $n = 3 will delete the third.
 460
 461 =cut
 462
 463 sub delete_field {
 464     my ( $params ) = @_;
 465     my $record = $params->{record};
 466     my $fieldName = $params->{field};
 467     my $subfieldName = $params->{subfield};
 468     my $field_numbers = $params->{field_numbers} // [];
 469
 470     if ( not $subfieldName or $subfieldName eq '' ) {
 471         _delete_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
 472     } else {
 473         _delete_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
 474     }
 475 }
 476
 477 sub _delete_field {
 478     my ( $params ) = @_;
 479     my $record = $params->{record};
 480     my $fieldName = $params->{field};
 481     my $field_numbers = $params->{field_numbers} // [];
 482
 483     my @fields = $record->field( $fieldName );
 484
 485     if ( @$field_numbers ) {
 486         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 487     }
 488     foreach my $field ( @fields ) {
 489         $record->delete_field( $field );
 490     }
 491 }
 492
 493 sub _delete_subfield {
 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     my @fields = $record->field( $fieldName );
 501
 502     if ( @$field_numbers ) {
 503         @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
 504     }
 505
 506     foreach my $field ( @fields ) {
 507         $field->delete_subfield( code => $subfieldName );
 508     }
 509 }
 510
 511
 512 sub _copy_move_field {
 513     my ( $params ) = @_;
 514     my $record = $params->{record};
 515     my $fromFieldName = $params->{from_field};
 516     my $toFieldName = $params->{to_field};
 517     my $regex = $params->{regex};
 518     my $field_numbers = $params->{field_numbers} // [];
 519     my $action = $params->{action} || 'copy';
 520
 521     my @from_fields = $record->field( $fromFieldName );
 522     if ( @$field_numbers ) {
 523         @from_fields = map { $_ <= @from_fields ? $from_fields[ $_ - 1 ] : () } @$field_numbers;
 524     }
 525
 526     my @new_fields;
 527     for my $from_field ( @from_fields ) {
 528         my $new_field = $from_field->clone;
 529         $new_field->{_tag} = $toFieldName; # Should be replaced by set_tag, introduced by MARC::Field 2.0.4
 530         if ( $regex and $regex->{search} ) {
 531             for my $subfield ( $new_field->subfields ) {
 532                 my $value = $subfield->[1];
 533                 ( $value ) = _modify_values({ values => [ $value ], regex => $regex });
 534                 $new_field->update( $subfield->[0], $value );
 535             }
 536         }
 537         if ( $action eq 'move' ) {
 538             $record->delete_field( $from_field )
 539         }
 540         elsif ( $action eq 'replace' ) {
 541             my @to_fields = $record->field( $toFieldName );
 542             if ( @to_fields ) {
 543                 $record->delete_field( $to_fields[0] );
 544             }
 545         }
 546         push @new_fields, $new_field;
 547     }
 548     $record->append_fields( @new_fields );
 549 }
 550
 551 sub _copy_move_subfield {
 552     my ( $params ) = @_;
 553     my $record = $params->{record};
 554     my $fromFieldName = $params->{from_field};
 555     my $fromSubfieldName = $params->{from_subfield};
 556     my $toFieldName = $params->{to_field};
 557     my $toSubfieldName = $params->{to_subfield};
 558     my $regex = $params->{regex};
 559     my $field_numbers = $params->{field_numbers} // [];
 560     my $action = $params->{action} || 'copy';
 561
 562     my @values = read_field({ record => $record, field => $fromFieldName, subfield => $fromSubfieldName });
 563     if ( @$field_numbers ) {
 564         @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
 565     }
 566     _modify_values({ values => \@values, regex => $regex });
 567     my $dont_erase = $action eq 'copy' ? 1 : 0;
 568     _update_subfield({ record => $record, field => $toFieldName, subfield => $toSubfieldName, values => \@values, dont_erase => $dont_erase });
 569
 570     # And delete if it's a move
 571     if ( $action eq 'move' ) {
 572         _delete_subfield({
 573             record => $record,
 574             field => $fromFieldName,
 575             subfield => $fromSubfieldName,
 576             field_numbers => $field_numbers,
 577         });
 578     }
 579 }
 580
 581 sub _modify_values {
 582     my ( $params ) = @_;
 583     my $values = $params->{values};
 584     my $regex = $params->{regex};
 585
 586     if ( $regex and $regex->{search} ) {
 587         $regex->{modifiers} //= q||;
 588         my @available_modifiers = qw( i g );
 589         my $modifiers = q||;
 590         for my $modifier ( split //, $regex->{modifiers} ) {
 591             $modifiers .= $modifier
 592                 if grep {/$modifier/} @available_modifiers;
 593         }
 594         foreach my $value ( @$values ) {
 595             if ( $modifiers =~ m/^(ig|gi)$/ ) {
 596                 $value =~ s/$regex->{search}/$regex->{replace}/ig;
 597             }
 598             elsif ( $modifiers eq 'i' ) {
 599                 $value =~ s/$regex->{search}/$regex->{replace}/i;
 600             }
 601             elsif ( $modifiers eq 'g' ) {
 602                 $value =~ s/$regex->{search}/$regex->{replace}/g;
 603             }
 604             else {
 605                 $value =~ s/$regex->{search}/$regex->{replace}/;
 606             }
 607         }
 608     }
 609     return @$values;
 610 }
 611 1;
 612 __END__