SimpleMARC.pm 19 KB
Newer Older
1
2
3
4
package Koha::SimpleMARC;

# Copyright 2009 Kyle M. Hall <kyle.m.hall@gmail.com>

5
use Modern::Perl;
6
7
8
9
10
11
12
13
14
15
16
17
18
19

#use MARC::Record;

require Exporter;

our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
  read_field
20
  add_field
21
22
  update_field
  copy_field
23
  copy_and_replace_field
24
25
26
27
28
29
30
31
32
33
34
  move_field
  delete_field
  field_exists
  field_equals
);


our $debug = 0;

=head1 NAME

35
SimpleMARC - Perl module for making simple MARC record alterations.
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

=head1 SYNOPSIS

  use SimpleMARC;

=head1 DESCRIPTION

SimpleMARC is designed to make writing scripts
to modify MARC records simple and easy.

Every function in the modules requires a
MARC::Record object as its first parameter.

=head1 AUTHOR

Kyle Hall <lt>kyle.m.hall@gmail.com<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009 by Kyle Hall

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.7 or,
at your option, any later version of Perl 5 you may have available.

=head1 FUNCTIONS

63
=head2 copy_field
64
65
66
67
68

  copy_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex[, $n ] ] );

  Copies a value from one field to another. If a regular expression ( $regex ) is supplied,
  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
72
73
74
75
76

  If $n is passed, copy_field will only copy the Nth field of the list of fields.
  E.g. $n = 1 will only use the first field's value, $n = 2 will use only the 2nd field's value.

=cut

sub copy_field {
77
78
79
80
81
82
83
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fromFieldName = $params->{from_field};
    my $fromSubfieldName = $params->{from_subfield};
    my $toFieldName = $params->{to_field};
    my $toSubfieldName = $params->{to_subfield};
    my $regex = $params->{regex};
84
    my $field_numbers = $params->{field_numbers} // [];
85
86
87
88

    if ( ! ( $record && $fromFieldName && $toFieldName ) ) { return; }


89
90
91
92
93
94
95
96
97
98
99
100
101
    if (   not $fromSubfieldName
        or $fromSubfieldName eq ''
        or not $toSubfieldName
        or $toSubfieldName eq '' ) {
        _copy_move_field(
            {   record        => $record,
                from_field    => $fromFieldName,
                to_field      => $toFieldName,
                regex         => $regex,
                field_numbers => $field_numbers,
                action        => 'copy',
            }
        );
102
    } else {
103
104
105
106
107
108
109
110
111
112
113
        _copy_move_subfield(
            {   record        => $record,
                from_field    => $fromFieldName,
                from_subfield => $fromSubfieldName,
                to_field      => $toFieldName,
                to_subfield   => $toSubfieldName,
                regex         => $regex,
                field_numbers => $field_numbers,
                action        => 'copy',
            }
        );
114
    }
115
}
116

117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
sub copy_and_replace_field {
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fromFieldName = $params->{from_field};
    my $fromSubfieldName = $params->{from_subfield};
    my $toFieldName = $params->{to_field};
    my $toSubfieldName = $params->{to_subfield};
    my $regex = $params->{regex};
    my $field_numbers = $params->{field_numbers} // [];

    if ( ! ( $record && $fromFieldName && $toFieldName ) ) { return; }


    if ( not $fromSubfieldName or $fromSubfieldName eq ''
      or not $toSubfieldName or $toSubfieldName eq ''
    ) {
        _copy_move_field(
            {   record        => $record,
                from_field    => $fromFieldName,
                to_field      => $toFieldName,
                regex         => $regex,
                field_numbers => $field_numbers,
                action        => 'replace',
            }
        );
    } else {
        _copy_move_subfield(
            {   record        => $record,
                from_field    => $fromFieldName,
                from_subfield => $fromSubfieldName,
                to_field      => $toFieldName,
                to_subfield   => $toSubfieldName,
                regex         => $regex,
                field_numbers => $field_numbers,
                action        => 'replace',
            }
        );
    }
}

157
sub update_field {
158
159
160
161
162
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fieldName = $params->{field};
    my $subfieldName = $params->{subfield};
    my @values = @{ $params->{values} };
163
    my $field_numbers = $params->{field_numbers} // [];
164
165
166
167
168
169
170
171

    if ( ! ( $record && $fieldName ) ) { return; }

    if ( not $subfieldName or $subfieldName eq '' ) {
        # FIXME I'm not sure the actual implementation is correct.
        die "This action is not implemented yet";
        #_update_field({ record => $record, field => $fieldName, values => \@values });
    } else {
172
        _update_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, values => \@values, field_numbers => $field_numbers });
