# Copyright 2009 Kyle M. Hall <kyle.m.hall@gmail.com>
-use strict;
-use warnings;
+use Modern::Perl;
#use MARC::Record;
read_field
update_field
copy_field
+ copy_and_replace_field
move_field
delete_field
field_exists
field_equals
);
-our $VERSION = '0.01';
our $debug = 0;
=head1 NAME
-SimpleMARC - Perl modle for making simple MARC record alterations.
+SimpleMARC - Perl module for making simple MARC record alterations.
=head1 SYNOPSIS
=head1 FUNCTIONS
-=head2
+=head2 copy_field
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.
- Example: $regex = 's/Old Text/Replacement Text/'
+ Example: $regex = { search => 'Old Text', replace => 'Replacement Text', modifiers => 'g' };
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 {
- my ( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName, $regex, $n, $dont_erase ) = @_;
- C4::Koha::Log( "C4::SimpleMARC::copy_field( '$record', '$fromFieldName', '$fromSubfieldName', '$toFieldName', '$toSubfieldName', '$regex', '$n' )" ) if $debug;
-
- if ( ! ( $record && $fromFieldName && $toFieldName ) ) { return; }
-
- my @values = read_field( $record, $fromFieldName, $fromSubfieldName );
- @values = ( $values[$n-1] ) if ( $n );
- C4::Koha::Log( "@values = read_field( $record, $fromFieldName, $fromSubfieldName )" ) if $debug >= 3;
-
- if ( $regex ) {
- foreach my $value ( @values ) {
- C4::Koha::Log( "\$value =~ s$regex" ) if ( $debug >= 3 );
- eval "\$value =~ s$regex";
+ 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 => 'copy',
+ }
+ );
+ } 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 => 'copy',
+ }
+ );
}
- }
-
- update_field( $record, $toFieldName, $toSubfieldName, @values, $dont_erase );
-
}
-=head2
-
- update_field( $record, $fieldName, $subfieldName, $value[, $value,[ $value ... ] ] );
-
- Updates a field with the given value, creating it if neccessary.
-
- If multiple values are supplied, they will be used to update a list of repeatable fields
- until either the fields or the values are all used.
-
- If a single value is supplied for a repeated field, that value will be used to update
- each of the repeated fields.
-
-=cut
+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',
+ }
+ );
+ }
+}
sub update_field {
- my ( $record, $fieldName, $subfieldName, @values, $dont_erase ) = @_;
- C4::Koha::Log( "C4::SimpleMARC::update_field( $record, $fieldName, $subfieldName, @values )" ) if $debug;
-
- if ( ! ( $record && $fieldName ) ) { return; }
+ 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 ( 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 {
+ _update_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, values => \@values, field_numbers => $field_numbers });
+ }
+}
- if ( @values eq 1 ) {
- _update_repeatable_field_with_single_value( $record, $fieldName, $subfieldName, @values );
- return;
- }
+sub _update_field {
+ my ( $params ) = @_;
+ my $record = $params->{record};
+ my $fieldName = $params->{field};
+ my @values = @{ $params->{values} };
- my $i = 0;
- my $field;
- if ( $subfieldName ) {
+ my $i = 0;
if ( my @fields = $record->field( $fieldName ) ) {
- unless ( $dont_erase ) {
- foreach my $field ( @fields ) {
- $field->update( "$subfieldName" => $values[$i++] );
- }
- }
- if ( $i <= scalar @values - 1 ) {
+ @values = ($values[0]) x scalar( @fields )
+ if @values == 1;
foreach my $field ( @fields ) {
- foreach my $j ( $i .. scalar( @values ) - 1) {
- $field->add_subfields( "$subfieldName" => $values[$j] );
- }
+ $field->update( $values[$i++] );
}
- }
} else {
- ## Field does not exist, create it.
- foreach my $value ( @values ) {
- $field = MARC::Field->new( $fieldName, '', '', "$subfieldName" => $values[$i++] );
- $record->append_fields( $field );
- }
+ ## 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";
+ }
}
- } else { ## No subfield
- if ( my @fields = $record->field( $fieldName ) ) {
- foreach my $field ( @fields ) {
- $field->update( $values[$i++] );
- }
+}
+
+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};
+ my $field_numbers = $params->{field_numbers} // [];
+ my $i = 0;
+
+ my @fields = $record->field( $fieldName );
+
+ if ( @$field_numbers ) {
+ @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
+ }
+
+ if ( @fields ) {
+ 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] );
+ }
+ }
+ }
} else {
- ## Field does not exists, create it
- foreach my $value ( @values ) {
- $field = MARC::Field->new( $fieldName, $value );
- $record->append_fields( $field );
- }
+ ## Field does not exist, create it.
+ foreach my $value ( @values ) {
+ my $field = MARC::Field->new( $fieldName, '', '', "$subfieldName" => $values[$i++] );
+ $record->append_fields( $field );
+ }
}
- }
}
-=head2
+=head2 read_field
my @values = read_field( $record, $fieldName[, $subfieldName, [, $n ] ] );
=cut
sub read_field {
- my ( $record, $fieldName, $subfieldName, $n ) = @_;
- C4::Koha::Log( "C4::SimpleMARC::read_field( '$record', '$fieldName', '$subfieldName', '$n' )" ) if $debug;
+ my ( $params ) = @_;
+ my $record = $params->{record};
+ my $fieldName = $params->{field};
+ my $subfieldName = $params->{subfield};
+ my $field_numbers = $params->{field_numbers} // [];
+
+ if ( not $subfieldName or $subfieldName eq '' ) {
+ _read_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
+ } else {
+ _read_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
+ }
+}
- my @fields = $record->field( $fieldName );
+sub _read_field {
+ my ( $params ) = @_;
+ my $record = $params->{record};
+ my $fieldName = $params->{field};
+ my $field_numbers = $params->{field_numbers} // [];
- return @fields unless $subfieldName;
+ my @fields = $record->field( $fieldName );
- my @subfields;
- foreach my $field ( @fields ) {
- my @sf = $field->subfield( $subfieldName );
- push( @subfields, @sf );
- }
+ return unless @fields;
- if ( $n ) {
- return $subfields[$n-1];
- } else {
- return @subfields;
- }
+ return map { $_->data() } @fields
+ if $fieldName < 10;
+
+ my @values;
+ 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];
+ }
+ }
+ }
+ } 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};
+ my $field_numbers = $params->{field_numbers} // [];
+
+ my @fields = $record->field( $fieldName );
+
+ return unless @fields;
+
+ my @values;
+ foreach my $field ( @fields ) {
+ my @sf = $field->subfield( $subfieldName );
+ push( @values, @sf );
+ }
+
+ if ( @values and @$field_numbers ) {
+ @values = map { $_ <= @values ? $values[ $_ - 1 ] : () } @$field_numbers;
+ }
+
+ return @values;
}
-=head2
+=head2 field_exists
- $bool = field_exists( $record, $fieldName[, $subfieldName ]);
+ @field_numbers = field_exists( $record, $fieldName[, $subfieldName ]);
- Returns true if the field exits, false otherwise.
+ Returns the field numbers or an empty array.
=cut
sub field_exists {
- my ( $record, $fieldName, $subfieldName ) = @_;
- C4::Koha::Log( "C4::SimpleMARC::field_exists( $record, $fieldName, $subfieldName )" ) if $debug;
+ my ( $params ) = @_;
+ my $record = $params->{record};
+ my $fieldName = $params->{field};
+ my $subfieldName = $params->{subfield};
if ( ! $record ) { return; }
- my $return = 0;
- if ( $fieldName && $subfieldName ) {
- $return = $record->field( $fieldName ) && $record->subfield( $fieldName, $subfieldName );
- } elsif ( $fieldName ) {
- $return = $record->field( $fieldName ) && 1;
+ 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++;
}
- C4::Koha::Log( "C4:SimpleMARC::field_exists: Returning '$return'" ) if $debug >= 2;
- return $return;
+ return \@field_numbers;
}
-=head2
+=head2 field_equals
- $bool = field_equals( $record, $value, $fieldName[, $subfieldName[, $regex [, $n ] ] ]);
+ $bool = field_equals( $record, $value, $fieldName[, $subfieldName[, $regex ] ]);
Returns true if the field equals the given value, false otherwise.
If a regular expression ( $regex ) is supplied, the value will be compared using
- the given regex. Example: $regex = 'm/sought_text/'
-
- If $n is passed, the Nth field of a repeatable series will be used for comparison.
- Set $n to 1 or leave empty for a non-repeatable field.
+ the given regex. Example: $regex = 'sought_text'
=cut
sub field_equals {
- my ( $record, $value, $fieldName, $subfieldName, $regex, $n ) = @_;
- $n = 1 unless ( $n ); ## $n defaults to first field of a repeatable field series
- C4::Koha::Log( "C4::SimpleMARC::field_equals( '$record', '$value', '$fieldName', '$subfieldName', '$regex', '$n')" ) if $debug;
+ my ( $params ) = @_;
+ my $record = $params->{record};
+ my $value = $params->{value};
+ my $fieldName = $params->{field};
+ my $subfieldName = $params->{subfield};
+ my $is_regex = $params->{is_regex};
if ( ! $record ) { return; }
- my @field_values = read_field( $record, $fieldName, $subfieldName, $n );
- my $field_value = $field_values[$n-1];
-
- if ( $regex ) {
- C4::Koha::Log( "Testing '$field_value' =~ m$value" ) if $debug >= 3;
- return eval "\$field_value =~ m$value";
- } else {
- return $field_value eq $value;
+ 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 (
+ (
+ $is_regex and $subfield_value =~ m/$value/
+ ) or (
+ $subfield_value eq $value
+ )
+ ) {
+ push @field_numbers, $current_field_number;
+ last SUBFIELDS;
+ }
+ }
+ $current_field_number++;
}
+
+ return \@field_numbers;
}
-=head2
+=head2 move_field
move_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName[, $regex [, $n ] ] );
=cut
sub move_field {
- my ( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName, $regex, $n ) = @_;
- C4::Koha::Log( "C4::SimpleMARC::move_field( '$record', '$fromFieldName', '$fromSubfieldName', '$toFieldName', '$toSubfieldName', '$regex', '$n' )" ) if $debug;
- copy_field( $record, $fromFieldName, $fromSubfieldName, $toFieldName, $toSubfieldName, $regex, $n , "don't_erase");
- delete_field( $record, $fromFieldName, $fromSubfieldName, $n );
+ 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 ( 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',
+ }
+ );
+ } 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 => 'move',
+ }
+ );
+ }
}
-=head2
+=head2 _delete_field
- delete_field( $record, $fieldName[, $subfieldName [, $n ] ] );
+ _delete_field( $record, $fieldName[, $subfieldName [, $n ] ] );
Deletes the given field.
=cut
sub delete_field {
- my ( $record, $fieldName, $subfieldName, $n ) = @_;
- C4::Koha::Log( "C4::SimpleMARC::delete_field( '$record', '$fieldName', '$subfieldName', '$n' )" ) if $debug;
+ my ( $params ) = @_;
+ my $record = $params->{record};
+ my $fieldName = $params->{field};
+ my $subfieldName = $params->{subfield};
+ my $field_numbers = $params->{field_numbers} // [];
+
+ if ( not $subfieldName or $subfieldName eq '' ) {
+ _delete_field({ record => $record, field => $fieldName, field_numbers => $field_numbers });
+ } else {
+ _delete_subfield({ record => $record, field => $fieldName, subfield => $subfieldName, field_numbers => $field_numbers });
+ }
+}
- my @fields = $record->field( $fieldName );
+sub _delete_field {
+ my ( $params ) = @_;
+ my $record = $params->{record};
+ my $fieldName = $params->{field};
+ my $field_numbers = $params->{field_numbers} // [];
- @fields = ( $fields[$n-1] ) if ( $n );
+ my @fields = $record->field( $fieldName );
- if ( @fields && !$subfieldName ) {
- foreach my $field ( @fields ) {
- $record->delete_field( $field );
+ if ( @$field_numbers ) {
+ @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
}
- } elsif ( @fields && $subfieldName ) {
foreach my $field ( @fields ) {
- $field->delete_subfield( code => $subfieldName );
+ $record->delete_field( $field );
}
- }
}
-=head2
+sub _delete_subfield {
+ my ( $params ) = @_;
+ my $record = $params->{record};
+ my $fieldName = $params->{field};
+ my $subfieldName = $params->{subfield};
+ my $field_numbers = $params->{field_numbers} // [];
- _update_repeatable_field_with_single_value( $record, $fieldName, $subfieldName, $value );
+ my @fields = $record->field( $fieldName );
- Updates a repeatable field, giving all existing copies of that field the given value.
+ if ( @$field_numbers ) {
+ @fields = map { $_ <= @fields ? $fields[ $_ - 1 ] : () } @$field_numbers;
+ }
- This is an internal function, and thus is not exported.
+ foreach my $field ( @fields ) {
+ $field->delete_subfield( code => $subfieldName );
+ }
+}
-=cut
-sub _update_repeatable_field_with_single_value {
- my ( $record, $fieldName, $subfieldName, $value ) = @_;
- C4::Koha::Log( "C4::SimpleMARC::_update_repeatable_field_with_single_value( $record, $fieldName, $subfieldName, $value )" ) if $debug;
+sub _copy_move_field {
+ my ( $params ) = @_;
+ my $record = $params->{record};
+ my $fromFieldName = $params->{from_field};
+ my $toFieldName = $params->{to_field};
+ my $regex = $params->{regex};
+ my $field_numbers = $params->{field_numbers} // [];
+ my $action = $params->{action} || 'copy';
- if ( ! ( $record && $fieldName ) ) { return; }
+ my @from_fields = $record->field( $fromFieldName );
+ if ( @$field_numbers ) {
+ @from_fields = map { $_ <= @from_fields ? $from_fields[ $_ - 1 ] : () } @$field_numbers;
+ }
- my $field;
- if ( $subfieldName ) {
- if ( my @fields = $record->field( $fieldName ) ) {
- foreach my $field ( @fields ) {
- $field->update( "$subfieldName" => $value );
- }
- } else {
- ## Field does not exist, create it.
- $field = MARC::Field->new( $fieldName, '', '', "$subfieldName" => $value );
- $record->append_fields( $field );
+ my @new_fields;
+ for my $from_field ( @from_fields ) {
+ my $new_field = $from_field->clone;
+ $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 );
+ }
+ }
+ 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;
}
- } else { ## No subfield
- if ( my @fields = $record->field( $fieldName ) ) {
- foreach my $field ( @fields ) {
- $field->update( $value );
- }
- } else {
- ## Field does not exists, create it
- $field = MARC::Field->new( $fieldName, $value );
- $record->append_fields( $field );
+ $record->append_fields( @new_fields );
+}
+
+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,
+ });
}
- }
}
+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;
+}
1;
__END__