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