Koha/MarcOverlayRules.pm

   1 package Koha::MarcOverlayRules;
   2
   3 # This file is part of Koha.
   4 #
   5 # Koha is free software; you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # Koha is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  17
  18 use Modern::Perl;
  19 use List::Util qw(first);
  20 use Koha::MarcOverlayRule;
  21 use Carp;
  22
  23 use Koha::Exceptions::MarcOverlayRule;
  24 use Try::Tiny;
  25 use Scalar::Util qw(looks_like_number);
  26
  27 use parent qw(Koha::Objects);
  28
  29 my $cache = Koha::Caches->get_instance();
  30
  31 =head1 NAME
  32
  33 Koha::MarcOverlayRules - Koha MarcOverlayRules Object set class
  34
  35 =head1 API
  36
  37 =head2 Class methods
  38
  39 =head3 operations
  40
  41 Returns a list of all valid operations.
  42
  43 =cut
  44
  45 sub operations {
  46     return ('add', 'append', 'remove', 'delete');
  47 }
  48
  49 =head3 context_rules
  50
  51     my $rules = Koha::MarcOverlayRules->context_rules($context);
  52
  53 Gets all MARC overlay rules for the supplied C<$context> (hashref with { module => filter, ... } values).
  54
  55 =cut
  56
  57 sub context_rules {
  58     my ($self, $context) = @_;
  59
  60     return unless %{$context};
  61
  62     my $rules = $cache->get_from_cache('marc_overlay_rules', { unsafe => 1 });
  63
  64     if (!$rules) {
  65         $rules = {};
  66         my @rules_rows = $self->_resultset()->search(
  67             undef,
  68             {
  69                 order_by => { -desc => [qw/id/] }
  70             }
  71         );
  72         foreach my $rule_row (@rules_rows) {
  73             my %rule = $rule_row->get_columns();
  74             my $operations = {};
  75
  76             foreach my $operation ($self->operations) {
  77                 $operations->{$operation} = { allow => $rule{$operation}, rule => $rule{id} };
  78             }
  79
  80             # TODO: Remove unless check and validate on saving rules?
  81             if ($rule{tag} eq '*') {
  82                 unless (exists $rules->{$rule{module}}->{$rule{filter}}->{'*'}) {
  83                     $rules->{$rule{module}}->{$rule{filter}}->{'*'} = $operations;
  84                 }
  85             }
  86             elsif ($rule{tag} =~ /^(\d{3})$/) {
  87                 unless (exists $rules->{$rule{module}}->{$rule{filter}}->{tags}->{$rule{tag}}) {
  88                     $rules->{$rule{module}}->{$rule{filter}}->{tags}->{$rule{tag}} = $operations;
  89                 }
  90             }
  91             else {
  92                 my $regexps = ($rules->{$rule{module}}->{$rule{filter}}->{regexps} //= []);
  93                 push @{$regexps}, [$rule{tag}, $operations];
  94             }
  95         }
  96         $cache->set_in_cache('marc_overlay_rules', $rules);
  97     }
  98
  99     my $context_rules = undef;
 100     foreach my $module_name (keys %{$context}) {
 101         if (
 102             exists $rules->{$module_name} &&
 103             exists $rules->{$module_name}->{$context->{$module_name}}
 104         ) {
 105             $context_rules = $rules->{$module_name}->{$context->{$module_name}};
 106             last;
 107         }
 108     }
 109     if (!$context_rules) {
 110         # No perms matching specific context conditions found, try wildcard value for each active context
 111         foreach my $module_name (keys %{$context}) {
 112             if (exists $rules->{$module_name}->{'*'}) {
 113                 $context_rules = $rules->{$module_name}->{'*'};
 114                 last;
 115             }
 116         }
 117     }
 118     return $context_rules;
 119 }
 120
 121 =head3 merge_records
 122
 123     my $merged_record = Koha::MarcOverlayRules->merge_records($old_record, $incoming_record, $context);
 124
 125 Overlay C<$old_record> with C<$incoming_record> applying overlay rules for C<$context>.
 126 Returns merged record C<$merged_record>. C<$old_record>, C<$incoming_record> and
 127 C<$merged_record> are all MARC::Record objects.
 128
 129 =cut
 130
 131 sub merge_records {
 132     my ($self, $old_record, $incoming_record, $context) = @_;
 133
 134     my $rules = $self->context_rules($context);
 135
 136     # Default when no rules found is to overwrite with incoming record
 137     return $incoming_record unless $rules;
 138
 139     my $fields_by_tag = sub {
 140         my ($record) = @_;
 141         my $fields = {};
 142         foreach my $field ($record->fields()) {
 143             $fields->{$field->tag()} //= [];
 144             push @{$fields->{$field->tag()}}, $field;
 145         }
 146         return $fields;
 147     };
 148
 149     my $hash_field_data = sub {
 150         my ($field) = @_;
 151         my $indicators = join("\x1E", map { $field->indicator($_) } (1, 2));
 152         return $indicators . "\x1E" . join("\x1E", sort map { join "\x1E", @{$_} } $field->subfields());
 153     };
 154
 155     my $diff_by_key = sub {
 156         my ($a, $b) = @_;
 157         my @removed;
 158         my @intersecting;
 159         my @added;
 160         my %keys_index = map { $_ => undef } (keys %{$a}, keys %{$b});
 161         foreach my $key (keys %keys_index) {
 162             if ($a->{$key} && $b->{$key}) {
 163                 push @intersecting, [$a->{$key}, $b->{$key}];
 164             }
 165             elsif ($a->{$key}) {
 166                 push @removed, $a->{$key};
 167             }
 168             else {
 169                 push @added, $b->{$key};
 170             }
 171         }
 172         return (\@removed, \@intersecting, \@added);
 173     };
 174
 175     my $tag_rules = $rules->{tags} // {};
 176     my $default_rule = $rules->{'*'} // {
 177         add => { allow => 1, 'rule' => 0},
 178         append => { allow => 1, 'rule' => 0},
 179         delete => { allow => 1, 'rule' => 0},
 180         remove => { allow => 1, 'rule' => 0},
 181     };
 182
 183     # Precompile regexps
 184     my @regexp_rules = map { { regexp => qr/^$_->[0]$/, actions => $_->[1] } } @{$rules->{regexps} // []};
 185
 186     my $get_matching_field_rule = sub {
 187         my ($tag) = @_;
 188         # Exact match takes precedence, then regexp, then wildcard/defaults
 189         return $tag_rules->{$tag} //
 190             %{(first { $tag =~ $_->{regexp} } @regexp_rules) // {}}{actions} //
 191             $default_rule;
 192     };
 193
 194     my %merged_record_fields;
 195
 196     my $current_fields = $fields_by_tag->($old_record);
 197     my $incoming_fields = $fields_by_tag->($incoming_record);
 198
 199     # First we get all new incoming fields
 200     my @new_field_tags = grep { !(exists $current_fields->{$_}) } keys %{$incoming_fields};
 201     foreach my $tag (@new_field_tags) {
 202         my $rule = $get_matching_field_rule->($tag);
 203         if ($rule->{add}->{allow}) {
 204             $merged_record_fields{$tag} //= [];
 205             push @{$merged_record_fields{$tag}}, @{$incoming_fields->{$tag}};
 206         }
 207     }
 208
 209     # Then we get all fields no longer present in incoming fields
 210     my @deleted_field_tags = grep { !(exists $incoming_fields->{$_}) } keys %{$current_fields};
 211     foreach my $tag (@deleted_field_tags) {
 212         my $rule = $get_matching_field_rule->($tag);
 213         if (!$rule->{delete}->{allow}) {
 214             $merged_record_fields{$tag} //= [];
 215             push @{$merged_record_fields{$tag}}, @{$current_fields->{$tag}};
 216         }
 217     }
 218
 219     # Then we get the intersection of fields, present both in
 220     # current and incoming record (possibly to be overwritten)
 221     my @common_field_tags = grep { exists $incoming_fields->{$_} } keys %{$current_fields};
 222     foreach my $tag (@common_field_tags) {
 223         my $rule = $get_matching_field_rule->($tag);
 224
 225         # Special handling for control fields
 226         if ($tag < 10) {
 227             if (
 228                 $rule->{append}->{allow} &&
 229                 !$rule->{remove}->{allow}
 230             ) {
 231                 # This should be highly unlikely since we have input validation to protect against this case
 232                 carp "Allowing \"append\" and skipping \"remove\" is not permitted for control fields, falling back to skipping both \"append\" and \"remove\"";
 233                 push @{$merged_record_fields{$tag}}, @{$current_fields->{$tag}};
 234             }
 235             elsif ($rule->{append}->{allow}) {
 236                 push @{$merged_record_fields{$tag}}, @{$incoming_fields->{$tag}};
 237             }
 238             else {
 239                 push @{$merged_record_fields{$tag}}, @{$current_fields->{$tag}};
 240             }
 241         }
 242         else {
 243             # Compute intersection and diff using field data
 244             my $sort_weight = 0;
 245             my %current_fields_by_data = map { $hash_field_data->($_) => [$sort_weight++, $_] } @{$current_fields->{$tag}};
 246
 247             # Always put incoming fields after current fields
 248             my %incoming_fields_by_data = map { $hash_field_data->($_) => [$sort_weight++, $_] } @{$incoming_fields->{$tag}};
 249
 250             my ($current_fields_only, $common_fields, $incoming_fields_only) = $diff_by_key->(\%current_fields_by_data, \%incoming_fields_by_data);
 251
 252             my @merged_fields;
 253
 254             # First add common fields (intersection)
 255             # Unchanged
 256             if (@{$common_fields}) {
 257                 if(
 258                     $rule->{delete}->{allow} &&
 259                     $rule->{add}->{allow} && (
 260                         @{$common_fields} == 1 || (
 261                             $rule->{append}->{allow} &&
 262                             $rule->{remove}->{allow}
 263                         )
 264                     )
 265                 ) {
 266                     # If overwritable apply possible subfield order
 267                     # changes from incoming fields
 268                     push @merged_fields, map { $_->[1] } @{$common_fields};
 269                 }
 270                 else {
 271                     # else keep existing subfield order
 272                     push @merged_fields, map { $_->[0] } @{$common_fields};
 273                 }
 274             }
 275             # Removed
 276             if (@{$current_fields_only}) {
 277                 if (!$rule->{remove}->{allow}) {
 278                     push @merged_fields, @{$current_fields_only};
 279                 }
 280             }
 281             # Appended
 282             if (@{$incoming_fields_only}) {
 283                 if ($rule->{append}->{allow}) {
 284                     push @merged_fields, @{$incoming_fields_only};
 285                 }
 286             }
 287             $merged_record_fields{$tag} //= [];
 288
 289             # Sort ascending according to weight (original order)
 290             push @{$merged_record_fields{$tag}}, map { $_->[1] } sort { $a->[0] <=> $b->[0] } @merged_fields;
 291         }
 292     }
 293
 294     my $merged_record = MARC::Record->new();
 295
 296     # Leader is always overwritten, or kept???
 297     $merged_record->leader($incoming_record->leader());
 298
 299     if (%merged_record_fields) {
 300         foreach my $tag (sort keys %merged_record_fields) {
 301             $merged_record->append_fields(@{$merged_record_fields{$tag}});
 302         }
 303     }
 304     return $merged_record;
 305 }
 306
 307 sub _clear_caches {
 308     $cache->clear_from_cache('marc_overlay_rules');
 309 }
 310
 311 =head2 find_or_create
 312
 313 Override C<find_or_create> to clear marc overlay rules cache.
 314
 315 =cut
 316
 317 sub find_or_create {
 318     my $self = shift @_;
 319     $self->_clear_caches();
 320     return $self->SUPER::find_or_create(@_);
 321 }
 322
 323 =head2 update
 324
 325 Override C<update> to clear marc overlay rules cache.
 326
 327 =cut
 328
 329 sub update {
 330     my $self = shift @_;
 331     $self->_clear_caches();
 332     return $self->SUPER::update(@_);
 333 }
 334
 335 =head2 delete
 336
 337 Override C<delete> to clear marc overlay rules cache.
 338
 339 =cut
 340
 341 sub delete {
 342     my $self = shift @_;
 343     $self->_clear_caches();
 344     return $self->SUPER::delete(@_);
 345 }
 346
 347 =head2 validate
 348
 349     Koha::MarcOverlayRules->validate($rule_data);
 350
 351 Validates C<$rule_data>. Throws C<Koha::Exceptions::MarcOverlayRule::InvalidTagRegExp>
 352 if C<$rule_data->{tag}> contains an invalid regular expression. Throws
 353 C<Koha::Exceptions::MarcOverlayRule::InvalidControlFieldActions> if contains invalid
 354 combination of actions for control fields. Otherwise returns true.
 355
 356 =cut
 357
 358 sub validate {
 359     my ($self, $rule_data) = @_;
 360
 361     if(exists $rule_data->{tag}) {
 362         if ($rule_data->{tag} ne '*') {
 363             eval { qr/$rule_data->{tag}/ };
 364             if ($@) {
 365                 Koha::Exceptions::MarcOverlayRule::InvalidTagRegExp->throw(
 366                     "Invalid tag regular expression"
 367                 );
 368             }
 369         }
 370         # TODO: Regexp or '*' that match controlfield not currently detected
 371         if (
 372             looks_like_number($rule_data->{tag}) &&
 373             $rule_data->{tag} < 10 &&
 374             $rule_data->{append} &&
 375             !$rule_data->{remove}
 376         ) {
 377             Koha::Exceptions::MarcOverlayRule::InvalidControlFieldActions->throw(
 378                 "Combination of allow append and skip remove not permitted for control fields"
 379             );
 380         }
 381     }
 382     return 1;
 383 }
 384
 385 sub _type {
 386     return 'MarcOverlayRule';
 387 }
 388
 389 =head3 object_class
 390
 391 =cut
 392
 393 sub object_class {
 394     return 'Koha::MarcOverlayRule';
 395 }
 396
 397 1;