1 package Koha::MarcOverlayRules;
3 # This file is part of Koha.
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.
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.
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>.
19 use List::Util qw(first);
20 use Koha::MarcOverlayRule;
23 use Koha::Exceptions::MarcOverlayRule;
25 use Scalar::Util qw(looks_like_number);
27 use parent qw(Koha::Objects);
29 my $cache = Koha::Caches->get_instance();
33 Koha::MarcOverlayRules - Koha MarcOverlayRules Object set class
41 Returns a list of all valid operations.
46 return ('add', 'append', 'remove', 'delete');
51 my $rules = Koha::MarcOverlayRules->context_rules($context);
53 Gets all MARC overlay rules for the supplied C<$context> (hashref with { module => filter, ... } values).
58 my ($self, $context) = @_;
60 return unless %{$context};
62 my $rules = $cache->get_from_cache('marc_overlay_rules', { unsafe => 1 });
66 my @rules_rows = $self->_resultset()->search(
69 order_by => { -desc => [qw/id/] }
72 foreach my $rule_row (@rules_rows) {
73 my %rule = $rule_row->get_columns();
76 foreach my $operation ($self->operations) {
77 $operations->{$operation} = { allow => $rule{$operation}, rule => $rule{id} };
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;
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;
92 my $regexps = ($rules->{$rule{module}}->{$rule{filter}}->{regexps} //= []);
93 push @{$regexps}, [$rule{tag}, $operations];
96 $cache->set_in_cache('marc_overlay_rules', $rules);
99 my $context_rules = undef;
100 foreach my $module_name (keys %{$context}) {
102 exists $rules->{$module_name} &&
103 exists $rules->{$module_name}->{$context->{$module_name}}
105 $context_rules = $rules->{$module_name}->{$context->{$module_name}};
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}->{'*'};
118 return $context_rules;
123 my $merged_record = Koha::MarcOverlayRules->merge_records($old_record, $incoming_record, $context);
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.
132 my ($self, $old_record, $incoming_record, $context) = @_;
134 my $rules = $self->context_rules($context);
136 # Default when no rules found is to overwrite with incoming record
137 return $incoming_record unless $rules;
139 my $fields_by_tag = sub {
142 foreach my $field ($record->fields()) {
143 $fields->{$field->tag()} //= [];
144 push @{$fields->{$field->tag()}}, $field;
149 my $hash_field_data = sub {
151 my $indicators = join("\x1E", map { $field->indicator($_) } (1, 2));
152 return $indicators . "\x1E" . join("\x1E", sort map { join "\x1E", @{$_} } $field->subfields());
155 my $diff_by_key = sub {
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}];
166 push @removed, $a->{$key};
169 push @added, $b->{$key};
172 return (\@removed, \@intersecting, \@added);
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},
184 my @regexp_rules = map { { regexp => qr/^$_->[0]$/, actions => $_->[1] } } @{$rules->{regexps} // []};
186 my $get_matching_field_rule = sub {
188 # Exact match takes precedence, then regexp, then wildcard/defaults
189 return $tag_rules->{$tag} //
190 %{(first { $tag =~ $_->{regexp} } @regexp_rules) // {}}{actions} //
194 my %merged_record_fields;
196 my $current_fields = $fields_by_tag->($old_record);
197 my $incoming_fields = $fields_by_tag->($incoming_record);
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}};
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}};
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);
225 # Special handling for control fields
228 $rule->{append}->{allow} &&
229 !$rule->{remove}->{allow}
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}};
235 elsif ($rule->{append}->{allow}) {
236 push @{$merged_record_fields{$tag}}, @{$incoming_fields->{$tag}};
239 push @{$merged_record_fields{$tag}}, @{$current_fields->{$tag}};
243 # Compute intersection and diff using field data
245 my %current_fields_by_data = map { $hash_field_data->($_) => [$sort_weight++, $_] } @{$current_fields->{$tag}};
247 # Always put incoming fields after current fields
248 my %incoming_fields_by_data = map { $hash_field_data->($_) => [$sort_weight++, $_] } @{$incoming_fields->{$tag}};
250 my ($current_fields_only, $common_fields, $incoming_fields_only) = $diff_by_key->(\%current_fields_by_data, \%incoming_fields_by_data);
254 # First add common fields (intersection)
256 if (@{$common_fields}) {
258 $rule->{delete}->{allow} &&
259 $rule->{add}->{allow} && (
260 @{$common_fields} == 1 || (
261 $rule->{append}->{allow} &&
262 $rule->{remove}->{allow}
266 # If overwritable apply possible subfield order
267 # changes from incoming fields
268 push @merged_fields, map { $_->[1] } @{$common_fields};
271 # else keep existing subfield order
272 push @merged_fields, map { $_->[0] } @{$common_fields};
276 if (@{$current_fields_only}) {
277 if (!$rule->{remove}->{allow}) {
278 push @merged_fields, @{$current_fields_only};
282 if (@{$incoming_fields_only}) {
283 if ($rule->{append}->{allow}) {
284 push @merged_fields, @{$incoming_fields_only};
287 $merged_record_fields{$tag} //= [];
289 # Sort ascending according to weight (original order)
290 push @{$merged_record_fields{$tag}}, map { $_->[1] } sort { $a->[0] <=> $b->[0] } @merged_fields;
294 my $merged_record = MARC::Record->new();
296 # Leader is always overwritten, or kept???
297 $merged_record->leader($incoming_record->leader());
299 if (%merged_record_fields) {
300 foreach my $tag (sort keys %merged_record_fields) {
301 $merged_record->append_fields(@{$merged_record_fields{$tag}});
304 return $merged_record;
308 $cache->clear_from_cache('marc_overlay_rules');
311 =head2 find_or_create
313 Override C<find_or_create> to clear marc overlay rules cache.
319 $self->_clear_caches();
320 return $self->SUPER::find_or_create(@_);
325 Override C<update> to clear marc overlay rules cache.
331 $self->_clear_caches();
332 return $self->SUPER::update(@_);
337 Override C<delete> to clear marc overlay rules cache.
343 $self->_clear_caches();
344 return $self->SUPER::delete(@_);
349 Koha::MarcOverlayRules->validate($rule_data);
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.
359 my ($self, $rule_data) = @_;
361 if(exists $rule_data->{tag}) {
362 if ($rule_data->{tag} ne '*') {
363 eval { qr/$rule_data->{tag}/ };
365 Koha::Exceptions::MarcOverlayRule::InvalidTagRegExp->throw(
366 "Invalid tag regular expression"
370 # TODO: Regexp or '*' that match controlfield not currently detected
372 looks_like_number($rule_data->{tag}) &&
373 $rule_data->{tag} < 10 &&
374 $rule_data->{append} &&
375 !$rule_data->{remove}
377 Koha::Exceptions::MarcOverlayRule::InvalidControlFieldActions->throw(
378 "Combination of allow append and skip remove not permitted for control fields"
386 return 'MarcOverlayRule';
394 return 'Koha::MarcOverlayRule';