173
174
    }
}
175

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
=head2 add_field

  add_field({
      record   => $record,
      field    => $fieldName,
      subfield => $subfieldName,
      values   => \@values,
      field_numbers => $field_numbers,
  });

  Adds a new field/subfield with supplied value(s).
  This function always add a new field as opposed to 'update_field' which will
  either update if field exists and add if it does not.

=cut


sub add_field {
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fieldName = $params->{field};
    my $subfieldName = $params->{subfield};
    my @values = @{ $params->{values} };
    my $field_numbers = $params->{field_numbers} // [];

    if ( ! ( $record && $fieldName ) ) { return; }
    if ( $fieldName > 10 ) {
        foreach my $value ( @values ) {
            my $field = MARC::Field->new( $fieldName, '', '', "$subfieldName" => $value );
            $record->append_fields( $field );
        }
    } else {
        foreach my $value ( @values ) {
            my $field = MARC::Field->new( $fieldName, $value );
            $record->append_fields( $field );
        }
    }
}

215
216
217
218
219
sub _update_field {
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fieldName = $params->{field};
    my @values = @{ $params->{values} };
220

221
    my $i = 0;
222
    if ( my @fields = $record->field( $fieldName ) ) {
223
        @values = ($values[0]) x scalar( @fields )
224
            if @values == 1;
225
        foreach my $field ( @fields ) {
226
            $field->update( $values[$i++] );
227
        }
228
    } else {
229
230
231
232
233
234
235
236
237
        ## Field does not exists, create it
        if ( $fieldName < 10 ) {
            foreach my $value ( @values ) {
                my $field = MARC::Field->new( $fieldName, $value );
                $record->append_fields( $field );
            }
        } else {
            warn "Invalid operation, trying to add a new field without subfield";
        }
238
    }
239
240
241
242
243
244
245
246
247
}

sub _update_subfield {
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fieldName = $params->{field};
    my $subfieldName = $params->{subfield};
    my @values = @{ $params->{values} };
    my $dont_erase = $params->{dont_erase};
248
    my $field_numbers = $params->{field_numbers} // [];
249
250
    my $i = 0;

251
252
253
254
255
256
257
    my @fields = $record->field( $fieldName );

    if ( @$field_numbers ) {
        @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
    }

    if ( @fields ) {
258
259
260
261
262
263
264
265
266
267
268
269
270
271
        unless ( $dont_erase ) {
            @values = ($values[0]) x scalar( @fields )
                if @values == 1;
            foreach my $field ( @fields ) {
                $field->update( "$subfieldName" => $values[$i++] );
            }
        }
        if ( $i <= scalar ( @values ) - 1 ) {
            foreach my $field ( @fields ) {
                foreach my $j ( $i .. scalar( @values ) - 1) {
                    $field->add_subfields( "$subfieldName" => $values[$j] );
                }
            }
        }
272
    } else {
273
274
275
276
277
        ## Field does not exist, create it.
        foreach my $value ( @values ) {
            my $field = MARC::Field->new( $fieldName, '', '', "$subfieldName" => $values[$i++] );
            $record->append_fields( $field );
        }
278
279
280
    }
}

281
=head2 read_field
282
283
284
285
286
287
288
289
290
291
292

  my @values = read_field( $record, $fieldName[, $subfieldName, [, $n ] ] );

  Returns an array of field values for the given field and subfield

  If $n is given, it will return only the $nth value of the array.
  E.g. If $n = 1, it return the 1st value, if $n = 3, it will return the 3rd value.

=cut

sub read_field {
293
294
295
296
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fieldName = $params->{field};
    my $subfieldName = $params->{subfield};
297
    my $field_numbers = $params->{field_numbers} // [];
298
299

    if ( not $subfieldName or $subfieldName eq '' ) {
300
        _read_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
301
    } else {
302
        _read_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
303
304
    }
}
305

306
307
308
309
sub _read_field {
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fieldName = $params->{field};
310
    my $field_numbers = $params->{field_numbers} // [];
311

312
    my @fields = $record->field( $fieldName );
313

314
    return unless @fields;
315

316
317
318
319
    return map { $_->data() } @fields
        if $fieldName < 10;

    my @values;
320
321
322
323
324
325
    if ( @$field_numbers ) {
        for my $field_number ( @$field_numbers ) {
            if ( $field_number <= scalar( @fields ) ) {
                for my $sf ( $fields[$field_number - 1]->subfields ) {
                    push @values, $sf->[1];
                }
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
            }
        }
    } else {
        foreach my $field ( @fields ) {
            for my $sf ( $field->subfields ) {
                push @values, $sf->[1];
            }
        }
    }

    return @values;
}

sub _read_subfield {
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fieldName = $params->{field};
    my $subfieldName = $params->{subfield};
344
    my $field_numbers = $params->{field_numbers} // [];
345
346
347
348
349
350
351
352
353
354
355

    my @fields = $record->field( $fieldName );

    return unless @fields;

    my @values;
    foreach my $field ( @fields ) {
        my @sf = $field->subfield( $subfieldName );
        push( @values, @sf );
    }

356
357
358
359
360
    if ( @values and @$field_numbers ) {
        @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
    }

    return @values;
361
362
}

