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