| 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 2544-2550
          sub TransformHtmlToMarc {
      
      
        Link Here | 
        
          | 2544 |  | 2563 |  | 
        
          | 2545 | =head2 TransformMarcToKoha | 2564 | =head2 TransformMarcToKoha | 
        
          | 2546 |  | 2565 |  | 
          
            
              | 2547 |     $result = TransformMarcToKoha( $record, undef, $limit ) | 2566 |     $result = TransformMarcToKoha($record, undef, $biblionumber, $option) | 
        
          | 2548 |  | 2567 |  | 
        
          | 2549 | Extract data from a MARC bib record into a hashref representing | 2568 | Extract data from a MARC bib record into a hashref representing | 
        
          | 2550 | Koha biblio, biblioitems, and items fields. | 2569 | Koha biblio, biblioitems, and items fields. | 
  
    | Lines 2555-2561
          hash_ref.
      
      
        Link Here | 
        
          | 2555 | =cut | 2574 | =cut | 
        
          | 2556 |  | 2575 |  | 
        
          | 2557 | sub TransformMarcToKoha { | 2576 | sub TransformMarcToKoha { | 
          
            
              | 2558 |     my ( $record, $frameworkcode, $limit_table ) = @_; | 2577 |     my ( $record, $frameworkcode, $limit_table, $biblionumber ) = @_; | 
        
          | 2559 |     # FIXME  Parameter $frameworkcode is obsolete and will be removed | 2578 |     # FIXME  Parameter $frameworkcode is obsolete and will be removed | 
        
          | 2560 |     $limit_table //= q{}; | 2579 |     $limit_table //= q{}; | 
        
          | 2561 |  | 2580 |  | 
  
    | Lines 3242-3248
          sub _koha_delete_biblio_metadata {
      
      
        Link Here | 
        
          | 3242 |  | 3261 |  | 
        
          | 3243 | =head2 ModBiblioMarc | 3262 | =head2 ModBiblioMarc | 
        
          | 3244 |  | 3263 |  | 
          
            
              | 3245 |   &ModBiblioMarc($newrec,$biblionumber,$frameworkcode); | 3264 |   &ModBiblioMarc($newrec, $biblionumber, $frameworkcode, $options); | 
        
          | 3246 |  | 3265 |  | 
        
          | 3247 | Add MARC XML data for a biblio to koha | 3266 | Add MARC XML data for a biblio to koha | 
        
          | 3248 |  | 3267 |  | 
  
    | Lines 3569-3576
          sub RemoveAllNsb {
      
      
        Link Here | 
        
          | 3569 |     return $record; | 3588 |     return $record; | 
        
          | 3570 | } | 3589 | } | 
        
          | 3571 |  | 3590 |  | 
          
            
              | 3572 | 1; | 3591 | =head2 ApplyMarcPermissions | 
            
              |  |  | 3592 |  | 
            
              | 3593 |     my $record = ApplyMarcPermissions($arguments) | 
            
              | 3594 |  | 
            
              | 3595 | Applies marc permission rules to a record. | 
            
              | 3596 |  | 
            
              | 3597 | C<$arguments> is expected to be a hashref with below keys defined. | 
            
              | 3598 |  | 
            
              | 3599 | =over 4 | 
            
              | 3600 |  | 
            
              | 3601 | =item C<biblionumber> | 
            
              | 3602 | biblionumber of old record | 
            
              | 3603 |  | 
            
              | 3604 | =item C<record> | 
            
              | 3605 | record that will modify old record | 
            
              | 3606 |  | 
            
              | 3607 | =item C<frameworkcode> | 
            
              | 3608 | only tags included in framework will be processed | 
            
              | 3609 |  | 
            
              | 3610 | =item C<filter> | 
            
              | 3611 | hashref containing at least one filter module from the marc_permissions_modules | 
            
              | 3612 | table in form {module => filter}. Three predefined filter modules exists: | 
            
              | 3613 |  | 
            
              | 3614 |     * source | 
            
              | 3615 |     * category | 
            
              | 3616 |     * borrower | 
            
              | 3617 |  | 
            
              | 3618 | =item C<log> | 
            
              | 3619 | optional reference to array that will be filled with rule evaluation log | 
            
              | 3620 | entries. | 
            
              | 3621 |  | 
            
              | 3622 | =item C<nolog> | 
            
              | 3623 | optional boolean which when true disables logging to action log. | 
            
              | 3624 |  | 
            
              | 3625 | =back | 
            
              | 3626 |  | 
            
              | 3627 | Returns: | 
            
              | 3628 |  | 
            
              | 3629 | =over 4 | 
            
              | 3630 |  | 
            
              | 3631 | =item C<$record> | 
            
              | 3632 |  | 
            
              | 3633 | new MARC record based on C<record> with C<filter> applied. If no old | 
            
              | 3634 | record for C<biblionumber> can be found, C<record> is returned unchanged. | 
            
              | 3635 | Default action when no matching filter found is to leave old record unchanged. | 
            
              | 3636 |  | 
            
              | 3637 | =back | 
            
              | 3638 |  | 
            
              | 3639 | =cut | 
            
              | 3640 |  | 
            
              | 3641 | sub ApplyMarcPermissions { | 
            
              | 3642 |     my ($arguments) = @_; | 
            
              | 3643 |     my $biblionumber = $arguments->{biblionumber}; | 
            
              | 3644 |     my $incoming_record = $arguments->{record}; | 
            
              | 3645 |  | 
            
              | 3646 |     if ( !$biblionumber ) { | 
            
              | 3647 |         carp 'ApplyMarcPermissions called on undefined biblionumber'; | 
            
              | 3648 |         return; | 
            
              | 3649 |     } | 
            
              | 3650 |     if ( !$incoming_record ) { | 
            
              | 3651 |         carp 'ApplyMarcPermissions called on undefined record'; | 
            
              | 3652 |         return; | 
            
              | 3653 |     } | 
            
              | 3654 |     my $old_record = GetMarcBiblio({ biblionumber => $biblionumber }); | 
            
              | 3655 |  | 
            
              | 3656 |     my $merge_rules = undef; | 
            
              | 3657 |     if ($old_record && $arguments->{filter} && ($merge_rules = GetMarcPermissions($arguments->{filter}))) { | 
            
              | 3658 |         return MergeRecords($old_record, $incoming_record, $merge_rules); | 
            
              | 3659 |     } | 
            
              | 3660 |     return $incoming_record; | 
            
              | 3661 | } | 
            
              | 3662 |  | 
            
              | 3663 | sub MergeRecords { | 
            
              | 3664 |     my ($old_record, $incoming_record, $merge_rules) = @_; | 
            
              | 3665 |     my $is_matching_regex = sub { | 
            
              | 3666 |         my ( $tag, $m ) = @_; | 
            
              | 3667 |  | 
            
              | 3668 |         # tag is not exactly same as possible regex | 
            
              | 3669 |         $tag ne $m && | 
            
              | 3670 |  | 
            
              | 3671 |         # wildcard | 
            
              | 3672 |         $m ne '*' && | 
            
              | 3673 |  | 
            
              | 3674 |         # valid tagDataType | 
            
              | 3675 |         $m !~ /^(0[1-9A-z][\dA-Z]) | | 
            
              | 3676 |         ([1-9A-z][\dA-z]{2})$/x && | 
            
              | 3677 |  | 
            
              | 3678 |         # nor valid controltagDataType | 
            
              | 3679 |         $m !~ /00[1-9A-Za-z]{1}/ && | 
            
              | 3680 |  | 
            
              | 3681 |         # so we try it as a regex | 
            
              | 3682 |         $tag =~ /^$m$/ | 
            
              | 3683 |     }; | 
            
              | 3684 |  | 
            
              | 3685 |     my $fields_by_tag = sub { | 
            
              | 3686 |         my ($record) = @_; | 
            
              | 3687 |         my $fields = {}; | 
            
              | 3688 |         foreach my $field ($record->fields()) { | 
            
              | 3689 |             $fields->{$field->tag()} //= []; | 
            
              | 3690 |             push @{$fields->{$field->tag()}}, $field; | 
            
              | 3691 |         } | 
            
              | 3692 |         return $fields; | 
            
              | 3693 |     }; | 
            
              | 3694 |  | 
            
              | 3695 |     my $hash_field_data = sub { | 
            
              | 3696 |         my ($field) = @_; | 
            
              | 3697 |         my $indicators = join("\x1E", map { $field->indicator($_) } (1, 2)); | 
            
              | 3698 |         return $indicators . "\x1E" . join("\x1E", sort map { join "\x1E", @{$_} } $field->subfields()); | 
            
              | 3699 |     }; | 
            
              | 3700 |  | 
            
              | 3701 |     my $diff_by_key = sub { | 
            
              | 3702 |         my ($a, $b) = @_; | 
            
              | 3703 |         my @removed; | 
            
              | 3704 |         my @intersecting; | 
            
              | 3705 |         my @added; | 
            
              | 3706 |         my %keys_index = map { $_ => undef } (keys %{$a}, keys %{$b}); | 
            
              | 3707 |         foreach my $key (keys %keys_index) { | 
            
              | 3708 |             if ($a->{$key} && $b->{$key}) { | 
            
              | 3709 |                 push @intersecting, $a->{$key}; | 
            
              | 3710 |             } | 
            
              | 3711 |             elsif ($a->{$key}) { | 
            
              | 3712 |                 push @removed, $a->{$key}; | 
            
              | 3713 |             } | 
            
              | 3714 |             else { | 
            
              | 3715 |                 push @added, $b->{$key}; | 
            
              | 3716 |             } | 
            
              | 3717 |         } | 
            
              | 3718 |         return (\@removed, \@intersecting, \@added); | 
            
              | 3719 |     }; | 
            
              | 3720 |  | 
            
              | 3721 |     my $get_matching_field_rule = sub { | 
            
              | 3722 |         my ($tag) = @_; | 
            
              | 3723 |         my $matched_rule = undef; | 
            
              | 3724 |         # Exact match takes precedence | 
            
              | 3725 |         if (exists $merge_rules->{$tag}) { | 
            
              | 3726 |             $matched_rule = $merge_rules->{$tag}; | 
            
              | 3727 |         } | 
            
              | 3728 |         else { | 
            
              | 3729 |             # TODO: sorty by module/weight rule id or something, grab first matching via listutils thingy | 
            
              | 3730 |             my @matching_rules = map { $merge_rules->{$_} } grep { $is_matching_regex->($tag, $_) } sort keys %{$merge_rules}; | 
            
              | 3731 |             # TODO: fix | 
            
              | 3732 |             if (@matching_rules) { | 
            
              | 3733 |                 $matched_rule = pop @matching_rules; | 
            
              | 3734 |             } | 
            
              | 3735 |             elsif($merge_rules->{'*'}) { | 
            
              | 3736 |                 $matched_rule = $merge_rules->{'*'}; | 
            
              | 3737 |             } | 
            
              | 3738 |         } | 
            
              | 3739 |         return $matched_rule; | 
            
              | 3740 |     }; | 
            
              | 3741 |  | 
            
              | 3742 |     my $merged_record = MARC::Record->new(); | 
            
              | 3743 |     my @merged_record_fields; | 
            
              | 3744 |  | 
            
              | 3745 |     # Leader is always overwritten, or kept??? | 
            
              | 3746 |     $merged_record->leader($incoming_record->leader()); | 
            
              | 3747 |  | 
            
              | 3748 |     my $current_fields = $fields_by_tag->($old_record); | 
            
              | 3749 |     my $incoming_fields = $fields_by_tag->($incoming_record); | 
            
              | 3750 |  | 
            
              | 3751 |     # First we get all new incoming control fields | 
            
              | 3752 |     my @new_field_tags = grep { !(exists $current_fields->{$_}) } keys %{$incoming_fields}; | 
            
              | 3753 |  | 
            
              | 3754 |     foreach my $tag (@new_field_tags) { | 
            
              | 3755 |         my $rule = $get_matching_field_rule->($tag) // { | 
            
              | 3756 |             on_new => {'action' => 'skip', 'rule' => 0} | 
            
              | 3757 |         }; | 
            
              | 3758 |         if ( | 
            
              | 3759 |             $rule->{on_new}->{action} eq 'add' || | 
            
              | 3760 |             $rule->{on_new}->{action} eq 'overwrite' # ??? | 
            
              | 3761 |         ) { # Or could just be write/protect? | 
            
              | 3762 |             # Hmm, only one control field possible?? | 
            
              | 3763 |             push @merged_record_fields, @{$incoming_fields->{$tag}}; | 
            
              | 3764 |         } | 
            
              | 3765 |     } | 
            
              | 3766 |  | 
            
              | 3767 |     # Then we get all control fields no longer present in incoming fields | 
            
              | 3768 |     # (removed) | 
            
              | 3769 |     my @deleted_field_tags = grep { !(exists $incoming_fields->{$_}) } keys %{$current_fields}; | 
            
              | 3770 |     foreach my $tag (@deleted_field_tags) { | 
            
              | 3771 |         my $rule = $get_matching_field_rule->($tag) // { | 
            
              | 3772 |             on_deleted => {'action' => 'skip', 'rule' => 0} | 
            
              | 3773 |         }; | 
            
              | 3774 |         if ($rule->{on_deleted}->{action} eq 'skip') { | 
            
              | 3775 |             push @merged_record_fields, @{$current_fields->{$tag}}; | 
            
              | 3776 |         } | 
            
              | 3777 |     } | 
            
              | 3778 |  | 
            
              | 3779 |     # Then we get the intersection of control fields, present both in | 
            
              | 3780 |     # current and incoming record (possibly to be overwritten) | 
            
              | 3781 |     my @common_field_tags = grep { exists $incoming_fields->{$_} } keys %{$current_fields}; | 
            
              | 3782 |     foreach my $tag (@common_field_tags) { | 
            
              | 3783 |         # Is control field | 
            
              | 3784 |         my $rule = $get_matching_field_rule->($tag) // { | 
            
              | 3785 |             on_removed => {'action' => 'skip', 'rule' => 0}, | 
            
              | 3786 |             on_appended => {'action' => 'skip', 'rule' => 0} | 
            
              | 3787 |         }; | 
            
              | 3788 |         if ($tag < 10) { | 
            
              | 3789 |             # on_existing = on_match | 
            
              | 3790 |             if ($rule->{on_appended}->{action} eq 'skip') { # TODO: replace with "protect", "keep" | 
            
              | 3791 |                 push @merged_record_fields, @{$current_fields->{$tag}}; | 
            
              | 3792 |             } | 
            
              | 3793 |             elsif ($rule->{on_appended}->{action} eq 'append') { | 
            
              | 3794 |                 push @merged_record_fields, @{$incoming_fields->{$tag}}; | 
            
              | 3795 |             } | 
            
              | 3796 |             if ( | 
            
              | 3797 |                 $rule->{on_appended}->{action} eq 'append' && | 
            
              | 3798 |                 $rule->{on_removed}->{action} eq 'skip' | 
            
              | 3799 |             ) { | 
            
              | 3800 |                 #TODO: This is an invalid combination for control fields, warn!! | 
            
              | 3801 |                 # Or should perform client/server side validation to prevent this choice | 
            
              | 3802 |             } | 
            
              | 3803 |         } | 
            
              | 3804 |         else { | 
            
              | 3805 |             # Compute intersection and diff using field data | 
            
              | 3806 |             my %current_fields_by_data = map { $hash_field_data->($_) => $_ } @{$current_fields->{$tag}}; | 
            
              | 3807 |             my %incoming_fields_by_data = map { $hash_field_data->($_) => $_ } @{$incoming_fields->{$tag}}; | 
            
              | 3808 |             my ($current_fields_only, $common_fields, $incoming_fields_only) = $diff_by_key->(\%current_fields_by_data, \%incoming_fields_by_data); | 
            
              | 3809 |  | 
            
              | 3810 |             # First add common fields (intersection) | 
            
              | 3811 |             # Unchanged | 
            
              | 3812 |             if (@{$common_fields}) { | 
            
              | 3813 |                 push @merged_record_fields, @{$common_fields}; | 
            
              | 3814 |             } | 
            
              | 3815 |             # Removed | 
            
              | 3816 |             if (@{$current_fields_only}) { | 
            
              | 3817 |                 if ($rule->{on_removed}->{action} eq 'skip') { | 
            
              | 3818 |                     push @merged_record_fields, @{$current_fields_only}; | 
            
              | 3819 |                 } | 
            
              | 3820 |             } | 
            
              | 3821 |             # Appended | 
            
              | 3822 |             if (@{$incoming_fields_only}) { | 
            
              | 3823 |                 if ($rule->{on_appended}->{action} eq 'append') { | 
            
              | 3824 |                     push @merged_record_fields, @{$incoming_fields_only}; | 
            
              | 3825 |                 } | 
            
              | 3826 |             } | 
            
              | 3827 |         } | 
            
              | 3828 |     } | 
            
              | 3829 |     if ($#merged_record_fields != 0) { | 
            
              | 3830 |         $merged_record->insert_fields_ordered(@merged_record_fields); | 
            
              | 3831 |     } | 
            
              | 3832 |     return $merged_record; | 
            
              | 3833 | } | 
            
              | 3834 |  | 
            
              | 3835 | =head2 GetMarcPermissions | 
            
              | 3836 |  | 
            
              | 3837 |     my $marc_permissions = GetMarcPermissions() | 
            
              | 3838 |  | 
            
              | 3839 | Loads MARC field permissions from the marc_permissions table. | 
            
              | 3840 |  | 
            
              | 3841 | Returns: | 
            
              | 3842 |  | 
            
              | 3843 | =over 4 | 
            
              | 3844 |  | 
            
              | 3845 | =item C<$marc_permissions> | 
            
              | 3846 |  | 
            
              | 3847 | hashref with permissions structure for use with GetMarcPermissionsAction. | 
            
              | 3848 |  | 
            
              | 3849 | =back | 
            
              | 3850 |  | 
            
              | 3851 | =cut | 
            
              | 3852 |  | 
            
              | 3853 | sub GetMarcPermissions { | 
            
              | 3854 |     my ($filter) = @_; | 
            
              | 3855 |     my $dbh = C4::Context->dbh; | 
            
              | 3856 |     my $rule_count = 0; | 
            
              | 3857 |     my $modules = GetMarcPermissionsModules(); | 
            
              | 3858 |     # We only care about modules included in the context/filter | 
            
              | 3859 |     # TODO: Perhaps make sure source => '*' is default? | 
            
              | 3860 |     my @filter_modules = grep { exists $filter->{$_->{name}} } @{$modules}; | 
            
              | 3861 |  | 
            
              | 3862 |     my $cache = Koha::Caches->get_instance(); | 
            
              | 3863 |     my $permissions = $cache->get_from_cache('marc_permissions', { unsafe => 1 }); | 
            
              | 3864 |  | 
            
              | 3865 |     if (!$permissions) { | 
            
              | 3866 |         my $query = ' | 
            
              | 3867 |             SELECT `marc_permissions`.*, | 
            
              | 3868 |                 `marc_permissions_modules`.`name`, | 
            
              | 3869 |                 `marc_permissions_modules`.`description`, | 
            
              | 3870 |                 `marc_permissions_modules`.`specificity` | 
            
              | 3871 |                 FROM `marc_permissions` | 
            
              | 3872 |                 LEFT JOIN `marc_permissions_modules` ON `module` = `marc_permissions_modules`.`id` | 
            
              | 3873 |                 ORDER BY `marc_permissions_modules`.`specificity`, `id` | 
            
              | 3874 |         '; | 
            
              | 3875 |         my $sth = $dbh->prepare($query); | 
            
              | 3876 |         $sth->execute(); | 
            
              | 3877 |         while (my $perm = $sth->fetchrow_hashref) { | 
            
              | 3878 |             my $target = ($permissions->{$perm->{name}}->{$perm->{filter}}->{$perm->{tagfield}} //= {}); | 
            
              | 3879 |             foreach my $event (GetMarcPermissionEvents()) { | 
            
              | 3880 |                 $target->{$event} = { action => $perm->{$event}, rule => $perm->{'id'} }; | 
            
              | 3881 |             } | 
            
              | 3882 |         } | 
            
              | 3883 |         $cache->set_in_cache('marc_permissions', $permissions); | 
            
              | 3884 |     } | 
            
              | 3885 |  | 
            
              | 3886 |     my $filtered_permissions = undef; | 
            
              | 3887 |     foreach my $module (@filter_modules) { | 
            
              | 3888 |         if ( | 
            
              | 3889 |             exists $permissions->{$module->{name}} && | 
            
              | 3890 |             exists $permissions->{$module->{name}}->{$filter->{$module->{name}}} | 
            
              | 3891 |         ) { | 
            
              | 3892 |             # TODO: Support multiple overlapping filters/context?? | 
            
              | 3893 |             $filtered_permissions = $permissions->{$module->{name}}->{$filter->{$module->{name}}}; | 
            
              | 3894 |             last; | 
            
              | 3895 |         } | 
            
              | 3896 |     } | 
            
              | 3897 |     if (!$filtered_permissions) { | 
            
              | 3898 |         # No perms matching specific context conditions found, try wildcard value for each active context | 
            
              | 3899 |         foreach my $module (@filter_modules) { | 
            
              | 3900 |             if (exists $permissions->{$module->{name}}->{'*'}) { | 
            
              | 3901 |                 $filtered_permissions = $permissions->{$module->{name}}->{'*'}; | 
            
              | 3902 |                 last; | 
            
              | 3903 |             } | 
            
              | 3904 |         } | 
            
              | 3905 |     } | 
            
              | 3906 |     return $filtered_permissions; | 
            
              | 3907 | } | 
            
              | 3908 |  | 
            
              | 3909 | # TODO: Use this in GetMarcPermissions | 
            
              | 3910 | =head2 GetMarcPermissionsRules | 
            
              | 3911 |  | 
            
              | 3912 |     my $rules = GetMarcPermissionsRules() | 
            
              | 3913 |  | 
            
              | 3914 | Returns: | 
            
              | 3915 |  | 
            
              | 3916 | =over 4 | 
            
              | 3917 |  | 
            
              | 3918 | =item C<$rules> | 
            
              | 3919 |  | 
            
              | 3920 | array (in list context, arrayref otherwise) of hashrefs from marc_permissions | 
            
              | 3921 | table in order of module specificity and rule id. | 
            
              | 3922 |  | 
            
              | 3923 | =back | 
            
              | 3924 |  | 
            
              | 3925 | =cut | 
            
              | 3926 |  | 
            
              | 3927 | sub GetMarcPermissionsRules { | 
            
              | 3928 |     my $dbh = C4::Context->dbh; | 
            
              | 3929 |     my @rules = (); | 
            
              | 3930 |  | 
            
              | 3931 |     my $query = ' | 
            
              | 3932 |     SELECT `marc_permissions`.`id`, | 
            
              | 3933 |            `marc_permissions`.`tagfield`, | 
            
              | 3934 |            `marc_permissions`.`filter`, | 
            
              | 3935 |            `marc_permissions`.`on_new`, | 
            
              | 3936 |            `marc_permissions`.`on_appended`, | 
            
              | 3937 |            `marc_permissions`.`on_removed`, | 
            
              | 3938 |            `marc_permissions`.`on_deleted`, | 
            
              | 3939 |            `marc_permissions_modules`.`name` as  `module`, | 
            
              | 3940 |            `marc_permissions_modules`.`description`, | 
            
              | 3941 |            `marc_permissions_modules`.`specificity` | 
            
              | 3942 |     FROM `marc_permissions` | 
            
              | 3943 |     LEFT JOIN `marc_permissions_modules` ON `module` = `marc_permissions_modules`.`id` | 
            
              | 3944 |     ORDER BY `marc_permissions_modules`.`specificity`, `id` | 
            
              | 3945 |     '; | 
            
              | 3946 |     my $sth = $dbh->prepare($query); | 
            
              | 3947 |     $sth->execute(); | 
            
              | 3948 |     while ( my $row = $sth->fetchrow_hashref ) { | 
            
              | 3949 |         push(@rules, $row); | 
            
              | 3950 |     } | 
            
              | 3951 |  | 
            
              | 3952 |     return wantarray ? @rules : \@rules; | 
            
              | 3953 | } | 
            
              | 3954 |  | 
            
              | 3955 | =head2 GetMarcPermissionsModules | 
            
              | 3956 |  | 
            
              | 3957 |     my $modules = GetMarcPermissionsModules() | 
            
              | 3958 |  | 
            
              | 3959 | Returns: | 
            
              | 3960 |  | 
            
              | 3961 | =over 4 | 
            
              | 3962 |  | 
            
              | 3963 | =item C<$modules> | 
            
              | 3964 |  | 
            
              | 3965 | array (in list context, arrayref otherwise) of hashrefs from | 
            
              | 3966 | marc_permissions_modules table in order of specificity. | 
            
              | 3967 |  | 
            
              | 3968 | =back | 
            
              | 3969 |  | 
            
              | 3970 | =cut | 
        
          | 3573 |  | 3971 |  | 
            
              |  |  | 3972 | sub GetMarcPermissionsModules { | 
            
              | 3973 |     my $dbh = C4::Context->dbh; | 
            
              | 3974 |     my @modules = (); | 
            
              | 3975 |  | 
            
              | 3976 |     my $query = ' | 
            
              | 3977 |     SELECT * | 
            
              | 3978 |     FROM `marc_permissions_modules` | 
            
              | 3979 |     ORDER BY `specificity` DESC | 
            
              | 3980 |     '; | 
            
              | 3981 |     my $sth = $dbh->prepare($query); | 
            
              | 3982 |     $sth->execute(); | 
            
              | 3983 |     while ( my $row = $sth->fetchrow_hashref ) { | 
            
              | 3984 |         push(@modules, $row); | 
            
              | 3985 |     } | 
            
              | 3986 |  | 
            
              | 3987 |     return wantarray ? @modules : \@modules; | 
            
              | 3988 | } | 
            
              | 3989 |  | 
            
              | 3990 | sub GetMarcPermissionEvents { | 
            
              | 3991 |     return ('on_new', 'on_appended', 'on_removed', 'on_deleted'); | 
            
              | 3992 | } | 
            
              | 3993 |  | 
            
              | 3994 | =head2 ModMarcPermissionsRule | 
            
              | 3995 |  | 
            
              | 3996 |     my $success = ModMarcPermissionsRule($id, $fields) | 
            
              | 3997 |  | 
            
              | 3998 | Modifies rule in the marc_permissions table. | 
            
              | 3999 |  | 
            
              | 4000 | =over 4 | 
            
              | 4001 |  | 
            
              | 4002 | =item C<$id> | 
            
              | 4003 |  | 
            
              | 4004 | rule id to modify | 
            
              | 4005 |  | 
            
              | 4006 | =item C<$fields> | 
            
              | 4007 |  | 
            
              | 4008 | hashref defining the table fields | 
            
              | 4009 |  | 
            
              | 4010 |       * tagfield - required | 
            
              | 4011 |       * module - required | 
            
              | 4012 |       * filter - required | 
            
              | 4013 |       * on_new - required | 
            
              | 4014 |       * on_appended - required | 
            
              | 4015 |       * on_removed - required | 
            
              | 4016 |       * on_deleted - required | 
            
              | 4017 |  | 
            
              | 4018 | =back | 
            
              | 4019 |  | 
            
              | 4020 | Returns: | 
            
              | 4021 |  | 
            
              | 4022 | =over 4 | 
            
              | 4023 |  | 
            
              | 4024 | =item C<$success> | 
            
              | 4025 |  | 
            
              | 4026 | undef if an error occurs, otherwise true. | 
            
              | 4027 |  | 
            
              | 4028 | =back | 
            
              | 4029 |  | 
            
              | 4030 | =cut | 
            
              | 4031 |  | 
            
              | 4032 | sub ModMarcPermissionsRule { | 
            
              | 4033 |     my ($id, $f) = @_; | 
            
              | 4034 |     my $dbh = C4::Context->dbh; | 
            
              | 4035 |  | 
            
              | 4036 |     my $query = ' | 
            
              | 4037 |     UPDATE `marc_permissions` | 
            
              | 4038 |     SET | 
            
              | 4039 |       tagfield = ?, | 
            
              | 4040 |       module = ?, | 
            
              | 4041 |       filter = ?, | 
            
              | 4042 |       on_new = ?, | 
            
              | 4043 |       on_appended = ?, | 
            
              | 4044 |       on_removed = ?, | 
            
              | 4045 |       on_deleted = ? | 
            
              | 4046 |     WHERE | 
            
              | 4047 |       id = ? | 
            
              | 4048 |     '; | 
            
              | 4049 |     my $sth = $dbh->prepare($query); | 
            
              | 4050 |     my $result = $sth->execute ( | 
            
              | 4051 |         $f->{tagfield}, | 
            
              | 4052 |         $f->{module}, | 
            
              | 4053 |         $f->{filter}, | 
            
              | 4054 |         $f->{on_new}, | 
            
              | 4055 |         $f->{on_appended}, | 
            
              | 4056 |         $f->{on_removed}, | 
            
              | 4057 |         $f->{on_deleted}, | 
            
              | 4058 |         $id | 
            
              | 4059 |     ); | 
            
              | 4060 |     ClearMarcPermissionsRulesCache(); | 
            
              | 4061 |     return $result; | 
            
              | 4062 | } | 
            
              | 4063 |  | 
            
              | 4064 | sub ClearMarcPermissionsRulesCache { | 
            
              | 4065 |     my $cache = Koha::Caches->get_instance(); | 
            
              | 4066 |     $cache->clear_from_cache('marc_permissions'); | 
            
              | 4067 | } | 
            
              | 4068 |  | 
            
              | 4069 | =head2 AddMarcPermissionsRule | 
            
              | 4070 |  | 
            
              | 4071 |     my $success = AddMarcPermissionsRule($fields) | 
            
              | 4072 |  | 
            
              | 4073 | Add rule to the marc_permissions table. | 
            
              | 4074 |  | 
            
              | 4075 | =over 4 | 
            
              | 4076 |  | 
            
              | 4077 | =item C<$fields> | 
            
              | 4078 |  | 
            
              | 4079 | hashref defining the table fields | 
            
              | 4080 |  | 
            
              | 4081 |       tagfield - required | 
            
              | 4082 |       module - required | 
            
              | 4083 |       filter - required | 
            
              | 4084 |       on_new - required | 
            
              | 4085 |       on_appended - required | 
            
              | 4086 |       on_removed - required | 
            
              | 4087 |       on_deleted - required | 
            
              | 4088 |  | 
            
              | 4089 | =back | 
            
              | 4090 |  | 
            
              | 4091 | Returns: | 
            
              | 4092 |  | 
            
              | 4093 | =over 4 | 
            
              | 4094 |  | 
            
              | 4095 | =item C<$success> | 
            
              | 4096 |  | 
            
              | 4097 | undef if an error occurs, otherwise true. | 
            
              | 4098 |  | 
            
              | 4099 | =back | 
            
              | 4100 |  | 
            
              | 4101 | =cut | 
            
              | 4102 |  | 
            
              | 4103 | sub AddMarcPermissionsRule { | 
            
              | 4104 |     my $f = shift; | 
            
              | 4105 |     my $dbh = C4::Context->dbh; | 
            
              | 4106 |     my $query = ' | 
            
              | 4107 |     INSERT INTO `marc_permissions` | 
            
              | 4108 |     ( | 
            
              | 4109 |       tagfield, | 
            
              | 4110 |       module, | 
            
              | 4111 |       filter, | 
            
              | 4112 |       on_new, | 
            
              | 4113 |       on_appended, | 
            
              | 4114 |       on_removed, | 
            
              | 4115 |       on_deleted | 
            
              | 4116 |     ) | 
            
              | 4117 |     VALUES (?, ?, ?, ?, ?, ?, ?) | 
            
              | 4118 |     '; | 
            
              | 4119 |     my $sth = $dbh->prepare($query); | 
            
              | 4120 |     my $result = $sth->execute ( | 
            
              | 4121 |         $f->{tagfield}, | 
            
              | 4122 |         $f->{module}, | 
            
              | 4123 |         $f->{filter}, | 
            
              | 4124 |         $f->{on_new}, | 
            
              | 4125 |         $f->{on_appended}, | 
            
              | 4126 |         $f->{on_removed}, | 
            
              | 4127 |         $f->{on_deleted} | 
            
              | 4128 |     ); | 
            
              | 4129 |     ClearMarcPermissionsRulesCache(); | 
            
              | 4130 |     return $result; | 
            
              | 4131 | } | 
            
              | 4132 |  | 
            
              | 4133 | =head2 DelMarcPermissionsRule | 
            
              | 4134 |  | 
            
              | 4135 |     my $success = DelMarcPermissionsRule($id) | 
            
              | 4136 |  | 
            
              | 4137 | Deletes rule from the marc_permissions table. | 
            
              | 4138 |  | 
            
              | 4139 | =over 4 | 
            
              | 4140 |  | 
            
              | 4141 | =item C<$id> | 
            
              | 4142 |  | 
            
              | 4143 | rule id to delete | 
            
              | 4144 |  | 
            
              | 4145 | =back | 
            
              | 4146 |  | 
            
              | 4147 | Returns: | 
            
              | 4148 |  | 
            
              | 4149 | =over 4 | 
            
              | 4150 |  | 
            
              | 4151 | =item C<$success> | 
            
              | 4152 |  | 
            
              | 4153 | undef if an error occurs, otherwise true. | 
            
              | 4154 |  | 
            
              | 4155 | =back | 
            
              | 4156 |  | 
            
              | 4157 | =cut | 
            
              | 4158 |  | 
            
              | 4159 | sub DelMarcPermissionsRule { | 
            
              | 4160 |     my $id = shift; | 
            
              | 4161 |     my $dbh = C4::Context->dbh; | 
            
              | 4162 |     my $query = ' | 
            
              | 4163 |     DELETE FROM `marc_permissions` | 
            
              | 4164 |     WHERE | 
            
              | 4165 |       id = ? | 
            
              | 4166 |     '; | 
            
              | 4167 |     my $sth = $dbh->prepare($query); | 
            
              | 4168 |     my $result = $sth->execute($id); | 
            
              | 4169 |     ClearMarcPermissionsRulesCache(); | 
            
              | 4170 |     return $result; | 
            
              | 4171 | } | 
            
              | 4172 | 1; | 
        
          | 3574 |  | 4173 |  | 
        
          | 3575 | __END__ | 4174 | __END__ | 
        
          | 3576 |  | 4175 |  |