363
=head2 field_exists
364

365
  @field_numbers = field_exists( $record, $fieldName[, $subfieldName ]);
366

367
  Returns the field numbers or an empty array.
368
369
370
371

=cut

sub field_exists {
372
373
374
375
  my ( $params ) = @_;
  my $record = $params->{record};
  my $fieldName = $params->{field};
  my $subfieldName = $params->{subfield};
376
377
378

  if ( ! $record ) { return; }

379
380
381
382
383
384
385
386
387
388
  my @field_numbers = ();
  my $current_field_number = 1;
  for my $field ( $record->field( $fieldName ) ) {
    if ( $subfieldName ) {
      push @field_numbers, $current_field_number
        if $field->subfield( $subfieldName );
    } else {
      push @field_numbers, $current_field_number;
    }
    $current_field_number++;
389
390
  }

391
  return \@field_numbers;
392
393
}

394
=head2 field_equals
395

396
  $bool = field_equals( $record, $value, $fieldName[, $subfieldName[, $regex ] ]);
397
398
399
400

  Returns true if the field equals the given value, false otherwise.

  If a regular expression ( $regex ) is supplied, the value will be compared using
401
  the given regex. Example: $regex = 'sought_text'
402
403
404
405

=cut

sub field_equals {
406
407
408
409
410
  my ( $params ) = @_;
  my $record = $params->{record};
  my $value = $params->{value};
  my $fieldName = $params->{field};
  my $subfieldName = $params->{subfield};
joubu's avatar
joubu committed
411
  my $is_regex = $params->{is_regex};
412
413
414

  if ( ! $record ) { return; }

415
416
417
418
419
420
421
422
423
424
  my @field_numbers = ();
  my $current_field_number = 1;
  FIELDS: for my $field ( $record->field( $fieldName ) ) {
    my @subfield_values = $subfieldName
        ? $field->subfield( $subfieldName )
        : map { $_->[1] } $field->subfields;

    SUBFIELDS: for my $subfield_value ( @subfield_values ) {
      if (
          (
joubu's avatar
joubu committed
425
              $is_regex and $subfield_value =~ m/$value/
426
427
428
429
430
431
432
433
434
          ) or (
              $subfield_value eq $value
          )
      ) {
          push @field_numbers, $current_field_number;
          last SUBFIELDS;
      }
    }
    $current_field_number++;
435
  }
436
437

  return \@field_numbers;
438
439
}

440
=head2 move_field
441
442
443
444
445
446
447
448
449
450
451
452
453

  move_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex [, $n ] ] );

  Moves a value from one field to another. If a regular expression ( $regex ) is supplied,
  the value will be transformed by the given regex before being moved into the new field.
  Example: $regex = 's/Old Text/Replacement Text/'

  If $n is passed, only the Nth field will be moved. $n = 1
  will move the first repeatable field, $n = 3 will move the third.

=cut

sub move_field {
454
455
456
457
458
459
460
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fromFieldName = $params->{from_field};
    my $fromSubfieldName = $params->{from_subfield};
    my $toFieldName = $params->{to_field};
    my $toSubfieldName = $params->{to_subfield};
    my $regex = $params->{regex};
461
    my $field_numbers = $params->{field_numbers} // [];
462

463
464
465
466
467
468
469
470
471
472
473
474
475
    if (   not $fromSubfieldName
        or $fromSubfieldName eq ''
        or not $toSubfieldName
        or $toSubfieldName eq '' ) {
        _copy_move_field(
            {   record        => $record,
                from_field    => $fromFieldName,
                to_field      => $toFieldName,
                regex         => $regex,
                field_numbers => $field_numbers,
                action        => 'move',
            }
        );
476
    } else {
477
478
479
480
481
482
483
484
485
486
487
        _copy_move_subfield(
            {   record        => $record,
                from_field    => $fromFieldName,
                from_subfield => $fromSubfieldName,
                to_field      => $toFieldName,
                to_subfield   => $toSubfieldName,
                regex         => $regex,
                field_numbers => $field_numbers,
                action        => 'move',
            }
        );
488
489
    }
}
490

491
=head2 _delete_field
492

493
  _delete_field( $record, $fieldName[, $subfieldName [, $n ] ] );
494
495
496
497
498
499
500
501
502

  Deletes the given field.

  If $n is passed, only the Nth field will be deleted. $n = 1
  will delete the first repeatable field, $n = 3 will delete the third.

=cut

