| Lines 99-104
          BEGIN {
      
      
        Link Here | 
        
          | 99 |  | 99 |  | 
        
          | 100 |       &CountItemsIssued | 100 |       &CountItemsIssued | 
        
          | 101 |       &CountBiblioInOrders | 101 |       &CountBiblioInOrders | 
            
              |  |  | 102 |  | 
            
              | 103 |       &GetMarcPermissionsRules | 
            
              | 104 |       &GetMarcPermissionsModules | 
            
              | 105 |       &ModMarcPermissionsRule | 
            
              | 106 |       &AddMarcPermissionsRule | 
            
              | 107 |       &DelMarcPermissionsRule | 
        
          | 102 |     ); | 108 |     ); | 
        
          | 103 |  | 109 |  | 
        
          | 104 |     # To modify something | 110 |     # To modify something | 
  
    | Lines 126-131
          BEGIN {
      
      
        Link Here | 
        
          | 126 |     # they are useful in a few circumstances, so they are exported, | 132 |     # they are useful in a few circumstances, so they are exported, | 
        
          | 127 |     # but don't use them unless you are a core developer ;-) | 133 |     # but don't use them unless you are a core developer ;-) | 
        
          | 128 |     push @EXPORT, qw( | 134 |     push @EXPORT, qw( | 
            
              |  |  | 135 |       &ApplyMarcPermissions | 
        
          | 129 |       &ModBiblioMarc | 136 |       &ModBiblioMarc | 
        
          | 130 |     ); | 137 |     ); | 
        
          | 131 |  | 138 |  | 
  
    | Lines 263-269
          sub AddBiblio {
      
      
        Link Here | 
        
          | 263 |  | 270 |  | 
        
          | 264 | =head2 ModBiblio | 271 | =head2 ModBiblio | 
        
          | 265 |  | 272 |  | 
          
            
              | 266 |   ModBiblio( $record,$biblionumber,$frameworkcode); | 273 |   ModBiblio($record, $biblionumber, $frameworkcode, $options); | 
        
          | 267 |  | 274 |  | 
        
          | 268 | Replace an existing bib record identified by C<$biblionumber> | 275 | Replace an existing bib record identified by C<$biblionumber> | 
        
          | 269 | with one supplied by the MARC::Record object C<$record>.  The embedded | 276 | with one supplied by the MARC::Record object C<$record>.  The embedded | 
  
    | Lines 284-290
          Returns 1 on success 0 on failure
      
      
        Link Here | 
        
          | 284 | =cut | 291 | =cut | 
        
          | 285 |  | 292 |  | 
        
          | 286 | sub ModBiblio { | 293 | sub ModBiblio { | 
          
            
              | 287 |     my ( $record, $biblionumber, $frameworkcode ) = @_; | 294 |     my ( $record, $biblionumber, $frameworkcode, $options ) = @_; | 
            
              |  |  | 295 |     $options //= {}; | 
            
              | 296 |  | 
        
          | 288 |     if (!$record) { | 297 |     if (!$record) { | 
        
          | 289 |         carp 'No record passed to ModBiblio'; | 298 |         carp 'No record passed to ModBiblio'; | 
        
          | 290 |         return 0; | 299 |         return 0; | 
  
    | Lines 312-317
          sub ModBiblio {
      
      
        Link Here | 
        
          | 312 |  | 321 |  | 
        
          | 313 |     _strip_item_fields($record, $frameworkcode); | 322 |     _strip_item_fields($record, $frameworkcode); | 
        
          | 314 |  | 323 |  | 
            
              |  |  | 324 |     # apply permissions | 
            
              | 325 |     if (C4::Context->preference('MARCPermissions') && $biblionumber && defined $options && exists $options->{'context'}) { | 
            
              | 326 |         $record = ApplyMarcPermissions({ | 
            
              | 327 |                 biblionumber => $biblionumber, | 
            
              | 328 |                 record => $record, | 
            
              | 329 |                 filter => $options->{'context'}, | 
            
              | 330 |             } | 
            
              | 331 |         ); | 
            
              | 332 |     } | 
            
              | 333 |  | 
        
          | 315 |     # update biblionumber and biblioitemnumber in MARC | 334 |     # update biblionumber and biblioitemnumber in MARC | 
        
          | 316 |     # FIXME - this is assuming a 1 to 1 relationship between | 335 |     # FIXME - this is assuming a 1 to 1 relationship between | 
        
          | 317 |     # biblios and biblioitems | 336 |     # biblios and biblioitems | 
  
    | Lines 322-334
          sub ModBiblio {
      
      
        Link Here | 
        
          | 322 |     _koha_marc_update_bib_ids( $record, $frameworkcode, $biblionumber, $biblioitemnumber ); | 341 |     _koha_marc_update_bib_ids( $record, $frameworkcode, $biblionumber, $biblioitemnumber ); | 
        
          | 323 |  | 342 |  | 
        
          | 324 |     # load the koha-table data object | 343 |     # load the koha-table data object | 
          
            
              | 325 |     my $oldbiblio = TransformMarcToKoha( $record, $frameworkcode ); | 344 |     my $oldbiblio = TransformMarcToKoha( $record, $frameworkcode, undef, $biblionumber); | 
        
          | 326 |  | 345 |  | 
        
          | 327 |     # update MARC subfield that stores biblioitems.cn_sort | 346 |     # update MARC subfield that stores biblioitems.cn_sort | 
        
          | 328 |     _koha_marc_update_biblioitem_cn_sort( $record, $oldbiblio, $frameworkcode ); | 347 |     _koha_marc_update_biblioitem_cn_sort( $record, $oldbiblio, $frameworkcode ); | 
        
          | 329 |  | 348 |  | 
        
          | 330 |     # update the MARC record (that now contains biblio and items) with the new record data | 349 |     # update the MARC record (that now contains biblio and items) with the new record data | 
          
            
              | 331 |     &ModBiblioMarc( $record, $biblionumber, $frameworkcode ); | 350 |     ModBiblioMarc( $record, $biblionumber, $frameworkcode ); | 
        
          | 332 |  | 351 |  | 
        
          | 333 |     # modify the other koha tables | 352 |     # modify the other koha tables | 
        
          | 334 |     _koha_modify_biblio( $dbh, $oldbiblio, $frameworkcode ); | 353 |     _koha_modify_biblio( $dbh, $oldbiblio, $frameworkcode ); | 
  
    | Lines 2508-2514
          sub TransformHtmlToMarc {
      
      
        Link Here | 
        
          | 2508 |  | 2527 |  | 
        
          | 2509 | =head2 TransformMarcToKoha | 2528 | =head2 TransformMarcToKoha | 
        
          | 2510 |  | 2529 |  | 
          
            
              | 2511 |     $result = TransformMarcToKoha( $record, undef, $limit ) | 2530 |     $result = TransformMarcToKoha($record, undef, $biblionumber, $option) | 
        
          | 2512 |  | 2531 |  | 
        
          | 2513 | Extract data from a MARC bib record into a hashref representing | 2532 | Extract data from a MARC bib record into a hashref representing | 
        
          | 2514 | Koha biblio, biblioitems, and items fields. | 2533 | Koha biblio, biblioitems, and items fields. | 
  
    | Lines 2519-2525
          hash_ref.
      
      
        Link Here | 
        
          | 2519 | =cut | 2538 | =cut | 
        
          | 2520 |  | 2539 |  | 
        
          | 2521 | sub TransformMarcToKoha { | 2540 | sub TransformMarcToKoha { | 
          
            
              | 2522 |     my ( $record, $frameworkcode, $limit_table ) = @_; | 2541 |     my ( $record, $frameworkcode, $limit_table, $biblionumber ) = @_; | 
        
          | 2523 |     # FIXME  Parameter $frameworkcode is obsolete and will be removed | 2542 |     # FIXME  Parameter $frameworkcode is obsolete and will be removed | 
        
          | 2524 |     $limit_table //= q{}; | 2543 |     $limit_table //= q{}; | 
        
          | 2525 |  | 2544 |  | 
  
    | Lines 3206-3212
          sub _koha_delete_biblio_metadata {
      
      
        Link Here | 
        
          | 3206 |  | 3225 |  | 
        
          | 3207 | =head2 ModBiblioMarc | 3226 | =head2 ModBiblioMarc | 
        
          | 3208 |  | 3227 |  | 
          
            
              | 3209 |   &ModBiblioMarc($newrec,$biblionumber,$frameworkcode); | 3228 |   &ModBiblioMarc($newrec, $biblionumber, $frameworkcode, $options); | 
        
          | 3210 |  | 3229 |  | 
        
          | 3211 | Add MARC XML data for a biblio to koha | 3230 | Add MARC XML data for a biblio to koha | 
        
          | 3212 |  | 3231 |  | 
  
    | Lines 3218-3223
          sub ModBiblioMarc {
      
      
        Link Here | 
        
          | 3218 |     # pass the MARC::Record to this function, and it will create the records in | 3237 |     # pass the MARC::Record to this function, and it will create the records in | 
        
          | 3219 |     # the marcxml field | 3238 |     # the marcxml field | 
        
          | 3220 |     my ( $record, $biblionumber, $frameworkcode ) = @_; | 3239 |     my ( $record, $biblionumber, $frameworkcode ) = @_; | 
            
              |  |  | 3240 |  | 
        
          | 3221 |     if ( !$record ) { | 3241 |     if ( !$record ) { | 
        
          | 3222 |         carp 'ModBiblioMarc passed an undefined record'; | 3242 |         carp 'ModBiblioMarc passed an undefined record'; | 
        
          | 3223 |         return; | 3243 |         return; | 
  
    | Lines 3230-3235
          sub ModBiblioMarc {
      
      
        Link Here | 
        
          | 3230 |     if ( !$frameworkcode ) { | 3250 |     if ( !$frameworkcode ) { | 
        
          | 3231 |         $frameworkcode = ""; | 3251 |         $frameworkcode = ""; | 
        
          | 3232 |     } | 3252 |     } | 
            
              |  |  | 3253 |  | 
        
          | 3233 |     my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?"); | 3254 |     my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?"); | 
        
          | 3234 |     $sth->execute( $frameworkcode, $biblionumber ); | 3255 |     $sth->execute( $frameworkcode, $biblionumber ); | 
        
          | 3235 |     $sth->finish; | 3256 |     $sth->finish; | 
  
    | Lines 3533-3540
          sub RemoveAllNsb {
      
      
        Link Here | 
        
          | 3533 |     return $record; | 3554 |     return $record; | 
        
          | 3534 | } | 3555 | } | 
        
          | 3535 |  | 3556 |  | 
          
            
              | 3536 | 1; | 3557 | =head2 ApplyMarcPermissions | 
            
              |  |  | 3558 |  | 
            
              | 3559 |     my $record = ApplyMarcPermissions($arguments) | 
            
              | 3560 |  | 
            
              | 3561 | Applies marc permission rules to a record. | 
            
              | 3562 |  | 
            
              | 3563 | C<$arguments> is expected to be a hashref with below keys defined. | 
            
              | 3564 |  | 
            
              | 3565 | =over 4 | 
            
              | 3566 |  | 
            
              | 3567 | =item C<biblionumber> | 
            
              | 3568 | biblionumber of old record | 
            
              | 3569 |  | 
            
              | 3570 | =item C<record> | 
            
              | 3571 | record that will modify old record | 
            
              | 3572 |  | 
            
              | 3573 | =item C<frameworkcode> | 
            
              | 3574 | only tags included in framework will be processed | 
            
              | 3575 |  | 
            
              | 3576 | =item C<filter> | 
            
              | 3577 | hashref containing at least one filter module from the marc_permissions_modules | 
            
              | 3578 | table in form {module => filter}. Three predefined filter modules exists: | 
            
              | 3579 |  | 
            
              | 3580 |     * source | 
            
              | 3581 |     * category | 
            
              | 3582 |     * borrower | 
            
              | 3583 |  | 
            
              | 3584 | =item C<log> | 
            
              | 3585 | optional reference to array that will be filled with rule evaluation log | 
            
              | 3586 | entries. | 
            
              | 3587 |  | 
            
              | 3588 | =item C<nolog> | 
            
              | 3589 | optional boolean which when true disables logging to action log. | 
            
              | 3590 |  | 
            
              | 3591 | =back | 
            
              | 3592 |  | 
            
              | 3593 | Returns: | 
            
              | 3594 |  | 
            
              | 3595 | =over 4 | 
            
              | 3596 |  | 
            
              | 3597 | =item C<$record> | 
            
              | 3598 |  | 
            
              | 3599 | new MARC record based on C<record> with C<filter> applied. If no old | 
            
              | 3600 | record for C<biblionumber> can be found, C<record> is returned unchanged. | 
            
              | 3601 | Default action when no matching filter found is to leave old record unchanged. | 
            
              | 3602 |  | 
            
              | 3603 | =back | 
            
              | 3604 |  | 
            
              | 3605 | =cut | 
            
              | 3606 |  | 
            
              | 3607 | sub ApplyMarcPermissions { | 
            
              | 3608 |     my ($arguments) = @_; | 
            
              | 3609 |     my $biblionumber = $arguments->{biblionumber}; | 
            
              | 3610 |     my $incoming_record = $arguments->{record}; | 
            
              | 3611 |  | 
            
              | 3612 |     if ( !$biblionumber ) { | 
            
              | 3613 |         carp 'ApplyMarcPermissions called on undefined biblionumber'; | 
            
              | 3614 |         return; | 
            
              | 3615 |     } | 
            
              | 3616 |     if ( !$incoming_record ) { | 
            
              | 3617 |         carp 'ApplyMarcPermissions called on undefined record'; | 
            
              | 3618 |         return; | 
            
              | 3619 |     } | 
            
              | 3620 |     my $old_record = GetMarcBiblio({ biblionumber => $biblionumber }); | 
            
              | 3621 |  | 
            
              | 3622 |     my $merge_rules = undef; | 
            
              | 3623 |     if ($old_record && $arguments->{filter} && ($merge_rules = GetMarcPermissions($arguments->{filter}))) { | 
            
              | 3624 |         return MergeRecords($old_record, $incoming_record, $merge_rules); | 
            
              | 3625 |     } | 
            
              | 3626 |     return $incoming_record; | 
            
              | 3627 | } | 
            
              | 3628 |  | 
            
              | 3629 | sub MergeRecords { | 
            
              | 3630 |     my ($old_record, $incoming_record, $merge_rules) = @_; | 
            
              | 3631 |     my $is_matching_regex = sub { | 
            
              | 3632 |         my ( $tag, $m ) = @_; | 
            
              | 3633 |  | 
            
              | 3634 |         # tag is not exactly same as possible regex | 
            
              | 3635 |         $tag ne $m && | 
            
              | 3636 |  | 
            
              | 3637 |         # wildcard | 
            
              | 3638 |         $m ne '*' && | 
            
              | 3639 |  | 
            
              | 3640 |         # valid tagDataType | 
            
              | 3641 |         $m !~ /^(0[1-9A-z][\dA-Z]) | | 
            
              | 3642 |         ([1-9A-z][\dA-z]{2})$/x && | 
            
              | 3643 |  | 
            
              | 3644 |         # nor valid controltagDataType | 
            
              | 3645 |         $m !~ /00[1-9A-Za-z]{1}/ && | 
            
              | 3646 |  | 
            
              | 3647 |         # so we try it as a regex | 
            
              | 3648 |         $tag =~ /^$m$/ | 
            
              | 3649 |     }; | 
            
              | 3650 |  | 
            
              | 3651 |     my $fields_by_tag = sub { | 
            
              | 3652 |         my ($record) = @_; | 
            
              | 3653 |         my $fields = {}; | 
            
              | 3654 |         foreach my $field ($record->fields()) { | 
            
              | 3655 |             $fields->{$field->tag()} //= []; | 
            
              | 3656 |             push @{$fields->{$field->tag()}}, $field; | 
            
              | 3657 |         } | 
            
              | 3658 |         return $fields; | 
            
              | 3659 |     }; | 
            
              | 3660 |  | 
            
              | 3661 |     my $hash_field_data = sub { | 
            
              | 3662 |         my ($field) = @_; | 
            
              | 3663 |         my $indicators = join("\x1E", map { $field->indicator($_) } (1, 2)); | 
            
              | 3664 |         return $indicators . "\x1E" . join("\x1E", sort map { join "\x1E", @{$_} } $field->subfields()); | 
            
              | 3665 |     }; | 
            
              | 3666 |  | 
            
              | 3667 |     my $diff_by_key = sub { | 
            
              | 3668 |         my ($a, $b) = @_; | 
            
              | 3669 |         my @removed; | 
            
              | 3670 |         my @intersecting; | 
            
              | 3671 |         my @added; | 
            
              | 3672 |         my %keys_index = map { $_ => undef } (keys %{$a}, keys %{$b}); | 
            
              | 3673 |         foreach my $key (keys %keys_index) { | 
            
              | 3674 |             if ($a->{$key} && $b->{$key}) { | 
            
              | 3675 |                 push @intersecting, $a->{$key}; | 
            
              | 3676 |             } | 
            
              | 3677 |             elsif ($a->{$key}) { | 
            
              | 3678 |                 push @removed, $a->{$key}; | 
            
              | 3679 |             } | 
            
              | 3680 |             else { | 
            
              | 3681 |                 push @added, $b->{$key}; | 
            
              | 3682 |             } | 
            
              | 3683 |         } | 
            
              | 3684 |         return (\@removed, \@intersecting, \@added); | 
            
              | 3685 |     }; | 
            
              | 3686 |  | 
            
              | 3687 |     my $get_matching_field_rule = sub { | 
            
              | 3688 |         my ($tag) = @_; | 
            
              | 3689 |         my $matched_rule = undef; | 
            
              | 3690 |         # Exact match takes precedence | 
            
              | 3691 |         if (exists $merge_rules->{$tag}) { | 
            
              | 3692 |             $matched_rule = $merge_rules->{$tag}; | 
            
              | 3693 |         } | 
            
              | 3694 |         else { | 
            
              | 3695 |             # TODO: sorty by module/weight rule id or something, grab first matching via listutils thingy | 
            
              | 3696 |             my @matching_rules = map { $merge_rules->{$_} } grep { $is_matching_regex->($tag, $_) } sort keys %{$merge_rules}; | 
            
              | 3697 |             # TODO: fix | 
            
              | 3698 |             if (@matching_rules) { | 
            
              | 3699 |                 $matched_rule = pop @matching_rules; | 
            
              | 3700 |             } | 
            
              | 3701 |             elsif($merge_rules->{'*'}) { | 
            
              | 3702 |                 $matched_rule = $merge_rules->{'*'}; | 
            
              | 3703 |             } | 
            
              | 3704 |         } | 
            
              | 3705 |         return $matched_rule; | 
            
              | 3706 |     }; | 
            
              | 3707 |  | 
            
              | 3708 |     my $merged_record = MARC::Record->new(); | 
            
              | 3709 |     my @merged_record_fields; | 
            
              | 3710 |  | 
            
              | 3711 |     # Leader is always overwritten, or kept??? | 
            
              | 3712 |     $merged_record->leader($incoming_record->leader()); | 
            
              | 3713 |  | 
            
              | 3714 |     my $current_fields = $fields_by_tag->($old_record); | 
            
              | 3715 |     my $incoming_fields = $fields_by_tag->($incoming_record); | 
            
              | 3716 |  | 
            
              | 3717 |     # First we get all new incoming control fields | 
            
              | 3718 |     my @new_field_tags = grep { !(exists $current_fields->{$_}) } keys %{$incoming_fields}; | 
            
              | 3719 |  | 
            
              | 3720 |     foreach my $tag (@new_field_tags) { | 
            
              | 3721 |         my $rule = $get_matching_field_rule->($tag) // { | 
            
              | 3722 |             on_new => {'action' => 'skip', 'rule' => 0} | 
            
              | 3723 |         }; | 
            
              | 3724 |         if ( | 
            
              | 3725 |             $rule->{on_new}->{action} eq 'add' || | 
            
              | 3726 |             $rule->{on_new}->{action} eq 'overwrite' # ??? | 
            
              | 3727 |         ) { # Or could just be write/protect? | 
            
              | 3728 |             # Hmm, only one control field possible?? | 
            
              | 3729 |             push @merged_record_fields, @{$incoming_fields->{$tag}}; | 
            
              | 3730 |         } | 
            
              | 3731 |     } | 
            
              | 3732 |  | 
            
              | 3733 |     # Then we get all control fields no longer present in incoming fields | 
            
              | 3734 |     # (removed) | 
            
              | 3735 |     my @deleted_field_tags = grep { !(exists $incoming_fields->{$_}) } keys %{$current_fields}; | 
            
              | 3736 |     foreach my $tag (@deleted_field_tags) { | 
            
              | 3737 |         my $rule = $get_matching_field_rule->($tag) // { | 
            
              | 3738 |             on_deleted => {'action' => 'skip', 'rule' => 0} | 
            
              | 3739 |         }; | 
            
              | 3740 |         if ($rule->{on_deleted}->{action} eq 'skip') { | 
            
              | 3741 |             push @merged_record_fields, @{$current_fields->{$tag}}; | 
            
              | 3742 |         } | 
            
              | 3743 |     } | 
            
              | 3744 |  | 
            
              | 3745 |     # Then we get the intersection of control fields, present both in | 
            
              | 3746 |     # current and incoming record (possibly to be overwritten) | 
            
              | 3747 |     my @common_field_tags = grep { exists $incoming_fields->{$_} } keys %{$current_fields}; | 
            
              | 3748 |     foreach my $tag (@common_field_tags) { | 
            
              | 3749 |         # Is control field | 
            
              | 3750 |         my $rule = $get_matching_field_rule->($tag) // { | 
            
              | 3751 |             on_removed => {'action' => 'skip', 'rule' => 0}, | 
            
              | 3752 |             on_appended => {'action' => 'skip', 'rule' => 0} | 
            
              | 3753 |         }; | 
            
              | 3754 |         if ($tag < 10) { | 
            
              | 3755 |             # on_existing = on_match | 
            
              | 3756 |             if ($rule->{on_appended}->{action} eq 'skip') { # TODO: replace with "protect", "keep" | 
            
              | 3757 |                 push @merged_record_fields, @{$current_fields->{$tag}}; | 
            
              | 3758 |             } | 
            
              | 3759 |             elsif ($rule->{on_appended}->{action} eq 'append') { | 
            
              | 3760 |                 push @merged_record_fields, @{$incoming_fields->{$tag}}; | 
            
              | 3761 |             } | 
            
              | 3762 |             if ( | 
            
              | 3763 |                 $rule->{on_appended}->{action} eq 'append' && | 
            
              | 3764 |                 $rule->{on_removed}->{action} eq 'skip' | 
            
              | 3765 |             ) { | 
            
              | 3766 |                 #TODO: This is an invalid combination for control fields, warn!! | 
            
              | 3767 |                 # Or should perform client/server side validation to prevent this choice | 
            
              | 3768 |             } | 
            
              | 3769 |         } | 
            
              | 3770 |         else { | 
            
              | 3771 |             # Compute intersection and diff using field data | 
            
              | 3772 |             my %current_fields_by_data = map { $hash_field_data->($_) => $_ } @{$current_fields->{$tag}}; | 
            
              | 3773 |             my %incoming_fields_by_data = map { $hash_field_data->($_) => $_ } @{$incoming_fields->{$tag}}; | 
            
              | 3774 |             my ($current_fields_only, $common_fields, $incoming_fields_only) = $diff_by_key->(\%current_fields_by_data, \%incoming_fields_by_data); | 
            
              | 3775 |  | 
            
              | 3776 |             # First add common fields (intersection) | 
            
              | 3777 |             # Unchanged | 
            
              | 3778 |             if (@{$common_fields}) { | 
            
              | 3779 |                 push @merged_record_fields, @{$common_fields}; | 
            
              | 3780 |             } | 
            
              | 3781 |             # Removed | 
            
              | 3782 |             if (@{$current_fields_only}) { | 
            
              | 3783 |                 if ($rule->{on_removed}->{action} eq 'skip') { | 
            
              | 3784 |                     push @merged_record_fields, @{$current_fields_only}; | 
            
              | 3785 |                 } | 
            
              | 3786 |             } | 
            
              | 3787 |             # Appended | 
            
              | 3788 |             if (@{$incoming_fields_only}) { | 
            
              | 3789 |                 if ($rule->{on_appended}->{action} eq 'append') { | 
            
              | 3790 |                     push @merged_record_fields, @{$incoming_fields_only}; | 
            
              | 3791 |                 } | 
            
              | 3792 |             } | 
            
              | 3793 |         } | 
            
              | 3794 |     } | 
            
              | 3795 |     if ($#merged_record_fields != 0) { | 
            
              | 3796 |         $merged_record->insert_fields_ordered(@merged_record_fields); | 
            
              | 3797 |     } | 
            
              | 3798 |     return $merged_record; | 
            
              | 3799 | } | 
            
              | 3800 |  | 
            
              | 3801 | =head2 GetMarcPermissions | 
            
              | 3802 |  | 
            
              | 3803 |     my $marc_permissions = GetMarcPermissions() | 
            
              | 3804 |  | 
            
              | 3805 | Loads MARC field permissions from the marc_permissions table. | 
            
              | 3806 |  | 
            
              | 3807 | Returns: | 
            
              | 3808 |  | 
            
              | 3809 | =over 4 | 
            
              | 3810 |  | 
            
              | 3811 | =item C<$marc_permissions> | 
            
              | 3812 |  | 
            
              | 3813 | hashref with permissions structure for use with GetMarcPermissionsAction. | 
            
              | 3814 |  | 
            
              | 3815 | =back | 
            
              | 3816 |  | 
            
              | 3817 | =cut | 
            
              | 3818 |  | 
            
              | 3819 | sub GetMarcPermissions { | 
            
              | 3820 |     my ($filter) = @_; | 
            
              | 3821 |     my $dbh = C4::Context->dbh; | 
            
              | 3822 |     my $rule_count = 0; | 
            
              | 3823 |     my $modules = GetMarcPermissionsModules(); | 
            
              | 3824 |     # We only care about modules included in the context/filter | 
            
              | 3825 |     # TODO: Perhaps make sure source => '*' is default? | 
            
              | 3826 |     my @filter_modules = grep { exists $filter->{$_->{name}} } @{$modules}; | 
            
              | 3827 |  | 
            
              | 3828 |     my $cache = Koha::Caches->get_instance(); | 
            
              | 3829 |     my $permissions = $cache->get_from_cache('marc_permissions', { unsafe => 1 }); | 
            
              | 3830 |  | 
            
              | 3831 |     if (!$permissions) { | 
            
              | 3832 |         my $query = ' | 
            
              | 3833 |             SELECT `marc_permissions`.*, | 
            
              | 3834 |                 `marc_permissions_modules`.`name`, | 
            
              | 3835 |                 `marc_permissions_modules`.`description`, | 
            
              | 3836 |                 `marc_permissions_modules`.`specificity` | 
            
              | 3837 |                 FROM `marc_permissions` | 
            
              | 3838 |                 LEFT JOIN `marc_permissions_modules` ON `module` = `marc_permissions_modules`.`id` | 
            
              | 3839 |                 ORDER BY `marc_permissions_modules`.`specificity`, `id` | 
            
              | 3840 |         '; | 
            
              | 3841 |         my $sth = $dbh->prepare($query); | 
            
              | 3842 |         $sth->execute(); | 
            
              | 3843 |         while (my $perm = $sth->fetchrow_hashref) { | 
            
              | 3844 |             my $target = ($permissions->{$perm->{name}}->{$perm->{filter}}->{$perm->{tagfield}} //= {}); | 
            
              | 3845 |             foreach my $event (GetMarcPermissionEvents()) { | 
            
              | 3846 |                 $target->{$event} = { action => $perm->{$event}, rule => $perm->{'id'} }; | 
            
              | 3847 |             } | 
            
              | 3848 |         } | 
            
              | 3849 |         $cache->set_in_cache('marc_permissions', $permissions); | 
            
              | 3850 |     } | 
            
              | 3851 |  | 
            
              | 3852 |     my $filtered_permissions = undef; | 
            
              | 3853 |     foreach my $module (@filter_modules) { | 
            
              | 3854 |         if ( | 
            
              | 3855 |             exists $permissions->{$module->{name}} && | 
            
              | 3856 |             exists $permissions->{$module->{name}}->{$filter->{$module->{name}}} | 
            
              | 3857 |         ) { | 
            
              | 3858 |             # TODO: Support multiple overlapping filters/context?? | 
            
              | 3859 |             $filtered_permissions = $permissions->{$module->{name}}->{$filter->{$module->{name}}}; | 
            
              | 3860 |             last; | 
            
              | 3861 |         } | 
            
              | 3862 |     } | 
            
              | 3863 |     if (!$filtered_permissions) { | 
            
              | 3864 |         # No perms matching specific context conditions found, try wildcard value for each active context | 
            
              | 3865 |         foreach my $module (@filter_modules) { | 
            
              | 3866 |             if (exists $permissions->{$module->{name}}->{'*'}) { | 
            
              | 3867 |                 $filtered_permissions = $permissions->{$module->{name}}->{'*'}; | 
            
              | 3868 |                 last; | 
            
              | 3869 |             } | 
            
              | 3870 |         } | 
            
              | 3871 |     } | 
            
              | 3872 |     return $filtered_permissions; | 
            
              | 3873 | } | 
            
              | 3874 |  | 
            
              | 3875 | # TODO: Use this in GetMarcPermissions | 
            
              | 3876 | =head2 GetMarcPermissionsRules | 
            
              | 3877 |  | 
            
              | 3878 |     my $rules = GetMarcPermissionsRules() | 
            
              | 3879 |  | 
            
              | 3880 | Returns: | 
            
              | 3881 |  | 
            
              | 3882 | =over 4 | 
            
              | 3883 |  | 
            
              | 3884 | =item C<$rules> | 
            
              | 3885 |  | 
            
              | 3886 | array (in list context, arrayref otherwise) of hashrefs from marc_permissions | 
            
              | 3887 | table in order of module specificity and rule id. | 
            
              | 3888 |  | 
            
              | 3889 | =back | 
            
              | 3890 |  | 
            
              | 3891 | =cut | 
            
              | 3892 |  | 
            
              | 3893 | sub GetMarcPermissionsRules { | 
            
              | 3894 |     my $dbh = C4::Context->dbh; | 
            
              | 3895 |     my @rules = (); | 
            
              | 3896 |  | 
            
              | 3897 |     my $query = ' | 
            
              | 3898 |     SELECT `marc_permissions`.`id`, | 
            
              | 3899 |            `marc_permissions`.`tagfield`, | 
            
              | 3900 |            `marc_permissions`.`filter`, | 
            
              | 3901 |            `marc_permissions`.`on_new`, | 
            
              | 3902 |            `marc_permissions`.`on_appended`, | 
            
              | 3903 |            `marc_permissions`.`on_removed`, | 
            
              | 3904 |            `marc_permissions`.`on_deleted`, | 
            
              | 3905 |            `marc_permissions_modules`.`name` as  `module`, | 
            
              | 3906 |            `marc_permissions_modules`.`description`, | 
            
              | 3907 |            `marc_permissions_modules`.`specificity` | 
            
              | 3908 |     FROM `marc_permissions` | 
            
              | 3909 |     LEFT JOIN `marc_permissions_modules` ON `module` = `marc_permissions_modules`.`id` | 
            
              | 3910 |     ORDER BY `marc_permissions_modules`.`specificity`, `id` | 
            
              | 3911 |     '; | 
            
              | 3912 |     my $sth = $dbh->prepare($query); | 
            
              | 3913 |     $sth->execute(); | 
            
              | 3914 |     while ( my $row = $sth->fetchrow_hashref ) { | 
            
              | 3915 |         push(@rules, $row); | 
            
              | 3916 |     } | 
            
              | 3917 |  | 
            
              | 3918 |     return wantarray ? @rules : \@rules; | 
            
              | 3919 | } | 
            
              | 3920 |  | 
            
              | 3921 | =head2 GetMarcPermissionsModules | 
            
              | 3922 |  | 
            
              | 3923 |     my $modules = GetMarcPermissionsModules() | 
            
              | 3924 |  | 
            
              | 3925 | Returns: | 
            
              | 3926 |  | 
            
              | 3927 | =over 4 | 
            
              | 3928 |  | 
            
              | 3929 | =item C<$modules> | 
            
              | 3930 |  | 
            
              | 3931 | array (in list context, arrayref otherwise) of hashrefs from | 
            
              | 3932 | marc_permissions_modules table in order of specificity. | 
            
              | 3933 |  | 
            
              | 3934 | =back | 
            
              | 3935 |  | 
            
              | 3936 | =cut | 
            
              | 3937 |  | 
            
              | 3938 | sub GetMarcPermissionsModules { | 
            
              | 3939 |     my $dbh = C4::Context->dbh; | 
            
              | 3940 |     my @modules = (); | 
            
              | 3941 |  | 
            
              | 3942 |     my $query = ' | 
            
              | 3943 |     SELECT * | 
            
              | 3944 |     FROM `marc_permissions_modules` | 
            
              | 3945 |     ORDER BY `specificity` DESC | 
            
              | 3946 |     '; | 
            
              | 3947 |     my $sth = $dbh->prepare($query); | 
            
              | 3948 |     $sth->execute(); | 
            
              | 3949 |     while ( my $row = $sth->fetchrow_hashref ) { | 
            
              | 3950 |         push(@modules, $row); | 
            
              | 3951 |     } | 
            
              | 3952 |  | 
            
              | 3953 |     return wantarray ? @modules : \@modules; | 
            
              | 3954 | } | 
            
              | 3955 |  | 
            
              | 3956 | sub GetMarcPermissionEvents { | 
            
              | 3957 |     return ('on_new', 'on_appended', 'on_removed', 'on_deleted'); | 
            
              | 3958 | } | 
            
              | 3959 |  | 
            
              | 3960 | =head2 ModMarcPermissionsRule | 
            
              | 3961 |  | 
            
              | 3962 |     my $success = ModMarcPermissionsRule($id, $fields) | 
            
              | 3963 |  | 
            
              | 3964 | Modifies rule in the marc_permissions table. | 
            
              | 3965 |  | 
            
              | 3966 | =over 4 | 
            
              | 3967 |  | 
            
              | 3968 | =item C<$id> | 
            
              | 3969 |  | 
            
              | 3970 | rule id to modify | 
            
              | 3971 |  | 
            
              | 3972 | =item C<$fields> | 
            
              | 3973 |  | 
            
              | 3974 | hashref defining the table fields | 
            
              | 3975 |  | 
            
              | 3976 |       * tagfield - required | 
            
              | 3977 |       * module - required | 
            
              | 3978 |       * filter - required | 
            
              | 3979 |       * on_new - required | 
            
              | 3980 |       * on_appended - required | 
            
              | 3981 |       * on_removed - required | 
            
              | 3982 |       * on_deleted - required | 
            
              | 3983 |  | 
            
              | 3984 | =back | 
            
              | 3985 |  | 
            
              | 3986 | Returns: | 
            
              | 3987 |  | 
            
              | 3988 | =over 4 | 
            
              | 3989 |  | 
            
              | 3990 | =item C<$success> | 
            
              | 3991 |  | 
            
              | 3992 | undef if an error occurs, otherwise true. | 
            
              | 3993 |  | 
            
              | 3994 | =back | 
        
          | 3537 |  | 3995 |  | 
            
              |  |  | 3996 | =cut | 
            
              | 3997 |  | 
            
              | 3998 | sub ModMarcPermissionsRule { | 
            
              | 3999 |     my ($id, $f) = @_; | 
            
              | 4000 |     my $dbh = C4::Context->dbh; | 
            
              | 4001 |  | 
            
              | 4002 |     my $query = ' | 
            
              | 4003 |     UPDATE `marc_permissions` | 
            
              | 4004 |     SET | 
            
              | 4005 |       tagfield = ?, | 
            
              | 4006 |       module = ?, | 
            
              | 4007 |       filter = ?, | 
            
              | 4008 |       on_new = ?, | 
            
              | 4009 |       on_appended = ?, | 
            
              | 4010 |       on_removed = ?, | 
            
              | 4011 |       on_deleted = ? | 
            
              | 4012 |     WHERE | 
            
              | 4013 |       id = ? | 
            
              | 4014 |     '; | 
            
              | 4015 |     my $sth = $dbh->prepare($query); | 
            
              | 4016 |     my $result = $sth->execute ( | 
            
              | 4017 |         $f->{tagfield}, | 
            
              | 4018 |         $f->{module}, | 
            
              | 4019 |         $f->{filter}, | 
            
              | 4020 |         $f->{on_new}, | 
            
              | 4021 |         $f->{on_appended}, | 
            
              | 4022 |         $f->{on_removed}, | 
            
              | 4023 |         $f->{on_deleted}, | 
            
              | 4024 |         $id | 
            
              | 4025 |     ); | 
            
              | 4026 |     ClearMarcPermissionsRulesCache(); | 
            
              | 4027 |     return $result; | 
            
              | 4028 | } | 
            
              | 4029 |  | 
            
              | 4030 | sub ClearMarcPermissionsRulesCache { | 
            
              | 4031 |     my $cache = Koha::Caches->get_instance(); | 
            
              | 4032 |     $cache->clear_from_cache('marc_permissions'); | 
            
              | 4033 | } | 
            
              | 4034 |  | 
            
              | 4035 | =head2 AddMarcPermissionsRule | 
            
              | 4036 |  | 
            
              | 4037 |     my $success = AddMarcPermissionsRule($fields) | 
            
              | 4038 |  | 
            
              | 4039 | Add rule to the marc_permissions table. | 
            
              | 4040 |  | 
            
              | 4041 | =over 4 | 
            
              | 4042 |  | 
            
              | 4043 | =item C<$fields> | 
            
              | 4044 |  | 
            
              | 4045 | hashref defining the table fields | 
            
              | 4046 |  | 
            
              | 4047 |       tagfield - required | 
            
              | 4048 |       module - required | 
            
              | 4049 |       filter - required | 
            
              | 4050 |       on_new - required | 
            
              | 4051 |       on_appended - required | 
            
              | 4052 |       on_removed - required | 
            
              | 4053 |       on_deleted - required | 
            
              | 4054 |  | 
            
              | 4055 | =back | 
            
              | 4056 |  | 
            
              | 4057 | Returns: | 
            
              | 4058 |  | 
            
              | 4059 | =over 4 | 
            
              | 4060 |  | 
            
              | 4061 | =item C<$success> | 
            
              | 4062 |  | 
            
              | 4063 | undef if an error occurs, otherwise true. | 
            
              | 4064 |  | 
            
              | 4065 | =back | 
            
              | 4066 |  | 
            
              | 4067 | =cut | 
            
              | 4068 |  | 
            
              | 4069 | sub AddMarcPermissionsRule { | 
            
              | 4070 |     my $f = shift; | 
            
              | 4071 |     my $dbh = C4::Context->dbh; | 
            
              | 4072 |     my $query = ' | 
            
              | 4073 |     INSERT INTO `marc_permissions` | 
            
              | 4074 |     ( | 
            
              | 4075 |       tagfield, | 
            
              | 4076 |       module, | 
            
              | 4077 |       filter, | 
            
              | 4078 |       on_new, | 
            
              | 4079 |       on_appended, | 
            
              | 4080 |       on_removed, | 
            
              | 4081 |       on_deleted | 
            
              | 4082 |     ) | 
            
              | 4083 |     VALUES (?, ?, ?, ?, ?, ?, ?) | 
            
              | 4084 |     '; | 
            
              | 4085 |     my $sth = $dbh->prepare($query); | 
            
              | 4086 |     my $result = $sth->execute ( | 
            
              | 4087 |         $f->{tagfield}, | 
            
              | 4088 |         $f->{module}, | 
            
              | 4089 |         $f->{filter}, | 
            
              | 4090 |         $f->{on_new}, | 
            
              | 4091 |         $f->{on_appended}, | 
            
              | 4092 |         $f->{on_removed}, | 
            
              | 4093 |         $f->{on_deleted} | 
            
              | 4094 |     ); | 
            
              | 4095 |     ClearMarcPermissionsRulesCache(); | 
            
              | 4096 |     return $result; | 
            
              | 4097 | } | 
            
              | 4098 |  | 
            
              | 4099 | =head2 DelMarcPermissionsRule | 
            
              | 4100 |  | 
            
              | 4101 |     my $success = DelMarcPermissionsRule($id) | 
            
              | 4102 |  | 
            
              | 4103 | Deletes rule from the marc_permissions table. | 
            
              | 4104 |  | 
            
              | 4105 | =over 4 | 
            
              | 4106 |  | 
            
              | 4107 | =item C<$id> | 
            
              | 4108 |  | 
            
              | 4109 | rule id to delete | 
            
              | 4110 |  | 
            
              | 4111 | =back | 
            
              | 4112 |  | 
            
              | 4113 | Returns: | 
            
              | 4114 |  | 
            
              | 4115 | =over 4 | 
            
              | 4116 |  | 
            
              | 4117 | =item C<$success> | 
            
              | 4118 |  | 
            
              | 4119 | undef if an error occurs, otherwise true. | 
            
              | 4120 |  | 
            
              | 4121 | =back | 
            
              | 4122 |  | 
            
              | 4123 | =cut | 
            
              | 4124 |  | 
            
              | 4125 | sub DelMarcPermissionsRule { | 
            
              | 4126 |     my $id = shift; | 
            
              | 4127 |     my $dbh = C4::Context->dbh; | 
            
              | 4128 |     my $query = ' | 
            
              | 4129 |     DELETE FROM `marc_permissions` | 
            
              | 4130 |     WHERE | 
            
              | 4131 |       id = ? | 
            
              | 4132 |     '; | 
            
              | 4133 |     my $sth = $dbh->prepare($query); | 
            
              | 4134 |     my $result = $sth->execute($id); | 
            
              | 4135 |     ClearMarcPermissionsRulesCache(); | 
            
              | 4136 |     return $result; | 
            
              | 4137 | } | 
            
              | 4138 | 1; | 
        
          | 3538 |  | 4139 |  | 
        
          | 3539 | __END__ | 4140 | __END__ | 
        
          | 3540 |  | 4141 |  |