467 lines
15 KiB
Perl
467 lines
15 KiB
Perl
package Koha::MarcOverlayRules;
|
|
|
|
# This file is part of Koha.
|
|
#
|
|
# Koha is free software; you can redistribute it and/or modify it
|
|
# under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 3 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# Koha is distributed in the hope that it will be useful, but
|
|
# WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with Koha; if not, see <http://www.gnu.org/licenses>.
|
|
|
|
use Modern::Perl;
|
|
use List::Util qw(first any);
|
|
use Koha::MarcOverlayRule;
|
|
use Carp;
|
|
|
|
use Koha::Exceptions::MarcOverlayRule;
|
|
use Try::Tiny;
|
|
use Scalar::Util qw(looks_like_number);
|
|
use Clone qw(clone);
|
|
|
|
use parent qw(Koha::Objects);
|
|
|
|
my $cache = Koha::Caches->get_instance();
|
|
|
|
=head1 NAME
|
|
|
|
Koha::MarcOverlayRules - Koha MarcOverlayRules Object set class
|
|
|
|
=head1 API
|
|
|
|
=head2 Class methods
|
|
|
|
=head3 operations
|
|
|
|
Returns a list of all valid operations.
|
|
|
|
=cut
|
|
|
|
sub operations {
|
|
return ( 'add', 'append', 'remove', 'delete' );
|
|
}
|
|
|
|
=head3 modules
|
|
|
|
Returns a list of all modules in order of priority.
|
|
|
|
=cut
|
|
|
|
sub modules {
|
|
return ( 'userid', 'categorycode', 'source' );
|
|
}
|
|
|
|
=head3 context_rules
|
|
|
|
my $rules = Koha::MarcOverlayRules->context_rules($context);
|
|
|
|
Gets all MARC overlay rules for the supplied C<$context> (hashref with { module => filter, ... } values).
|
|
|
|
=cut
|
|
|
|
sub context_rules {
|
|
my ( $self, $context ) = @_;
|
|
|
|
return unless %{$context};
|
|
|
|
my $rules = $cache->get_from_cache( 'marc_overlay_rules', { unsafe => 1 } );
|
|
|
|
if ( !$rules ) {
|
|
$rules = {};
|
|
my @rules_rows = $self->_resultset()->search(
|
|
undef,
|
|
{ order_by => { -desc => [qw/id/] } }
|
|
);
|
|
foreach my $rule_row (@rules_rows) {
|
|
my %rule = $rule_row->get_columns();
|
|
my $operations = {};
|
|
|
|
foreach my $operation ( $self->operations ) {
|
|
$operations->{$operation} = { allow => $rule{$operation}, rule => $rule{id} };
|
|
}
|
|
|
|
# TODO: Remove unless check and validate on saving rules?
|
|
if ( $rule{tag} eq '*' ) {
|
|
unless ( exists $rules->{ $rule{module} }->{ $rule{filter} }->{'*'} ) {
|
|
$rules->{ $rule{module} }->{ $rule{filter} }->{'*'} = $operations;
|
|
}
|
|
} elsif ( $rule{tag} =~ /^(\d{3})$/ ) {
|
|
unless ( exists $rules->{ $rule{module} }->{ $rule{filter} }->{tags}->{ $rule{tag} } ) {
|
|
$rules->{ $rule{module} }->{ $rule{filter} }->{tags}->{ $rule{tag} } = $operations;
|
|
}
|
|
} else {
|
|
my $regexps = ( $rules->{ $rule{module} }->{ $rule{filter} }->{regexps} //= [] );
|
|
push @{$regexps}, [ $rule{tag}, $operations ];
|
|
}
|
|
}
|
|
$cache->set_in_cache( 'marc_overlay_rules', $rules );
|
|
}
|
|
|
|
my $context_rules;
|
|
my @context_modules = grep { exists $context->{$_} } $self->modules();
|
|
|
|
foreach my $module_name (@context_modules) {
|
|
if ( exists $rules->{$module_name}
|
|
&& exists $rules->{$module_name}->{ $context->{$module_name} } )
|
|
{
|
|
$context_rules = $rules->{$module_name}->{ $context->{$module_name} };
|
|
|
|
unless ( exists $rules->{$module_name}->{'*'} ) {
|
|
|
|
# No wildcard filter rules defined
|
|
last;
|
|
}
|
|
|
|
# Merge in all wildcard filter rules which has not been overridden
|
|
# by the matching context
|
|
if ( $context_rules->{'*'} ) {
|
|
|
|
# Wildcard tag for matching context will override all rules,
|
|
# nothing left to do
|
|
last;
|
|
}
|
|
|
|
# Clone since we will potentially be modified cached value
|
|
# fetched with unsafe => 1
|
|
$context_rules = clone($context_rules);
|
|
|
|
if ( exists $rules->{$module_name}->{'*'}->{'*'} ) {
|
|
|
|
# Merge in wildcard filter wildcard tag rule if exists
|
|
$context_rules->{'*'} = $rules->{$module_name}->{'*'}->{'*'};
|
|
}
|
|
|
|
if ( exists $rules->{$module_name}->{'*'}->{tags} ) {
|
|
if ( exists $context_rules->{regexps} ) {
|
|
|
|
# If the current context has regexp rules, we have to make sure
|
|
# to not only to skip tags already present but also those matching
|
|
# any of those rules
|
|
|
|
my @regexps = map { qr/^$_->[0]$/ } @{ $context_rules->{regexps} };
|
|
|
|
foreach my $tag ( keys %{ $rules->{$module_name}->{'*'}->{tags} } ) {
|
|
unless ( ( any { $tag =~ $_ } @regexps ) || exists $context_rules->{tags}->{$tag} ) {
|
|
$context_rules->{tags}->{$tag} = $rules->{$module_name}->{'*'}->{tags}->{$tag};
|
|
}
|
|
}
|
|
} else {
|
|
|
|
# Merge in wildcard filter tag rules not already present
|
|
# in the matching context
|
|
foreach my $tag ( keys %{ $rules->{$module_name}->{'*'}->{tags} } ) {
|
|
unless ( exists $context_rules->{tags}->{$tag} ) {
|
|
$context_rules->{tags}->{$tag} = $rules->{$module_name}->{'*'}->{tags}->{$tag};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( exists $rules->{$module_name}->{'*'}->{regexps} ) {
|
|
|
|
# Merge in wildcard filter regexp rules last, making sure rules from the
|
|
# matching context have precedence
|
|
$context_rules->{regexps} //= [];
|
|
push @{ $context_rules->{regexps} }, @{ $rules->{$module_name}->{'*'}->{regexps} };
|
|
}
|
|
|
|
last;
|
|
}
|
|
}
|
|
|
|
if ( !$context_rules ) {
|
|
|
|
# No rules matching specific context conditions found, try wildcard value for each active context
|
|
foreach my $module_name (@context_modules) {
|
|
if ( exists $rules->{$module_name}->{'*'} ) {
|
|
$context_rules = $rules->{$module_name}->{'*'};
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
return $context_rules;
|
|
}
|
|
|
|
=head3 merge_records
|
|
|
|
my $merged_record = Koha::MarcOverlayRules->merge_records($old_record, $incoming_record, $context);
|
|
|
|
Overlay C<$old_record> with C<$incoming_record> applying overlay rules for C<$context>.
|
|
Returns merged record C<$merged_record>. C<$old_record>, C<$incoming_record> and
|
|
C<$merged_record> are all MARC::Record objects.
|
|
|
|
=cut
|
|
|
|
sub merge_records {
|
|
my ( $self, $old_record, $incoming_record, $context ) = @_;
|
|
|
|
my $rules = $self->context_rules($context);
|
|
|
|
# Default when no rules found is to overwrite with incoming record
|
|
return $incoming_record unless $rules;
|
|
|
|
my $fields_by_tag = sub {
|
|
my ($record) = @_;
|
|
my $fields = {};
|
|
foreach my $field ( $record->fields() ) {
|
|
$fields->{ $field->tag() } //= [];
|
|
push @{ $fields->{ $field->tag() } }, $field;
|
|
}
|
|
return $fields;
|
|
};
|
|
|
|
my $hash_field_data = sub {
|
|
my ($field) = @_;
|
|
my $indicators = join( "\x1E", map { $field->indicator($_) } ( 1, 2 ) );
|
|
return $indicators . "\x1E" . join( "\x1E", sort map { join "\x1E", @{$_} } $field->subfields() );
|
|
};
|
|
|
|
my $diff_by_key = sub {
|
|
my ( $a, $b ) = @_;
|
|
my @removed;
|
|
my @intersecting;
|
|
my @added;
|
|
my %keys_index = map { $_ => undef } ( keys %{$a}, keys %{$b} );
|
|
foreach my $key ( keys %keys_index ) {
|
|
if ( $a->{$key} && $b->{$key} ) {
|
|
push @intersecting, [ $a->{$key}, $b->{$key} ];
|
|
} elsif ( $a->{$key} ) {
|
|
push @removed, $a->{$key};
|
|
} else {
|
|
push @added, $b->{$key};
|
|
}
|
|
}
|
|
return ( \@removed, \@intersecting, \@added );
|
|
};
|
|
|
|
my $tag_rules = $rules->{tags} // {};
|
|
my $default_rule = $rules->{'*'} // {
|
|
add => { allow => 1, 'rule' => 0 },
|
|
append => { allow => 1, 'rule' => 0 },
|
|
delete => { allow => 1, 'rule' => 0 },
|
|
remove => { allow => 1, 'rule' => 0 },
|
|
};
|
|
|
|
# Precompile regexps
|
|
my @regexp_rules = map { { regexp => qr/^$_->[0]$/, actions => $_->[1] } } @{ $rules->{regexps} // [] };
|
|
|
|
my $get_matching_field_rule = sub {
|
|
my ($tag) = @_;
|
|
|
|
# Exact match takes precedence, then regexp, then wildcard/defaults
|
|
return $tag_rules->{$tag} // %{ ( first { $tag =~ $_->{regexp} } @regexp_rules ) // {} }{actions}
|
|
// $default_rule;
|
|
};
|
|
|
|
my %merged_record_fields;
|
|
|
|
my $current_fields = $fields_by_tag->($old_record);
|
|
my $incoming_fields = $fields_by_tag->($incoming_record);
|
|
|
|
# First we get all new incoming fields
|
|
my @new_field_tags = grep { !( exists $current_fields->{$_} ) } keys %{$incoming_fields};
|
|
foreach my $tag (@new_field_tags) {
|
|
my $rule = $get_matching_field_rule->($tag);
|
|
if ( $rule->{add}->{allow} ) {
|
|
$merged_record_fields{$tag} //= [];
|
|
push @{ $merged_record_fields{$tag} }, @{ $incoming_fields->{$tag} };
|
|
}
|
|
}
|
|
|
|
# Then we get all fields no longer present in incoming fields
|
|
my @deleted_field_tags = grep { !( exists $incoming_fields->{$_} ) } keys %{$current_fields};
|
|
foreach my $tag (@deleted_field_tags) {
|
|
my $rule = $get_matching_field_rule->($tag);
|
|
if ( !$rule->{delete}->{allow} ) {
|
|
$merged_record_fields{$tag} //= [];
|
|
push @{ $merged_record_fields{$tag} }, @{ $current_fields->{$tag} };
|
|
}
|
|
}
|
|
|
|
# Then we get the intersection of fields, present both in
|
|
# current and incoming record (possibly to be overwritten)
|
|
my @common_field_tags = grep { exists $incoming_fields->{$_} } keys %{$current_fields};
|
|
foreach my $tag (@common_field_tags) {
|
|
my $rule = $get_matching_field_rule->($tag);
|
|
|
|
# Special handling for control fields
|
|
if ( $tag < 10 ) {
|
|
if ( $rule->{append}->{allow}
|
|
&& !$rule->{remove}->{allow} )
|
|
{
|
|
# This should be highly unlikely since we have input validation to protect against this case
|
|
carp
|
|
"Allowing \"append\" and skipping \"remove\" is not permitted for control fields, falling back to skipping both \"append\" and \"remove\"";
|
|
push @{ $merged_record_fields{$tag} }, @{ $current_fields->{$tag} };
|
|
} elsif ( $rule->{append}->{allow} ) {
|
|
push @{ $merged_record_fields{$tag} }, @{ $incoming_fields->{$tag} };
|
|
} else {
|
|
push @{ $merged_record_fields{$tag} }, @{ $current_fields->{$tag} };
|
|
}
|
|
} else {
|
|
|
|
# Compute intersection and diff using field data
|
|
my $sort_weight = 0;
|
|
my %current_fields_by_data =
|
|
map { $hash_field_data->($_) => [ $sort_weight++, $_ ] } @{ $current_fields->{$tag} };
|
|
|
|
# Always put incoming fields after current fields
|
|
my %incoming_fields_by_data =
|
|
map { $hash_field_data->($_) => [ $sort_weight++, $_ ] } @{ $incoming_fields->{$tag} };
|
|
|
|
my ( $current_fields_only, $common_fields, $incoming_fields_only ) =
|
|
$diff_by_key->( \%current_fields_by_data, \%incoming_fields_by_data );
|
|
|
|
my @merged_fields;
|
|
|
|
# First add common fields (intersection)
|
|
# Unchanged
|
|
if ( @{$common_fields} ) {
|
|
if (
|
|
$rule->{delete}->{allow}
|
|
&& $rule->{add}->{allow}
|
|
&& (
|
|
@{$common_fields} == 1
|
|
|| ( $rule->{append}->{allow}
|
|
&& $rule->{remove}->{allow} )
|
|
)
|
|
)
|
|
{
|
|
# If overwritable apply possible subfield order
|
|
# changes from incoming fields
|
|
push @merged_fields, map { $_->[1] } @{$common_fields};
|
|
} else {
|
|
|
|
# else keep existing subfield order
|
|
push @merged_fields, map { $_->[0] } @{$common_fields};
|
|
}
|
|
}
|
|
|
|
# Removed
|
|
if ( @{$current_fields_only} ) {
|
|
if ( !$rule->{remove}->{allow} ) {
|
|
push @merged_fields, @{$current_fields_only};
|
|
}
|
|
}
|
|
|
|
# Appended
|
|
if ( @{$incoming_fields_only} ) {
|
|
if ( $rule->{append}->{allow} ) {
|
|
push @merged_fields, @{$incoming_fields_only};
|
|
}
|
|
}
|
|
$merged_record_fields{$tag} //= [];
|
|
|
|
# Sort ascending according to weight (original order)
|
|
push @{ $merged_record_fields{$tag} }, map { $_->[1] } sort { $a->[0] <=> $b->[0] } @merged_fields;
|
|
}
|
|
}
|
|
|
|
my $merged_record = MARC::Record->new();
|
|
|
|
# Leader is always overwritten, or kept???
|
|
$merged_record->leader( $incoming_record->leader() );
|
|
|
|
if (%merged_record_fields) {
|
|
foreach my $tag ( sort keys %merged_record_fields ) {
|
|
$merged_record->append_fields( @{ $merged_record_fields{$tag} } );
|
|
}
|
|
}
|
|
return $merged_record;
|
|
}
|
|
|
|
sub _clear_caches {
|
|
$cache->clear_from_cache('marc_overlay_rules');
|
|
}
|
|
|
|
=head2 find_or_create
|
|
|
|
Override C<find_or_create> to clear marc overlay rules cache.
|
|
|
|
=cut
|
|
|
|
sub find_or_create {
|
|
my $self = shift @_;
|
|
$self->_clear_caches();
|
|
return $self->SUPER::find_or_create(@_);
|
|
}
|
|
|
|
=head2 update
|
|
|
|
Override C<update> to clear marc overlay rules cache.
|
|
|
|
=cut
|
|
|
|
sub update {
|
|
my $self = shift @_;
|
|
$self->_clear_caches();
|
|
return $self->SUPER::update(@_);
|
|
}
|
|
|
|
=head2 delete
|
|
|
|
Override C<delete> to clear marc overlay rules cache.
|
|
|
|
=cut
|
|
|
|
sub delete {
|
|
my $self = shift @_;
|
|
$self->_clear_caches();
|
|
return $self->SUPER::delete(@_);
|
|
}
|
|
|
|
=head2 validate
|
|
|
|
Koha::MarcOverlayRules->validate($rule_data);
|
|
|
|
Validates C<$rule_data>. Throws C<Koha::Exceptions::MarcOverlayRule::InvalidTagRegExp>
|
|
if C<$rule_data->{tag}> contains an invalid regular expression. Throws
|
|
C<Koha::Exceptions::MarcOverlayRule::InvalidControlFieldActions> if contains invalid
|
|
combination of actions for control fields. Otherwise returns true.
|
|
|
|
=cut
|
|
|
|
sub validate {
|
|
my ( $self, $rule_data ) = @_;
|
|
|
|
if ( exists $rule_data->{tag} ) {
|
|
if ( $rule_data->{tag} ne '*' ) {
|
|
eval { qr/$rule_data->{tag}/ };
|
|
if ($@) {
|
|
Koha::Exceptions::MarcOverlayRule::InvalidTagRegExp->throw("Invalid tag regular expression");
|
|
}
|
|
}
|
|
|
|
# TODO: Regexp or '*' that match controlfield not currently detected
|
|
if ( looks_like_number( $rule_data->{tag} )
|
|
&& $rule_data->{tag} < 10
|
|
&& $rule_data->{append}
|
|
&& !$rule_data->{remove} )
|
|
{
|
|
Koha::Exceptions::MarcOverlayRule::InvalidControlFieldActions->throw(
|
|
"Combination of allow append and skip remove not permitted for control fields");
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub _type {
|
|
return 'MarcOverlayRule';
|
|
}
|
|
|
|
=head3 object_class
|
|
|
|
=cut
|
|
|
|
sub object_class {
|
|
return 'Koha::MarcOverlayRule';
|
|
}
|
|
|
|
1;
|