sub delete_field {
503
504
505
506
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fieldName = $params->{field};
    my $subfieldName = $params->{subfield};
507
    my $field_numbers = $params->{field_numbers} // [];
508
509

    if ( not $subfieldName or $subfieldName eq '' ) {
510
        _delete_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
511
    } else {
512
        _delete_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
513
514
    }
}
515

516
517
518
519
sub _delete_field {
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fieldName = $params->{field};
520
    my $field_numbers = $params->{field_numbers} // [];
521

522
    my @fields = $record->field( $fieldName );
523

524
525
526
    if ( @$field_numbers ) {
        @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
    }
527
    foreach my $field ( @fields ) {
528
        $record->delete_field( $field );
529
    }
530
531
532
533
534
535
536
}

sub _delete_subfield {
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fieldName = $params->{field};
    my $subfieldName = $params->{subfield};
537
    my $field_numbers = $params->{field_numbers} // [];
538
539
540

    my @fields = $record->field( $fieldName );

541
542
543
    if ( @$field_numbers ) {
        @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
    }
544

545
    foreach my $field ( @fields ) {
546
        $field->delete_subfield( code => $subfieldName );
547
548
549
    }
}

550
551
552
553
554
555
556

sub _copy_move_field {
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fromFieldName = $params->{from_field};
    my $toFieldName = $params->{to_field};
    my $regex = $params->{regex};
joubu's avatar
joubu committed
557
    my $field_numbers = $params->{field_numbers} // [];
558
559
    my $action = $params->{action} || 'copy';

560
    my @from_fields = $record->field( $fromFieldName );
561
    if ( @$field_numbers ) {
562
        @from_fields = map { $_ <= @from_fields ? $from_fields[ $_ - 1 ] : () } @$field_numbers;
563
564
    }

565
566
567
    my @new_fields;
    for my $from_field ( @from_fields ) {
        my $new_field = $from_field->clone;
568
569
570
571
572
573
574
575
        $new_field->{_tag} = $toFieldName; # Should be replaced by set_tag, introduced by MARC::Field 2.0.4
        if ( $regex and $regex->{search} ) {
            for my $subfield ( $new_field->subfields ) {
                my $value = $subfield->[1];
                ( $value ) = _modify_values({ values => [ $value ], regex => $regex });
                $new_field->update( $subfield->[0], $value );
            }
        }
576
577
578
579
580
581
582
583
584
585
        if ( $action eq 'move' ) {
            $record->delete_field( $from_field )
        }
        elsif ( $action eq 'replace' ) {
            my @to_fields = $record->field( $toFieldName );
            if ( @to_fields ) {
                $record->delete_field( $to_fields[0] );
            }
        }
        push @new_fields, $new_field;
586
    }
587
    $record->append_fields( @new_fields );
588
589
}

590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
sub _copy_move_subfield {
    my ( $params ) = @_;
    my $record = $params->{record};
    my $fromFieldName = $params->{from_field};
    my $fromSubfieldName = $params->{from_subfield};
    my $toFieldName = $params->{to_field};
    my $toSubfieldName = $params->{to_subfield};
    my $regex = $params->{regex};
    my $field_numbers = $params->{field_numbers} // [];
    my $action = $params->{action} || 'copy';

    my @values = read_field({ record => $record, field => $fromFieldName, subfield => $fromSubfieldName });
    if ( @$field_numbers ) {
        @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
    }
    _modify_values({ values => \@values, regex => $regex });
    my $dont_erase = $action eq 'copy' ? 1 : 0;
    _update_subfield({ record => $record, field => $toFieldName, subfield => $toSubfieldName, values => \@values, dont_erase => $dont_erase });

    # And delete if it's a move
    if ( $action eq 'move' ) {
        _delete_subfield({
            record => $record,
            field => $fromFieldName,
            subfield => $fromSubfieldName,
            field_numbers => $field_numbers,
        });
    }
}

620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
sub _modify_values {
    my ( $params ) = @_;
    my $values = $params->{values};
    my $regex = $params->{regex};

    if ( $regex and $regex->{search} ) {
        $regex->{modifiers} //= q||;
        my @available_modifiers = qw( i g );
        my $modifiers = q||;
        for my $modifier ( split //, $regex->{modifiers} ) {
            $modifiers .= $modifier
                if grep {/$modifier/} @available_modifiers;
        }
        foreach my $value ( @$values ) {
            if ( $modifiers =~ m/^(ig|gi)$/ ) {
                $value =~ s/$regex->{search}/$regex->{replace}/ig;
            }
            elsif ( $modifiers eq 'i' ) {
                $value =~ s/$regex->{search}/$regex->{replace}/i;
            }
            elsif ( $modifiers eq 'g' ) {
                $value =~ s/$regex->{search}/$regex->{replace}/g;
            }
            else {
                $value =~ s/$regex->{search}/$regex->{replace}/;
            }
        }
    }
    return @$values;
}
650
651
1;
__END__