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);
use Koha::MarcOverlayRule;
use Carp;

use Koha::Exceptions::MarcOverlayRule;
use Try::Tiny;
use Scalar::Util qw(looks_like_number);

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 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 = undef;
    foreach my $module_name (keys %{$context}) {
        if (
            exists $rules->{$module_name} &&
            exists $rules->{$module_name}->{$context->{$module_name}}
        ) {
            $context_rules = $rules->{$module_name}->{$context->{$module_name}};
            last;
        }
    }
    if (!$context_rules) {
        # No perms matching specific context conditions found, try wildcard value for each active context
        foreach my $module_name (keys %{$context}) {
            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;