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