Bug 15288: (followup) Better wording for OPAC error page
[koha.git] / Koha / SimpleMARC.pm
blob04ff8f9a86a36b7e13f2848ccdf7ee168ef69118
1 package Koha::SimpleMARC;
3 # Copyright 2009 Kyle M. Hall <kyle.m.hall@gmail.com>
5 use Modern::Perl;
7 #use MARC::Record;
9 require Exporter;
11 our @ISA = qw(Exporter);
12 our %EXPORT_TAGS = ( 'all' => [ qw(
14 ) ] );
16 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
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
29 our $VERSION = '0.01';
31 our $debug = 0;
33 =head1 NAME
35 SimpleMARC - Perl module for making simple MARC record alterations.
37 =head1 SYNOPSIS
39 use SimpleMARC;
41 =head1 DESCRIPTION
43 SimpleMARC is designed to make writing scripts
44 to modify MARC records simple and easy.
46 Every function in the modules requires a
47 MARC::Record object as its first parameter.
49 =head1 AUTHOR
51 Kyle Hall <lt>kyle.m.hall@gmail.com<gt>
53 =head1 COPYRIGHT AND LICENSE
55 Copyright (C) 2009 by Kyle Hall
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.
61 =head1 FUNCTIONS
63 =head2 copy_field
65 copy_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex[, $n ] ] );
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' };
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.
74 =cut
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} // [];
86 if ( ! ( $record && $fromFieldName && $toFieldName ) ) { return; }
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',
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',
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} // [];
127 if ( ! ( $record && $fromFieldName && $toFieldName ) ) { return; }
130 if ( not $fromSubfieldName or $fromSubfieldName eq ''
131 or not $toSubfieldName or $toSubfieldName eq ''
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',
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',
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} // [];
165 if ( ! ( $record && $fieldName ) ) { return; }
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 });
176 sub _update_field {
177 my ( $params ) = @_;
178 my $record = $params->{record};
179 my $fieldName = $params->{field};
180 my @values = @{ $params->{values} };
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++] );
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 );
196 } else {
197 warn "Invalid operation, trying to add a new field without subfield";
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;
212 my @fields = $record->field( $fieldName );
214 if ( @$field_numbers ) {
215 @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
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++] );
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] );
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 );
242 =head2 read_field
244 my @values = read_field( $record, $fieldName[, $subfieldName, [, $n ] ] );
246 Returns an array of field values for the given field and subfield
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.
251 =cut
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} // [];
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 });
267 sub _read_field {
268 my ( $params ) = @_;
269 my $record = $params->{record};
270 my $fieldName = $params->{field};
271 my $field_numbers = $params->{field_numbers} // [];
273 my @fields = $record->field( $fieldName );
275 return unless @fields;
277 return map { $_->data() } @fields
278 if $fieldName < 10;
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];
289 } else {
290 foreach my $field ( @fields ) {
291 for my $sf ( $field->subfields ) {
292 push @values, $sf->[1];
297 return @values;
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} // [];
307 my @fields = $record->field( $fieldName );
309 return unless @fields;
311 my @values;
312 foreach my $field ( @fields ) {
313 my @sf = $field->subfield( $subfieldName );
314 push( @values, @sf );
317 if ( @values and @$field_numbers ) {
318 @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
321 return @values;
324 =head2 field_exists
326 @field_numbers = field_exists( $record, $fieldName[, $subfieldName ]);
328 Returns the field numbers or an empty array.
330 =cut
332 sub field_exists {
333 my ( $params ) = @_;
334 my $record = $params->{record};
335 my $fieldName = $params->{field};
336 my $subfieldName = $params->{subfield};
338 if ( ! $record ) { return; }
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;
349 $current_field_number++;
352 return \@field_numbers;
355 =head2 field_equals
357 $bool = field_equals( $record, $value, $fieldName[, $subfieldName[, $regex ] ]);
359 Returns true if the field equals the given value, false otherwise.
361 If a regular expression ( $regex ) is supplied, the value will be compared using
362 the given regex. Example: $regex = 'sought_text'
364 =cut
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};
374 if ( ! $record ) { return; }
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;
383 SUBFIELDS: for my $subfield_value ( @subfield_values ) {
384 if (
386 $is_regex and $subfield_value =~ m/$value/
387 ) or (
388 $subfield_value eq $value
391 push @field_numbers, $current_field_number;
392 last SUBFIELDS;
395 $current_field_number++;
398 return \@field_numbers;
401 =head2 move_field
403 move_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex [, $n ] ] );
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/'
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.
412 =cut
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} // [];
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',
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',
452 =head2 _delete_field
454 _delete_field( $record, $fieldName[, $subfieldName [, $n ] ] );
456 Deletes the given field.
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.
461 =cut
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} // [];
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 });
477 sub _delete_field {
478 my ( $params ) = @_;
479 my $record = $params->{record};
480 my $fieldName = $params->{field};
481 my $field_numbers = $params->{field_numbers} // [];
483 my @fields = $record->field( $fieldName );
485 if ( @$field_numbers ) {
486 @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
488 foreach my $field ( @fields ) {
489 $record->delete_field( $field );
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} // [];
500 my @fields = $record->field( $fieldName );
502 if ( @$field_numbers ) {
503 @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
506 foreach my $field ( @fields ) {
507 $field->delete_subfield( code => $subfieldName );
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';
521 my @from_fields = $record->field( $fromFieldName );
522 if ( @$field_numbers ) {
523 @from_fields = map { $_ <= @from_fields ? $from_fields[ $_ - 1 ] : () } @$field_numbers;
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 );
537 if ( $action eq 'move' ) {
538 $record->delete_field( $from_field )
540 elsif ( $action eq 'replace' ) {
541 my @to_fields = $record->field( $toFieldName );
542 if ( @to_fields ) {
543 $record->delete_field( $to_fields[0] );
546 push @new_fields, $new_field;
548 $record->append_fields( @new_fields );
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';
562 my @values = read_field({ record => $record, field => $fromFieldName, subfield => $fromSubfieldName });
563 if ( @$field_numbers ) {
564 @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
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 });
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,
581 sub _modify_values {
582 my ( $params ) = @_;
583 my $values = $params->{values};
584 my $regex = $params->{regex};
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;
594 foreach my $value ( @$values ) {
595 if ( $modifiers =~ m/^(ig|gi)$/ ) {
596 $value =~ s/$regex->{search}/$regex->{replace}/ig;
598 elsif ( $modifiers eq 'i' ) {
599 $value =~ s/$regex->{search}/$regex->{replace}/i;
601 elsif ( $modifiers eq 'g' ) {
602 $value =~ s/$regex->{search}/$regex->{replace}/g;
604 else {
605 $value =~ s/$regex->{search}/$regex->{replace}/;
609 return @$values;
612 __END__