| Lines 106-111
          BEGIN {
      
      
        Link Here | 
        
          | 106 |       &CountItemsIssued | 106 |       &CountItemsIssued | 
        
          | 107 |       &CountBiblioInOrders | 107 |       &CountBiblioInOrders | 
        
          | 108 |       &GetSubscriptionsId | 108 |       &GetSubscriptionsId | 
            
              |  |  | 109 |  | 
            
              | 110 |       &GetMarcPermissionsRules | 
            
              | 111 |       &GetMarcPermissionsModules | 
            
              | 112 |       &ModMarcPermissionsRule | 
            
              | 113 |       &AddMarcPermissionsRule | 
            
              | 114 |       &DelMarcPermissionsRule | 
        
          | 109 |     ); | 115 |     ); | 
        
          | 110 |  | 116 |  | 
        
          | 111 |     # To modify something | 117 |     # To modify something | 
  
    | Lines 133-138
          BEGIN {
      
      
        Link Here | 
        
          | 133 |     # they are useful in a few circumstances, so they are exported, | 139 |     # they are useful in a few circumstances, so they are exported, | 
        
          | 134 |     # but don't use them unless you are a core developer ;-) | 140 |     # but don't use them unless you are a core developer ;-) | 
        
          | 135 |     push @EXPORT, qw( | 141 |     push @EXPORT, qw( | 
            
              |  |  | 142 |       &ApplyMarcPermissions | 
        
          | 136 |       &ModBiblioMarc | 143 |       &ModBiblioMarc | 
        
          | 137 |     ); | 144 |     ); | 
        
          | 138 |  | 145 |  | 
  
    | Lines 257-263
          sub AddBiblio {
      
      
        Link Here | 
        
          | 257 |     _koha_marc_update_biblioitem_cn_sort( $record, $olddata, $frameworkcode ); | 264 |     _koha_marc_update_biblioitem_cn_sort( $record, $olddata, $frameworkcode ); | 
        
          | 258 |  | 265 |  | 
        
          | 259 |     # now add the record | 266 |     # now add the record | 
          
            
              | 260 |     ModBiblioMarc( $record, $biblionumber, $frameworkcode ) unless $defer_marc_save; | 267 |     ModBiblioMarc( $record, $biblionumber, $frameworkcode, $options->{filter} ) unless $defer_marc_save; | 
        
          | 261 |  | 268 |  | 
        
          | 262 |     # update OAI-PMH sets | 269 |     # update OAI-PMH sets | 
        
          | 263 |     if(C4::Context->preference("OAI-PMH:AutoUpdateSets")) { | 270 |     if(C4::Context->preference("OAI-PMH:AutoUpdateSets")) { | 
  
    | Lines 270-276
          sub AddBiblio {
      
      
        Link Here | 
        
          | 270 |  | 277 |  | 
        
          | 271 | =head2 ModBiblio | 278 | =head2 ModBiblio | 
        
          | 272 |  | 279 |  | 
          
            
              | 273 |   ModBiblio( $record,$biblionumber,$frameworkcode); | 280 |   ModBiblio($record, $biblionumber, $frameworkcode, $filter); | 
        
          | 274 |  | 281 |  | 
        
          | 275 | Replace an existing bib record identified by C<$biblionumber> | 282 | Replace an existing bib record identified by C<$biblionumber> | 
        
          | 276 | with one supplied by the MARC::Record object C<$record>.  The embedded | 283 | with one supplied by the MARC::Record object C<$record>.  The embedded | 
  
    | Lines 291-297
          Returns 1 on success 0 on failure
      
      
        Link Here | 
        
          | 291 | =cut | 298 | =cut | 
        
          | 292 |  | 299 |  | 
        
          | 293 | sub ModBiblio { | 300 | sub ModBiblio { | 
          
            
              | 294 |     my ( $record, $biblionumber, $frameworkcode ) = @_; | 301 |     my ( $record, $biblionumber, $frameworkcode, $filter ) = @_; | 
            
              |  |  | 302 |  | 
        
          | 295 |     if (!$record) { | 303 |     if (!$record) { | 
        
          | 296 |         carp 'No record passed to ModBiblio'; | 304 |         carp 'No record passed to ModBiblio'; | 
        
          | 297 |         return 0; | 305 |         return 0; | 
  
    | Lines 329-341
          sub ModBiblio {
      
      
        Link Here | 
        
          | 329 |     _koha_marc_update_bib_ids( $record, $frameworkcode, $biblionumber, $biblioitemnumber ); | 337 |     _koha_marc_update_bib_ids( $record, $frameworkcode, $biblionumber, $biblioitemnumber ); | 
        
          | 330 |  | 338 |  | 
        
          | 331 |     # load the koha-table data object | 339 |     # load the koha-table data object | 
          
            
              | 332 |     my $oldbiblio = TransformMarcToKoha( $record, $frameworkcode ); | 340 |     my $oldbiblio = TransformMarcToKoha( $record, $frameworkcode, undef, $biblionumber, $filter ); | 
        
          | 333 |  | 341 |  | 
        
          | 334 |     # update MARC subfield that stores biblioitems.cn_sort | 342 |     # update MARC subfield that stores biblioitems.cn_sort | 
        
          | 335 |     _koha_marc_update_biblioitem_cn_sort( $record, $oldbiblio, $frameworkcode ); | 343 |     _koha_marc_update_biblioitem_cn_sort( $record, $oldbiblio, $frameworkcode ); | 
        
          | 336 |  | 344 |  | 
        
          | 337 |     # update the MARC record (that now contains biblio and items) with the new record data | 345 |     # update the MARC record (that now contains biblio and items) with the new record data | 
          
            
              | 338 |     &ModBiblioMarc( $record, $biblionumber, $frameworkcode ); | 346 |     ModBiblioMarc( $record, $biblionumber, $frameworkcode, $filter ); | 
        
          | 339 |  | 347 |  | 
        
          | 340 |     # modify the other koha tables | 348 |     # modify the other koha tables | 
        
          | 341 |     _koha_modify_biblio( $dbh, $oldbiblio, $frameworkcode ); | 349 |     _koha_modify_biblio( $dbh, $oldbiblio, $frameworkcode ); | 
  
    | Lines 2655-2661
          sub TransformHtmlToMarc {
      
      
        Link Here | 
        
          | 2655 |  | 2663 |  | 
        
          | 2656 | =head2 TransformMarcToKoha | 2664 | =head2 TransformMarcToKoha | 
        
          | 2657 |  | 2665 |  | 
          
            
              | 2658 |   $result = TransformMarcToKoha( $record, $frameworkcode ) | 2666 |   $result = TransformMarcToKoha( $record, $frameworkcode, $biblionumber, $filter ) | 
        
          | 2659 |  | 2667 |  | 
        
          | 2660 | Extract data from a MARC bib record into a hashref representing | 2668 | Extract data from a MARC bib record into a hashref representing | 
        
          | 2661 | Koha biblio, biblioitems, and items fields.  | 2669 | Koha biblio, biblioitems, and items fields.  | 
  
    | Lines 2666-2672
          hash_ref
      
      
        Link Here | 
        
          | 2666 | =cut | 2674 | =cut | 
        
          | 2667 |  | 2675 |  | 
        
          | 2668 | sub TransformMarcToKoha { | 2676 | sub TransformMarcToKoha { | 
          
            
              | 2669 |     my ( $record, $frameworkcode, $limit_table ) = @_; | 2677 |     my ( $record, $frameworkcode, $limit_table, $biblionumber, $filter ) = @_; | 
        
          | 2670 |  | 2678 |  | 
        
          | 2671 |     my $result = {}; | 2679 |     my $result = {}; | 
        
          | 2672 |     if (!defined $record) { | 2680 |     if (!defined $record) { | 
  
    | Lines 2687-2692
          sub TransformMarcToKoha {
      
      
        Link Here | 
        
          | 2687 |         $tables{'biblioitems'} = 1; | 2695 |         $tables{'biblioitems'} = 1; | 
        
          | 2688 |     } | 2696 |     } | 
        
          | 2689 |  | 2697 |  | 
            
              |  |  | 2698 |     # apply permissions | 
            
              | 2699 |     if ( C4::Context->preference('MARCPermissions') && $biblionumber && $filter) { | 
            
              | 2700 |         $record = ApplyMarcPermissions({ | 
            
              | 2701 |                 biblionumber => $biblionumber, | 
            
              | 2702 |                 record => $record, | 
            
              | 2703 |                 frameworkcode => $frameworkcode, | 
            
              | 2704 |                 filter => $filter, | 
            
              | 2705 |                 nolog => 1 | 
            
              | 2706 |             }); | 
            
              | 2707 |     } | 
            
              | 2708 |  | 
        
          | 2690 |     # traverse through record | 2709 |     # traverse through record | 
        
          | 2691 |   MARCFIELD: foreach my $field ( $record->fields() ) { | 2710 |   MARCFIELD: foreach my $field ( $record->fields() ) { | 
        
          | 2692 |         my $tag = $field->tag(); | 2711 |         my $tag = $field->tag(); | 
  
    | Lines 3441-3447
          sub _koha_delete_biblioitems {
      
      
        Link Here | 
        
          | 3441 |  | 3460 |  | 
        
          | 3442 | =head2 ModBiblioMarc | 3461 | =head2 ModBiblioMarc | 
        
          | 3443 |  | 3462 |  | 
          
            
              | 3444 |   &ModBiblioMarc($newrec,$biblionumber,$frameworkcode); | 3463 |   &ModBiblioMarc($newrec,$biblionumber,$frameworkcode,$filter); | 
        
          | 3445 |  | 3464 |  | 
        
          | 3446 | Add MARC XML data for a biblio to koha | 3465 | Add MARC XML data for a biblio to koha | 
        
          | 3447 |  | 3466 |  | 
  
    | Lines 3452-3458
          Function exported, but should NOT be used, unless you really know what you're do
      
      
        Link Here | 
        
          | 3452 | sub ModBiblioMarc { | 3471 | sub ModBiblioMarc { | 
        
          | 3453 |     # pass the MARC::Record to this function, and it will create the records in | 3472 |     # pass the MARC::Record to this function, and it will create the records in | 
        
          | 3454 |     # the marcxml field | 3473 |     # the marcxml field | 
          
            
              | 3455 |     my ( $record, $biblionumber, $frameworkcode ) = @_; | 3474 |     my ( $record, $biblionumber, $frameworkcode, $filter ) = @_; | 
            
              |  |  | 3475 |  | 
        
          | 3456 |     if ( !$record ) { | 3476 |     if ( !$record ) { | 
        
          | 3457 |         carp 'ModBiblioMarc passed an undefined record'; | 3477 |         carp 'ModBiblioMarc passed an undefined record'; | 
        
          | 3458 |         return; | 3478 |         return; | 
  
    | Lines 3465-3470
          sub ModBiblioMarc {
      
      
        Link Here | 
        
          | 3465 |     if ( !$frameworkcode ) { | 3485 |     if ( !$frameworkcode ) { | 
        
          | 3466 |         $frameworkcode = ""; | 3486 |         $frameworkcode = ""; | 
        
          | 3467 |     } | 3487 |     } | 
            
              |  |  | 3488 |  | 
            
              | 3489 |     # apply permissions | 
            
              | 3490 |     if ( C4::Context->preference('MARCPermissions') ) { | 
            
              | 3491 |         $record = ApplyMarcPermissions({ | 
            
              | 3492 |                 biblionumber => $biblionumber, | 
            
              | 3493 |                 record => $record, | 
            
              | 3494 |                 frameworkcode => $frameworkcode, | 
            
              | 3495 |                 filter => $filter | 
            
              | 3496 |             }); | 
            
              | 3497 |     } | 
            
              | 3498 |  | 
        
          | 3468 |     my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?"); | 3499 |     my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?"); | 
        
          | 3469 |     $sth->execute( $frameworkcode, $biblionumber ); | 3500 |     $sth->execute( $frameworkcode, $biblionumber ); | 
        
          | 3470 |     $sth->finish; | 3501 |     $sth->finish; | 
  
    | Lines 3785-3790
          sub RemoveAllNsb {
      
      
        Link Here | 
        
          | 3785 |     return $record; | 3816 |     return $record; | 
        
          | 3786 | } | 3817 | } | 
        
          | 3787 |  | 3818 |  | 
            
              |  |  | 3819 | =head2 ApplyMarcPermissions | 
            
              | 3820 |  | 
            
              | 3821 |     my $record = ApplyMarcPermissions($arguments) | 
            
              | 3822 |  | 
            
              | 3823 | Applies marc permission rules to a record. | 
            
              | 3824 |  | 
            
              | 3825 | C<$arguments> is expected to be a hashref with below keys defined. | 
            
              | 3826 |  | 
            
              | 3827 | =over 4 | 
            
              | 3828 |  | 
            
              | 3829 | =item C<biblionumber> | 
            
              | 3830 | biblionumber of old record | 
            
              | 3831 |  | 
            
              | 3832 | =item C<record> | 
            
              | 3833 | record that will modify old record | 
            
              | 3834 |  | 
            
              | 3835 | =item C<frameworkcode> | 
            
              | 3836 | only tags included in framework will be processed | 
            
              | 3837 |  | 
            
              | 3838 | =item C<filter> | 
            
              | 3839 | hashref containing at least one filter module from the marc_permissions_modules | 
            
              | 3840 | table in form {module => filter}. Three predefined filter modules exists: | 
            
              | 3841 |  | 
            
              | 3842 |     * source | 
            
              | 3843 |     * category | 
            
              | 3844 |     * borrower | 
            
              | 3845 |  | 
            
              | 3846 | =item C<log> | 
            
              | 3847 | optional reference to array that will be filled with rule evaluation log | 
            
              | 3848 | entries. | 
            
              | 3849 |  | 
            
              | 3850 | =item C<nolog> | 
            
              | 3851 | optional boolean which when true disables logging to action log. | 
            
              | 3852 |  | 
            
              | 3853 | =back | 
            
              | 3854 |  | 
            
              | 3855 | Returns: | 
            
              | 3856 |  | 
            
              | 3857 | =over 4 | 
            
              | 3858 |  | 
            
              | 3859 | =item C<$record> | 
            
              | 3860 |  | 
            
              | 3861 | new MARC record based on C<record> with C<filter> applied. If no old | 
            
              | 3862 | record for C<biblionumber> can be found, C<record> is returned unchanged. | 
            
              | 3863 | Default action when no matching filter found is to leave old record unchanged. | 
            
              | 3864 |  | 
            
              | 3865 | =back | 
            
              | 3866 |  | 
            
              | 3867 | =cut | 
            
              | 3868 |  | 
            
              | 3869 | sub ApplyMarcPermissions { | 
            
              | 3870 |     my $arguments     = shift; | 
            
              | 3871 |     my $biblionumber  = $arguments->{biblionumber}; | 
            
              | 3872 |     my $new_record    = $arguments->{record}; | 
            
              | 3873 |     my $frameworkcode = $arguments->{frameworkcode} || ''; | 
            
              | 3874 |  | 
            
              | 3875 |     if ( !$biblionumber ) { | 
            
              | 3876 |         carp 'ApplyMarcPermissions called on undefined biblionumber'; | 
            
              | 3877 |         return; | 
            
              | 3878 |     } | 
            
              | 3879 |     if ( !$new_record ) { | 
            
              | 3880 |         carp 'ApplyMarcPermissions called on undefined record'; | 
            
              | 3881 |         return; | 
            
              | 3882 |     } | 
            
              | 3883 |     my $filter = $arguments->{filter} | 
            
              | 3884 |       or return $new_record; | 
            
              | 3885 |  | 
            
              | 3886 |     my $log   = $arguments->{log} || []; | 
            
              | 3887 |     my $nolog = $arguments->{nolog}; | 
            
              | 3888 |  | 
            
              | 3889 |     my $dbh = C4::Context->dbh; | 
            
              | 3890 |  | 
            
              | 3891 |     my $is_regex = sub { | 
            
              | 3892 |         my ( $tag, $m ) = @_; | 
            
              | 3893 |         # tag is not exactly same as possible regex | 
            
              | 3894 |         $tag ne $m && | 
            
              | 3895 |  | 
            
              | 3896 |         # wildcard | 
            
              | 3897 |         $m ne '*' && | 
            
              | 3898 |  | 
            
              | 3899 |         # valid tagDataType | 
            
              | 3900 |         $m !~ /^(0[1-9A-z][\dA-Z]) | | 
            
              | 3901 |         ([1-9A-z][\dA-z]{2})$/x && | 
            
              | 3902 |  | 
            
              | 3903 |         # nor valid controltagDataType | 
            
              | 3904 |         $m !~ /00[1-9A-Za-z]{1}/ && | 
            
              | 3905 |  | 
            
              | 3906 |         # so we try it as a regex | 
            
              | 3907 |         $tag =~ /^$m$/ | 
            
              | 3908 |     }; | 
            
              | 3909 |  | 
            
              | 3910 |     my $old_record = GetMarcBiblio($biblionumber); | 
            
              | 3911 |     if ( $old_record ) { | 
            
              | 3912 |         my $ret_record      = MARC::Record->new(); | 
            
              | 3913 |         my $perm            = GetMarcPermissions() or return $new_record; | 
            
              | 3914 |         my $marc_struct     = GetMarcStructure(1, $frameworkcode); | 
            
              | 3915 |         my $similarity_pref = C4::Context->preference("MARCPermissionsCorrectionSimilarity"); | 
            
              | 3916 |         $similarity_pref    = defined $similarity_pref && | 
            
              | 3917 |                               $similarity_pref >= 0 && | 
            
              | 3918 |                               $similarity_pref <= 100 ? | 
            
              | 3919 |                               $similarity_pref/100.0 : undef; | 
            
              | 3920 |  | 
            
              | 3921 |         # First came the leader ... | 
            
              | 3922 |         $ret_record->leader($old_record->leader()); | 
            
              | 3923 |  | 
            
              | 3924 |         # ... and then came all the tags in the framework | 
            
              | 3925 |         for my $tag (sort keys %{$marc_struct}) { | 
            
              | 3926 |             my @old_fields = $old_record->field($tag); | 
            
              | 3927 |             my @new_fields = $new_record->field($tag); | 
            
              | 3928 |             next unless @old_fields or @new_fields; | 
            
              | 3929 |             my @perms = ( | 
            
              | 3930 |                 $perm->{'*'}, | 
            
              | 3931 |                 (   # regex tags | 
            
              | 3932 |                     map { $perm->{$_} } | 
            
              | 3933 |                       grep { $is_regex->( $tag, $_ ) } sort keys %{$perm} | 
            
              | 3934 |                 ), | 
            
              | 3935 |                 $perm->{$tag} | 
            
              | 3936 |             ); | 
            
              | 3937 |  | 
            
              | 3938 |             # There can be more than one field for each tag, so we have to | 
            
              | 3939 |             # iterate all fields and distinguish which are new, removed or | 
            
              | 3940 |             # modified | 
            
              | 3941 |             my $max_fields = ($#old_fields, $#new_fields) | 
            
              | 3942 |                              [$#old_fields< $#new_fields]; | 
            
              | 3943 |             for ( my $i_field = 0; $i_field <= $max_fields; $i_field++ ) { | 
            
              | 3944 |                 my $old_field = $old_fields[$i_field]; | 
            
              | 3945 |                 my $new_field = $new_fields[$i_field]; | 
            
              | 3946 |  | 
            
              | 3947 |                 # Existing field | 
            
              | 3948 |                 if ( $old_field and $new_field ) { | 
            
              | 3949 |                     # Control fields | 
            
              | 3950 |                     if ( $old_field->is_control_field() ) { | 
            
              | 3951 |                         # Existing control field | 
            
              | 3952 |                         if ( $old_field and $new_field ) { | 
            
              | 3953 |                             my $on_existing = GetMarcPermissionsAction('on_existing', $filter, @perms); | 
            
              | 3954 |                             if ( defined $on_existing->{action} ) { | 
            
              | 3955 |                                 push @{$log}, | 
            
              | 3956 |                                   { | 
            
              | 3957 |                                     rule         => $on_existing->{rule}, | 
            
              | 3958 |                                     event        => "existing", | 
            
              | 3959 |                                     action       => $on_existing->{action}, | 
            
              | 3960 |                                     tag          => $tag, | 
            
              | 3961 |                                     subfieldcode => undef, | 
            
              | 3962 |                                     filter       => $filter | 
            
              | 3963 |                                   }; | 
            
              | 3964 |                                 if ( $on_existing->{action} eq 'skip' ) { | 
            
              | 3965 |                                     $ret_record->insert_fields_ordered($old_field); | 
            
              | 3966 |                                     next; | 
            
              | 3967 |                                 } elsif ( $on_existing->{action} eq 'overwrite' ) { | 
            
              | 3968 |                                     $ret_record->insert_fields_ordered($new_field); | 
            
              | 3969 |                                     next; | 
            
              | 3970 |                                 } elsif ( $on_existing->{action} eq 'add' ) { | 
            
              | 3971 |                                     $ret_record->insert_fields_ordered($old_field); | 
            
              | 3972 |                                     $ret_record->insert_fields_ordered($new_field); | 
            
              | 3973 |                                     next; | 
            
              | 3974 |                                 } elsif ( $on_existing->{action} eq 'add_or_correct' ) { | 
            
              | 3975 |                                     if ( $similarity_pref ) { | 
            
              | 3976 |                                         my $similarity = similarity $old_field->data(), $new_field->data(); | 
            
              | 3977 |                                         if ( $similarity >= $similarity_pref ) { | 
            
              | 3978 |                                             $ret_record->insert_fields_ordered($new_field); | 
            
              | 3979 |                                         } else { | 
            
              | 3980 |                                             $ret_record->insert_fields_ordered($old_field); | 
            
              | 3981 |                                             $ret_record->insert_fields_ordered($new_field); | 
            
              | 3982 |                                         } | 
            
              | 3983 |                                     } else { | 
            
              | 3984 |                                         $ret_record->insert_fields_ordered($old_field); | 
            
              | 3985 |                                     } | 
            
              | 3986 |                                 } | 
            
              | 3987 |                             } else { # default to skip | 
            
              | 3988 |                                 $ret_record->insert_fields_ordered($old_field); | 
            
              | 3989 |                                 next; | 
            
              | 3990 |                             } | 
            
              | 3991 |                         # New control field | 
            
              | 3992 |                         } elsif ( not $old_field and $new_field ) { | 
            
              | 3993 |                             my $on_new = GetMarcPermissionsAction('on_new', $filter, @perms); | 
            
              | 3994 |                             if ( defined $on_new->{action} ) { | 
            
              | 3995 |                                 push @{$log}, | 
            
              | 3996 |                                   { | 
            
              | 3997 |                                     rule         => $on_new->{rule}, | 
            
              | 3998 |                                     event        => "new", | 
            
              | 3999 |                                     action       => $on_new->{action}, | 
            
              | 4000 |                                     tag          => $tag, | 
            
              | 4001 |                                     subfieldcode => undef, | 
            
              | 4002 |                                     filter       => $filter | 
            
              | 4003 |                                   }; | 
            
              | 4004 |                                 if ( $on_new->{action} eq 'skip' ) { # Redundant | 
            
              | 4005 |                                     next; | 
            
              | 4006 |                                 } elsif ( $on_new->{action} eq 'add' ) { | 
            
              | 4007 |                                     $ret_record->insert_fields_ordered($new_field); | 
            
              | 4008 |                                     next; | 
            
              | 4009 |                                 } | 
            
              | 4010 |                             } | 
            
              | 4011 |                         # Removed control field | 
            
              | 4012 |                         } elsif ( $old_field and not $new_field ) { | 
            
              | 4013 |                             my $on_removed = GetMarcPermissionsAction('on_removed', $filter, @perms); | 
            
              | 4014 |                             if ( defined $on_removed->{action} ) { | 
            
              | 4015 |                                 push @{$log}, | 
            
              | 4016 |                                   { | 
            
              | 4017 |                                     rule         => $on_removed->{rule}, | 
            
              | 4018 |                                     event        => "removed", | 
            
              | 4019 |                                     action       => $on_removed->{action}, | 
            
              | 4020 |                                     tag          => $tag, | 
            
              | 4021 |                                     subfieldcode => undef | 
            
              | 4022 |                                   }; | 
            
              | 4023 |                                 if ( $on_removed->{action} eq 'skip' ) { | 
            
              | 4024 |                                     $ret_record->insert_fields_ordered($old_field); | 
            
              | 4025 |                                     next; | 
            
              | 4026 |                                 } elsif ( $on_removed->{action} eq 'remove' ) { | 
            
              | 4027 |                                     next; | 
            
              | 4028 |                                 } | 
            
              | 4029 |                             } else { # default to skip | 
            
              | 4030 |                                 $ret_record->insert_fields_ordered($old_field); | 
            
              | 4031 |                                 next; | 
            
              | 4032 |                             } | 
            
              | 4033 |                         } | 
            
              | 4034 |                     # Indicators and subfields | 
            
              | 4035 |                     } else { | 
            
              | 4036 |                         # Indicators | 
            
              | 4037 |                         my @old_ind = map { $old_field->indicator($_) } (1,2); | 
            
              | 4038 |                         my @new_ind = map { $new_field->indicator($_) } (1,2); | 
            
              | 4039 |                         my @ind = ('',''); | 
            
              | 4040 |  | 
            
              | 4041 |                         for my $i ((0,1)) { | 
            
              | 4042 |                             my @ind_perms = ( | 
            
              | 4043 |                                 @perms, | 
            
              | 4044 |                                 $perm->{$tag}->{subfields}->{ 'i' . ( $i + 1 ) } | 
            
              | 4045 |                             ); | 
            
              | 4046 |  | 
            
              | 4047 |                             # Existing indicator | 
            
              | 4048 |                             if ( defined $old_ind[$i] and defined $new_ind[$i] ) { | 
            
              | 4049 |                                 my $on_existing = GetMarcPermissionsAction('on_existing', $filter, @ind_perms); | 
            
              | 4050 |                                 if ( defined $on_existing->{action} ) { | 
            
              | 4051 |                                     push @{$log}, | 
            
              | 4052 |                                       { | 
            
              | 4053 |                                         rule         => $on_existing->{rule}, | 
            
              | 4054 |                                         event        => "existing", | 
            
              | 4055 |                                         action       => $on_existing->{action}, | 
            
              | 4056 |                                         tag          => $tag, | 
            
              | 4057 |                                         subfieldcode => 'i' . ( $i + 1 ), | 
            
              | 4058 |                                         filter       => $filter | 
            
              | 4059 |                                       }; | 
            
              | 4060 |                                     if ( $on_existing->{action} eq 'skip' ) { | 
            
              | 4061 |                                         $ind[$i] = $old_ind[$i]; | 
            
              | 4062 |                                     } elsif ( $on_existing->{action} eq 'overwrite' ) { | 
            
              | 4063 |                                         $ind[$i] = $new_ind[$i]; | 
            
              | 4064 |                                     } | 
            
              | 4065 |                                 } else { # default to skip | 
            
              | 4066 |                                     $ind[$i] = $old_ind[$i]; | 
            
              | 4067 |                                 } | 
            
              | 4068 |                             # New indicator | 
            
              | 4069 |                             } elsif ( not defined $old_ind[$i] and defined $new_ind[$i] ) { | 
            
              | 4070 |                                 my $on_new = GetMarcPermissionsAction('on_new', $filter, @ind_perms); | 
            
              | 4071 |                                 if ( defined $on_new->{action} ) { | 
            
              | 4072 |                                     push @{$log}, | 
            
              | 4073 |                                       { | 
            
              | 4074 |                                         rule         => $on_new->{rule}, | 
            
              | 4075 |                                         event        => "new", | 
            
              | 4076 |                                         action       => $on_new->{action}, | 
            
              | 4077 |                                         tag          => $tag, | 
            
              | 4078 |                                         subfieldcode => 'i' . ( $i + 1 ), | 
            
              | 4079 |                                         filter       => $filter | 
            
              | 4080 |                                       }; | 
            
              | 4081 |                                     if ( $on_new->{action} eq 'skip' ) { | 
            
              | 4082 |                                         $ind[$i] = $old_ind[$i]; | 
            
              | 4083 |                                     } elsif ( $on_new->{action} eq 'add' ) { | 
            
              | 4084 |                                         $ind[$i] = $new_ind[$i]; | 
            
              | 4085 |                                     } | 
            
              | 4086 |                                 } | 
            
              | 4087 |                             # Removed indicator | 
            
              | 4088 |                             } elsif ( defined $old_ind[$i] and not defined $new_ind[$i] ) { | 
            
              | 4089 |                                 my $on_removed = GetMarcPermissionsAction('on_removed', $filter, @ind_perms); | 
            
              | 4090 |                                 if ( defined $on_removed->{action} ) { | 
            
              | 4091 |                                     push @{$log}, | 
            
              | 4092 |                                       { | 
            
              | 4093 |                                         rule         => $on_removed->{rule}, | 
            
              | 4094 |                                         event        => "removed", | 
            
              | 4095 |                                         action       => $on_removed->{action}, | 
            
              | 4096 |                                         tag          => $tag, | 
            
              | 4097 |                                         subfieldcode => 'i' . ( $i + 1 ), | 
            
              | 4098 |                                         filter       => $filter | 
            
              | 4099 |                                       }; | 
            
              | 4100 |                                     if ( $on_removed->{action} eq 'skip' ) { | 
            
              | 4101 |                                         $ind[$i] = $old_ind[$i]; | 
            
              | 4102 |                                     } elsif ( $on_removed->{action} eq 'remove' ) { | 
            
              | 4103 |                                         $ind[$i] = ''; | 
            
              | 4104 |                                     } | 
            
              | 4105 |                                 } else { # default to skip | 
            
              | 4106 |                                     $ind[$i] = $old_ind[$i]; | 
            
              | 4107 |                                 } | 
            
              | 4108 |                             } | 
            
              | 4109 |                         } | 
            
              | 4110 |  | 
            
              | 4111 |                         # Subfields | 
            
              | 4112 |                         my @subfields = (); | 
            
              | 4113 |                         my %proccessed_subcodes = (); | 
            
              | 4114 |  | 
            
              | 4115 |                         # Try to preserve subfield order by first processing | 
            
              | 4116 |                         # subfields from the old record, and then subfields from | 
            
              | 4117 |                         # the framework structure unless include in old record. | 
            
              | 4118 |                         my @sorted_subfields = ( | 
            
              | 4119 |                             map { shift @{$_} } $old_field->subfields(), | 
            
              | 4120 |                             () = sort keys %{ $marc_struct->{$tag} } | 
            
              | 4121 |                         ); | 
            
              | 4122 |                         for my $subcode ( @sorted_subfields ) { | 
            
              | 4123 |                             next if $proccessed_subcodes{$subcode}; | 
            
              | 4124 |                             $proccessed_subcodes{$subcode} = 1; | 
            
              | 4125 |                             next unless ref $marc_struct->{$tag}{$subcode} eq 'HASH'; | 
            
              | 4126 |                             my @old_subfields = $old_field->subfield($subcode); | 
            
              | 4127 |                             my @new_subfields = $new_field->subfield($subcode); | 
            
              | 4128 |                             next unless @old_subfields or @new_subfields; | 
            
              | 4129 |  | 
            
              | 4130 |                             my @subfield_perms = ( | 
            
              | 4131 |                                 @perms, | 
            
              | 4132 |                                 $perm->{'*'}->{subfields}->{'*'}, | 
            
              | 4133 |                                 $perm->{$tag}->{subfields}->{'*'}, | 
            
              | 4134 |                                 (    # tag->regex | 
            
              | 4135 |                                     map { $perm->{$tag}->{subfields}->{$_} } | 
            
              | 4136 |                                       grep { | 
            
              | 4137 |                                         # subcode is not exactly same as | 
            
              | 4138 |                                         # possible regex | 
            
              | 4139 |                                         $subcode ne $_ && | 
            
              | 4140 |  | 
            
              | 4141 |                                         # wildcard, not checking for valid | 
            
              | 4142 |                                         # subfieldcodeDataType since it | 
            
              | 4143 |                                         # contains too many regex characters | 
            
              | 4144 |                                         $_ !~ /^(\*)$/ && | 
            
              | 4145 |  | 
            
              | 4146 |                                         # so we try it as a regex | 
            
              | 4147 |                                         $subcode =~ /$_/ | 
            
              | 4148 |                                       } sort | 
            
              | 4149 |                                       keys %{ $perm->{$tag}->{subfields} } | 
            
              | 4150 |                                 ), | 
            
              | 4151 |                                 (    # regex->* | 
            
              | 4152 |                                     map { $perm->{$_}->{subfields}->{'*'} } | 
            
              | 4153 |                                       grep { $is_regex->( $tag, $_ ) } | 
            
              | 4154 |                                       sort keys %{$perm} | 
            
              | 4155 |                                 ), | 
            
              | 4156 |                                 $perm->{'*'}->{subfields}->{$subcode}, | 
            
              | 4157 |                                 (    # regex->subcode | 
            
              | 4158 |                                     map { $perm->{$_}->{subfields}->{$subcode} } | 
            
              | 4159 |                                       grep { $is_regex->( $tag, $_ ) } | 
            
              | 4160 |                                       sort keys %{$perm} | 
            
              | 4161 |                                 ), | 
            
              | 4162 |                                 $perm->{$tag}->{subfields}->{$subcode} | 
            
              | 4163 |                             ); | 
            
              | 4164 |  | 
            
              | 4165 |                             # Existing subfield | 
            
              | 4166 |                             if ( @old_subfields and @new_subfields ) { | 
            
              | 4167 |                                 my $on_existing = GetMarcPermissionsAction('on_existing', $filter, @subfield_perms); | 
            
              | 4168 |                                 if ( defined $on_existing->{action} ) { | 
            
              | 4169 |                                     push @{$log}, | 
            
              | 4170 |                                       { | 
            
              | 4171 |                                         rule         => $on_existing->{rule}, | 
            
              | 4172 |                                         event        => "existing", | 
            
              | 4173 |                                         action       => $on_existing->{action}, | 
            
              | 4174 |                                         tag          => $tag, | 
            
              | 4175 |                                         subfieldcode => $subcode, | 
            
              | 4176 |                                         filter       => $filter | 
            
              | 4177 |                                       }; | 
            
              | 4178 |                                     if ( $on_existing->{action} eq 'skip' ) { | 
            
              | 4179 |                                         push(@subfields, map {($subcode,$_)} @old_subfields); | 
            
              | 4180 |                                         next; | 
            
              | 4181 |                                     } elsif ( $on_existing->{action} eq 'overwrite' ) { | 
            
              | 4182 |                                         push(@subfields, map {($subcode,$_)} @new_subfields); | 
            
              | 4183 |                                         next; | 
            
              | 4184 |                                     } elsif ( $on_existing->{action} eq 'add' ) { | 
            
              | 4185 |                                         push(@subfields, map {($subcode,$_)} @old_subfields); | 
            
              | 4186 |                                         push(@subfields, map {($subcode,$_)} @new_subfields); | 
            
              | 4187 |                                         next; | 
            
              | 4188 |                                     } elsif ( $on_existing->{action} eq 'add_or_correct' ) { | 
            
              | 4189 |                                         if ( $similarity_pref ) { | 
            
              | 4190 |                                             my @corrected_vals = (); | 
            
              | 4191 |  | 
            
              | 4192 |                                             # correct all old subfields | 
            
              | 4193 |                                             for ( my $i_new = 0; $i_new <= $#new_subfields; $i_new++ ) { | 
            
              | 4194 |                                                 my $new_val = $new_subfields[$i_new]; | 
            
              | 4195 |                                                 for ( my $i_old = 0; $i_old <= $#old_subfields; $i_old++ ) { | 
            
              | 4196 |                                                     my $old_val = $old_subfields[$i_old]; | 
            
              | 4197 |                                                     next if not defined $old_val or not defined $new_val; | 
            
              | 4198 |                                                     my $similarity = similarity ($old_val, $new_val); | 
            
              | 4199 |                                                     if ( $similarity >= $similarity_pref ) { | 
            
              | 4200 |                                                         $corrected_vals[$i_old] = $new_val; | 
            
              | 4201 |                                                         $new_subfields[$i_new] = undef; | 
            
              | 4202 |                                                         $old_subfields[$i_old] = undef; | 
            
              | 4203 |                                                         last; | 
            
              | 4204 |                                                     } | 
            
              | 4205 |                                                 } | 
            
              | 4206 |                                             } | 
            
              | 4207 |  | 
            
              | 4208 |                                             # insert all unchanged old subfields | 
            
              | 4209 |                                             map { | 
            
              | 4210 |                                                 $corrected_vals[$_] = $old_subfields[$_] | 
            
              | 4211 |                                                     if defined $old_subfields[$_] | 
            
              | 4212 |                                                 } 0 .. $#old_subfields; | 
            
              | 4213 |  | 
            
              | 4214 |  | 
            
              | 4215 |                                             # append all remaning new subfields | 
            
              | 4216 |                                             map {push @corrected_vals, $_ if defined} @new_subfields; | 
            
              | 4217 |  | 
            
              | 4218 |                                             push(@subfields, map {($subcode,$_)} @corrected_vals); | 
            
              | 4219 |                                         } else { | 
            
              | 4220 |                                             push(@subfields, map {($subcode,$_)} @old_subfields); | 
            
              | 4221 |                                         } | 
            
              | 4222 |                                     } | 
            
              | 4223 |                                 } else { # default to skip | 
            
              | 4224 |                                     push(@subfields, map {($subcode,$_)} @old_subfields); | 
            
              | 4225 |                                     next; | 
            
              | 4226 |                                 } | 
            
              | 4227 |                             # New subfield | 
            
              | 4228 |                             } elsif ( not @old_subfields and @new_subfields ) { | 
            
              | 4229 |                                 my $on_new = GetMarcPermissionsAction('on_new', $filter, @subfield_perms); | 
            
              | 4230 |                                 if ( defined $on_new->{action} ) { | 
            
              | 4231 |                                     push @{$log}, | 
            
              | 4232 |                                       { | 
            
              | 4233 |                                         rule         => $on_new->{rule}, | 
            
              | 4234 |                                         event        => "new", | 
            
              | 4235 |                                         action       => $on_new->{action}, | 
            
              | 4236 |                                         tag          => $tag, | 
            
              | 4237 |                                         subfieldcode => $subcode, | 
            
              | 4238 |                                         filter       => $filter | 
            
              | 4239 |                                       }; | 
            
              | 4240 |                                     if ( $on_new->{action} eq 'skip' ) { | 
            
              | 4241 |                                         next; | 
            
              | 4242 |                                     } elsif ( $on_new->{action} eq 'add' ) { | 
            
              | 4243 |                                         push(@subfields, map {($subcode,$_)} @new_subfields); | 
            
              | 4244 |                                         next; | 
            
              | 4245 |                                     } | 
            
              | 4246 |                                 } | 
            
              | 4247 |                             # Removed subfield | 
            
              | 4248 |                             } elsif ( @old_subfields and not @new_subfields ) { | 
            
              | 4249 |                                 my $on_removed = GetMarcPermissionsAction('on_removed', $filter, @subfield_perms); | 
            
              | 4250 |                                 if ( defined $on_removed->{action} ) { | 
            
              | 4251 |                                     push @{$log}, | 
            
              | 4252 |                                       { | 
            
              | 4253 |                                         rule         => $on_removed->{rule}, | 
            
              | 4254 |                                         event        => "removed", | 
            
              | 4255 |                                         action       => $on_removed->{action}, | 
            
              | 4256 |                                         tag          => $tag, | 
            
              | 4257 |                                         subfieldcode => $subcode, | 
            
              | 4258 |                                         filter       => $filter | 
            
              | 4259 |                                       }; | 
            
              | 4260 |                                     if ( $on_removed->{action} eq 'skip' ) { | 
            
              | 4261 |                                         push(@subfields, ($subcode => @old_subfields)); | 
            
              | 4262 |                                         next; | 
            
              | 4263 |                                     } elsif ( $on_removed->{action} eq 'remove' ) { | 
            
              | 4264 |                                         next; | 
            
              | 4265 |                                     } | 
            
              | 4266 |                                 } else { # default to skip | 
            
              | 4267 |                                     push(@subfields, ($subcode => @old_subfields)); | 
            
              | 4268 |                                     next; | 
            
              | 4269 |                                 } | 
            
              | 4270 |                             } | 
            
              | 4271 |                         } # / for each subfield | 
            
              | 4272 |                         $ret_record->insert_grouped_field(MARC::Field->new($tag, $ind[0], $ind[1], @subfields)); | 
            
              | 4273 |                     } | 
            
              | 4274 |                 # New field | 
            
              | 4275 |                 } elsif ( not $old_field and $new_field ) { | 
            
              | 4276 |                     my $on_new = GetMarcPermissionsAction('on_new', $filter, @perms); | 
            
              | 4277 |  | 
            
              | 4278 |                     if ( defined $on_new->{action} ) { | 
            
              | 4279 |                         push @{$log}, | 
            
              | 4280 |                           { | 
            
              | 4281 |                             rule         => $on_new->{rule}, | 
            
              | 4282 |                             event        => "new", | 
            
              | 4283 |                             action       => $on_new->{action}, | 
            
              | 4284 |                             tag          => $tag, | 
            
              | 4285 |                             subfieldcode => undef, | 
            
              | 4286 |                             filter       => $filter | 
            
              | 4287 |                           }; | 
            
              | 4288 |                         if ( $on_new->{action} eq 'skip' ) { | 
            
              | 4289 |                             next; | 
            
              | 4290 |                         } elsif ( $on_new->{action} eq 'add' ) { | 
            
              | 4291 |                             $ret_record->insert_fields_ordered($new_field); | 
            
              | 4292 |                             next; | 
            
              | 4293 |                         } | 
            
              | 4294 |                     } | 
            
              | 4295 |                 # Removed field | 
            
              | 4296 |                 } elsif ( $old_field and not $new_field ) { | 
            
              | 4297 |                     my $on_removed = GetMarcPermissionsAction('on_removed', $filter, @perms); | 
            
              | 4298 |                     if ( defined $on_removed->{action} ) { | 
            
              | 4299 |                         push @{$log}, | 
            
              | 4300 |                           { | 
            
              | 4301 |                             rule         => $on_removed->{rule}, | 
            
              | 4302 |                             event        => "removed", | 
            
              | 4303 |                             action       => $on_removed->{action}, | 
            
              | 4304 |                             tag          => $tag, | 
            
              | 4305 |                             subfieldcode => undef, | 
            
              | 4306 |                             filter       => $filter | 
            
              | 4307 |                           }; | 
            
              | 4308 |                         if ( $on_removed->{action} eq 'skip' ) { | 
            
              | 4309 |                             $ret_record->insert_grouped_field($old_field); | 
            
              | 4310 |                             next; | 
            
              | 4311 |                         } elsif ( $on_removed->{action} eq 'remove' ) { | 
            
              | 4312 |                             next; | 
            
              | 4313 |                         } | 
            
              | 4314 |                     } else { # default to skip | 
            
              | 4315 |                         $ret_record->insert_grouped_field($old_field); | 
            
              | 4316 |                         next; | 
            
              | 4317 |                     } | 
            
              | 4318 |                 } | 
            
              | 4319 |             } # / for each field | 
            
              | 4320 |         } # / for each tag | 
            
              | 4321 |         if ( !$nolog && C4::Context->preference("MARCPermissionsLog") ) { | 
            
              | 4322 |             my $log_str = ''; | 
            
              | 4323 |             my $n       = $#{$log}; | 
            
              | 4324 |             for my $l ( @{$log} ) { | 
            
              | 4325 |                 $log_str .= "{\n"; | 
            
              | 4326 |                 my $kn = keys %{$l}; | 
            
              | 4327 |                 for my $k ( sort keys %{$l} ) { | 
            
              | 4328 |                     if ( $k eq 'filter' ) { | 
            
              | 4329 |                         $log_str .= "  filter => {\n"; | 
            
              | 4330 |                         my $fkn = keys %{ $l->{$k} }; | 
            
              | 4331 |                         for my $fk ( sort keys %{ $l->{$k} } ) { | 
            
              | 4332 |                             $log_str .= '    ' | 
            
              | 4333 |                               . $fk . ' => ' | 
            
              | 4334 |                               . $l->{$k}->{$fk} | 
            
              | 4335 |                               . ( --$fkn ? ',' : '' ) . "\n"; | 
            
              | 4336 |                         } | 
            
              | 4337 |                         $log_str .= "  }" . ( --$kn ? ',' : '' ) . "\n"; | 
            
              | 4338 |                     } | 
            
              | 4339 |                     else { | 
            
              | 4340 |                         $log_str .= '  ' | 
            
              | 4341 |                           . $k . ' => ' | 
            
              | 4342 |                           . $l->{$k} | 
            
              | 4343 |                           . ( --$kn ? ',' : '' ) . "\n" | 
            
              | 4344 |                           if defined $l->{$k}; | 
            
              | 4345 |                     } | 
            
              | 4346 |                 } | 
            
              | 4347 |                 $log_str .= '}' . ( $n-- ? ",\n" : '' ); | 
            
              | 4348 |             } | 
            
              | 4349 |             logaction( "CATALOGUING", "MODIFY", $biblionumber, $log_str ); | 
            
              | 4350 |         } | 
            
              | 4351 |         return $ret_record; | 
            
              | 4352 |     } | 
            
              | 4353 |     return $new_record; | 
            
              | 4354 | } | 
            
              | 4355 |  | 
            
              | 4356 |  | 
            
              | 4357 | =head2 GetMarcPermissions | 
            
              | 4358 |  | 
            
              | 4359 |     my $marc_permissions = GetMarcPermissions() | 
            
              | 4360 |  | 
            
              | 4361 | Loads MARC field permissions from the marc_permissions table. | 
            
              | 4362 |  | 
            
              | 4363 | Returns: | 
            
              | 4364 |  | 
            
              | 4365 | =over 4 | 
            
              | 4366 |  | 
            
              | 4367 | =item C<$marc_permissions> | 
            
              | 4368 |  | 
            
              | 4369 | hashref with permissions structure for use with GetMarcPermissionsAction. | 
            
              | 4370 |  | 
            
              | 4371 | =back | 
            
              | 4372 |  | 
            
              | 4373 | =cut | 
            
              | 4374 |  | 
            
              | 4375 | sub GetMarcPermissions { | 
            
              | 4376 |     my $dbh = C4::Context->dbh; | 
            
              | 4377 |     my $rule_count = 0; | 
            
              | 4378 |     my %perms = (); | 
            
              | 4379 |  | 
            
              | 4380 |     my $query = ' | 
            
              | 4381 |     SELECT `marc_permissions`.*, | 
            
              | 4382 |            `marc_permissions_modules`.`name`, | 
            
              | 4383 |            `marc_permissions_modules`.`description`, | 
            
              | 4384 |            `marc_permissions_modules`.`specificity` | 
            
              | 4385 |     FROM `marc_permissions` | 
            
              | 4386 |     LEFT JOIN `marc_permissions_modules` ON `module` = `marc_permissions_modules`.`id` | 
            
              | 4387 |     ORDER BY `marc_permissions_modules`.`specificity`, `id` | 
            
              | 4388 |     '; | 
            
              | 4389 |     my $sth = $dbh->prepare($query); | 
            
              | 4390 |     $sth->execute(); | 
            
              | 4391 |     while ( my $row = $sth->fetchrow_hashref ) { | 
            
              | 4392 |         $rule_count++; | 
            
              | 4393 |         if ( defined $row->{tagsubfield} and $row->{tagsubfield} ) { | 
            
              | 4394 |             $perms{ $row->{tagfield} }->{subfields}->{ $row->{tagsubfield} } | 
            
              | 4395 |               ->{on_existing}->{ $row->{name} }->{ $row->{filter} } = | 
            
              | 4396 |               { action => $row->{on_existing}, rule => $row->{'id'} }; | 
            
              | 4397 |             $perms{ $row->{tagfield} }->{subfields}->{ $row->{tagsubfield} } | 
            
              | 4398 |               ->{on_new}->{ $row->{name} }->{ $row->{filter} } = | 
            
              | 4399 |               { action => $row->{on_new}, rule => $row->{'id'} }; | 
            
              | 4400 |             $perms{ $row->{tagfield} }->{subfields}->{ $row->{tagsubfield} } | 
            
              | 4401 |               ->{on_removed}->{ $row->{name} }->{ $row->{filter} } = | 
            
              | 4402 |               { action => $row->{on_removed}, rule => $row->{'id'} }; | 
            
              | 4403 |         } | 
            
              | 4404 |         else { | 
            
              | 4405 |             $perms{ $row->{tagfield} }->{on_existing}->{ $row->{name} } | 
            
              | 4406 |               ->{ $row->{filter} } = | 
            
              | 4407 |               { action => $row->{on_existing}, rule => $row->{'id'} }; | 
            
              | 4408 |             $perms{ $row->{tagfield} }->{on_new}->{ $row->{name} } | 
            
              | 4409 |               ->{ $row->{filter} } = | 
            
              | 4410 |               { action => $row->{on_new}, rule => $row->{'id'} }; | 
            
              | 4411 |             $perms{ $row->{tagfield} }->{on_removed}->{ $row->{name} } | 
            
              | 4412 |               ->{ $row->{filter} } = | 
            
              | 4413 |               { action => $row->{on_removed}, rule => $row->{'id'} }; | 
            
              | 4414 |         } | 
            
              | 4415 |     } | 
            
              | 4416 |  | 
            
              | 4417 |     return unless $rule_count; | 
            
              | 4418 |     return \%perms; | 
            
              | 4419 | } | 
            
              | 4420 |  | 
            
              | 4421 | =head2 GetMarcPermissionsAction | 
            
              | 4422 |  | 
            
              | 4423 |     my $action = GetMarcPermissionsAction($event, $filter, @permissions) | 
            
              | 4424 |  | 
            
              | 4425 | Gets action based on C<$event>, C<$filter> and C<@permissions>. | 
            
              | 4426 |  | 
            
              | 4427 | =over 4 | 
            
              | 4428 |  | 
            
              | 4429 | =item C<$event> | 
            
              | 4430 |  | 
            
              | 4431 | which event: 'on_existing', 'on_new' or 'on_removed' | 
            
              | 4432 |  | 
            
              | 4433 | =item C<$filter> | 
            
              | 4434 |  | 
            
              | 4435 | hashref containing at least one filter module from the marc_permissions_modules | 
            
              | 4436 | table in form {module => filter}. Three predefined filter modules exists: | 
            
              | 4437 |  | 
            
              | 4438 |     * source | 
            
              | 4439 |     * category | 
            
              | 4440 |     * borrower | 
            
              | 4441 |  | 
            
              | 4442 | =item C<@permissions> | 
            
              | 4443 |  | 
            
              | 4444 | list of permission structures in order of specificity from least to most | 
            
              | 4445 | specific. | 
            
              | 4446 |  | 
            
              | 4447 | =back | 
            
              | 4448 |  | 
            
              | 4449 | Returns: | 
            
              | 4450 |  | 
            
              | 4451 | =over 4 | 
            
              | 4452 |  | 
            
              | 4453 | =item C<$action> | 
            
              | 4454 |  | 
            
              | 4455 | hashref defining matching action. | 
            
              | 4456 |  | 
            
              | 4457 | =back | 
            
              | 4458 |  | 
            
              | 4459 | =cut | 
            
              | 4460 |  | 
            
              | 4461 | sub GetMarcPermissionsAction { | 
            
              | 4462 |     my $what = shift or return; | 
            
              | 4463 |     my $filter = shift or return; | 
            
              | 4464 |     my @perms = @_; | 
            
              | 4465 |     my $modules = GetMarcPermissionsModules(); | 
            
              | 4466 |     my $action = undef; | 
            
              | 4467 |  | 
            
              | 4468 |     for my $perm (@perms) { | 
            
              | 4469 |         next if not defined $perm; | 
            
              | 4470 |         next if not defined $perm->{$what}; | 
            
              | 4471 |         my $tmp_action = undef; | 
            
              | 4472 |         # TODO: Borde kunna loopa over $perm->what? | 
            
              | 4473 |         # 1. Sortera filterargument efter prio (intersect keys med modules) | 
            
              | 4474 |         # Intersect med modules? | 
            
              | 4475 |         # foreach $filter as (keys %{$filter}) { | 
            
              | 4476 |         # } | 
            
              | 4477 |         for my $module ( @{$modules} ) { | 
            
              | 4478 |             my $action_candidate = defined $perm->{$what}->{ $module->{'name'} } ? $perm->{$what}->{ $module->{'name'} } : undef; | 
            
              | 4479 |  | 
            
              | 4480 |             # Problem: permission-modul med hogre specificitet overridarar aven om specifik | 
            
              | 4481 |             # matchning pa annan modul (med lagre) | 
            
              | 4482 |             if ($action_candidate) { | 
            
              | 4483 |                 if ( | 
            
              | 4484 |                     defined $filter->{ $module->{'name'} } and | 
            
              | 4485 |                     defined $action_candidate->{ $filter->{ $module->{'name'} } }->{action} | 
            
              | 4486 |                 ) { | 
            
              | 4487 |                     $tmp_action = $perm->{$what}->{ $module->{'name'} }->{ $filter->{ $module->{'name'} } }; | 
            
              | 4488 |                     last; | 
            
              | 4489 |                 } | 
            
              | 4490 |                 elsif (defined $action_candidate->{'*'}->{action} and !$tmp_action) { | 
            
              | 4491 |                     $tmp_action = $perm->{$what}->{ $module->{'name'} }->{'*'}; | 
            
              | 4492 |                 } | 
            
              | 4493 |             } | 
            
              | 4494 |         } | 
            
              | 4495 |         $action = $tmp_action if defined $tmp_action; | 
            
              | 4496 |     } | 
            
              | 4497 |  | 
            
              | 4498 |     return $action; | 
            
              | 4499 | } | 
            
              | 4500 |  | 
            
              | 4501 | =head2 GetMarcPermissionsRules | 
            
              | 4502 |  | 
            
              | 4503 |     my $rules = GetMarcPermissionsRules() | 
            
              | 4504 |  | 
            
              | 4505 | Returns: | 
            
              | 4506 |  | 
            
              | 4507 | =over 4 | 
            
              | 4508 |  | 
            
              | 4509 | =item C<$rules> | 
            
              | 4510 |  | 
            
              | 4511 | array (in list context, arrayref otherwise) of hashrefs from marc_permissions | 
            
              | 4512 | table in order of module specificity and rule id. | 
            
              | 4513 |  | 
            
              | 4514 | =back | 
            
              | 4515 |  | 
            
              | 4516 | =cut | 
            
              | 4517 |  | 
            
              | 4518 | sub GetMarcPermissionsRules { | 
            
              | 4519 |     my $dbh = C4::Context->dbh; | 
            
              | 4520 |     my @rules = (); | 
            
              | 4521 |  | 
            
              | 4522 |     my $query = ' | 
            
              | 4523 |     SELECT `marc_permissions`.`id`, | 
            
              | 4524 |            `marc_permissions`.`tagfield`, | 
            
              | 4525 |            `marc_permissions`.`tagsubfield`, | 
            
              | 4526 |            `marc_permissions`.`filter`, | 
            
              | 4527 |            `marc_permissions`.`on_existing`, | 
            
              | 4528 |            `marc_permissions`.`on_new`, | 
            
              | 4529 |            `marc_permissions`.`on_removed`, | 
            
              | 4530 |            `marc_permissions_modules`.`name` as  `module`, | 
            
              | 4531 |            `marc_permissions_modules`.`description`, | 
            
              | 4532 |            `marc_permissions_modules`.`specificity` | 
            
              | 4533 |     FROM `marc_permissions` | 
            
              | 4534 |     LEFT JOIN `marc_permissions_modules` ON `module` = `marc_permissions_modules`.`id` | 
            
              | 4535 |     ORDER BY `marc_permissions_modules`.`specificity`, `id` | 
            
              | 4536 |     '; | 
            
              | 4537 |     my $sth = $dbh->prepare($query); | 
            
              | 4538 |     $sth->execute(); | 
            
              | 4539 |     while ( my $row = $sth->fetchrow_hashref ) { | 
            
              | 4540 |         push(@rules, $row); | 
            
              | 4541 |     } | 
            
              | 4542 |  | 
            
              | 4543 |     return wantarray ? @rules : \@rules; | 
            
              | 4544 | } | 
            
              | 4545 |  | 
            
              | 4546 | =head2 GetMarcPermissionsModules | 
            
              | 4547 |  | 
            
              | 4548 |     my $modules = GetMarcPermissionsModules() | 
            
              | 4549 |  | 
            
              | 4550 | Returns: | 
            
              | 4551 |  | 
            
              | 4552 | =over 4 | 
            
              | 4553 |  | 
            
              | 4554 | =item C<$modules> | 
            
              | 4555 |  | 
            
              | 4556 | array (in list context, arrayref otherwise) of hashrefs from | 
            
              | 4557 | marc_permissions_modules table in order of specificity. | 
            
              | 4558 |  | 
            
              | 4559 | =back | 
            
              | 4560 |  | 
            
              | 4561 | =cut | 
            
              | 4562 |  | 
            
              | 4563 | sub GetMarcPermissionsModules { | 
            
              | 4564 |     my $dbh = C4::Context->dbh; | 
            
              | 4565 |     my @modules = (); | 
            
              | 4566 |  | 
            
              | 4567 |     my $query = ' | 
            
              | 4568 |     SELECT * | 
            
              | 4569 |     FROM `marc_permissions_modules` | 
            
              | 4570 |     ORDER BY `specificity` DESC | 
            
              | 4571 |     '; | 
            
              | 4572 |     my $sth = $dbh->prepare($query); | 
            
              | 4573 |     $sth->execute(); | 
            
              | 4574 |     while ( my $row = $sth->fetchrow_hashref ) { | 
            
              | 4575 |         push(@modules, $row); | 
            
              | 4576 |     } | 
            
              | 4577 |  | 
            
              | 4578 |     return wantarray ? @modules : \@modules; | 
            
              | 4579 | } | 
            
              | 4580 |  | 
            
              | 4581 | =head2 ModMarcPermissionsRule | 
            
              | 4582 |  | 
            
              | 4583 |     my $success = ModMarcPermissionsRule($id, $fields) | 
            
              | 4584 |  | 
            
              | 4585 | Modifies rule in the marc_permissions table. | 
            
              | 4586 |  | 
            
              | 4587 | =over 4 | 
            
              | 4588 |  | 
            
              | 4589 | =item C<$id> | 
            
              | 4590 |  | 
            
              | 4591 | rule id to modify | 
            
              | 4592 |  | 
            
              | 4593 | =item C<$fields> | 
            
              | 4594 |  | 
            
              | 4595 | hashref defining the table fields | 
            
              | 4596 |  | 
            
              | 4597 |       * tagfield - required | 
            
              | 4598 |       * tagsubfield | 
            
              | 4599 |       * module - required | 
            
              | 4600 |       * filter - required | 
            
              | 4601 |       * on_existing - required | 
            
              | 4602 |       * on_new - required | 
            
              | 4603 |       * on_removed - required | 
            
              | 4604 |  | 
            
              | 4605 | =back | 
            
              | 4606 |  | 
            
              | 4607 | Returns: | 
            
              | 4608 |  | 
            
              | 4609 | =over 4 | 
            
              | 4610 |  | 
            
              | 4611 | =item C<$success> | 
            
              | 4612 |  | 
            
              | 4613 | undef if an error occurs, otherwise true. | 
            
              | 4614 |  | 
            
              | 4615 | =back | 
            
              | 4616 |  | 
            
              | 4617 | =cut | 
            
              | 4618 |  | 
            
              | 4619 | sub ModMarcPermissionsRule { | 
            
              | 4620 |     my ($id, $f) = @_; | 
            
              | 4621 |     my $dbh = C4::Context->dbh; | 
            
              | 4622 |     my $query = ' | 
            
              | 4623 |     UPDATE `marc_permissions` | 
            
              | 4624 |     SET | 
            
              | 4625 |       tagfield = ?, | 
            
              | 4626 |       tagsubfield = ?, | 
            
              | 4627 |       module = ?, | 
            
              | 4628 |       filter = ?, | 
            
              | 4629 |       on_existing = ?, | 
            
              | 4630 |       on_new = ?, | 
            
              | 4631 |       on_removed = ? | 
            
              | 4632 |     WHERE | 
            
              | 4633 |       id = ? | 
            
              | 4634 |     '; | 
            
              | 4635 |     my $sth = $dbh->prepare($query); | 
            
              | 4636 |     return $sth->execute ( | 
            
              | 4637 |                       $f->{tagfield}, | 
            
              | 4638 |                       $f->{tagsubfield}, | 
            
              | 4639 |                       $f->{module}, | 
            
              | 4640 |                       $f->{filter}, | 
            
              | 4641 |                       $f->{on_existing}, | 
            
              | 4642 |                       $f->{on_new}, | 
            
              | 4643 |                       $f->{on_removed}, | 
            
              | 4644 |                       $id | 
            
              | 4645 |                   ); | 
            
              | 4646 | } | 
            
              | 4647 |  | 
            
              | 4648 | =head2 AddMarcPermissionsRule | 
            
              | 4649 |  | 
            
              | 4650 |     my $success = AddMarcPermissionsRule($fields) | 
            
              | 4651 |  | 
            
              | 4652 | Add rule to the marc_permissions table. | 
            
              | 4653 |  | 
            
              | 4654 | =over 4 | 
            
              | 4655 |  | 
            
              | 4656 | =item C<$fields> | 
            
              | 4657 |  | 
            
              | 4658 | hashref defining the table fields | 
            
              | 4659 |  | 
            
              | 4660 |       tagfield - required | 
            
              | 4661 |       tagsubfield | 
            
              | 4662 |       module - required | 
            
              | 4663 |       filter - required | 
            
              | 4664 |       on_existing - required | 
            
              | 4665 |       on_new - required | 
            
              | 4666 |       on_removed - required | 
            
              | 4667 |  | 
            
              | 4668 | =back | 
            
              | 4669 |  | 
            
              | 4670 | Returns: | 
            
              | 4671 |  | 
            
              | 4672 | =over 4 | 
            
              | 4673 |  | 
            
              | 4674 | =item C<$success> | 
            
              | 4675 |  | 
            
              | 4676 | undef if an error occurs, otherwise true. | 
            
              | 4677 |  | 
            
              | 4678 | =back | 
            
              | 4679 |  | 
            
              | 4680 | =cut | 
            
              | 4681 |  | 
            
              | 4682 | sub AddMarcPermissionsRule { | 
            
              | 4683 |     my $f = shift; | 
            
              | 4684 |     my $dbh = C4::Context->dbh; | 
            
              | 4685 |     my $query = ' | 
            
              | 4686 |     INSERT INTO `marc_permissions` | 
            
              | 4687 |     ( | 
            
              | 4688 |       tagfield, | 
            
              | 4689 |       tagsubfield, | 
            
              | 4690 |       module, | 
            
              | 4691 |       filter, | 
            
              | 4692 |       on_existing, | 
            
              | 4693 |       on_new, | 
            
              | 4694 |       on_removed | 
            
              | 4695 |     ) | 
            
              | 4696 |     VALUES (?, ?, ?, ?, ?, ?, ?) | 
            
              | 4697 |     '; | 
            
              | 4698 |     my $sth = $dbh->prepare($query); | 
            
              | 4699 |     return $sth->execute ( | 
            
              | 4700 |                       $f->{tagfield}, | 
            
              | 4701 |                       $f->{tagsubfield}, | 
            
              | 4702 |                       $f->{module}, | 
            
              | 4703 |                       $f->{filter}, | 
            
              | 4704 |                       $f->{on_existing}, | 
            
              | 4705 |                       $f->{on_new}, | 
            
              | 4706 |                       $f->{on_removed} | 
            
              | 4707 |                   ); | 
            
              | 4708 | } | 
            
              | 4709 |  | 
            
              | 4710 | =head2 DelMarcPermissionsRule | 
            
              | 4711 |  | 
            
              | 4712 |     my $success = DelMarcPermissionsRule($id) | 
            
              | 4713 |  | 
            
              | 4714 | Deletes rule from the marc_permissions table. | 
            
              | 4715 |  | 
            
              | 4716 | =over 4 | 
            
              | 4717 |  | 
            
              | 4718 | =item C<$id> | 
            
              | 4719 |  | 
            
              | 4720 | rule id to delete | 
            
              | 4721 |  | 
            
              | 4722 | =back | 
            
              | 4723 |  | 
            
              | 4724 | Returns: | 
            
              | 4725 |  | 
            
              | 4726 | =over 4 | 
            
              | 4727 |  | 
            
              | 4728 | =item C<$success> | 
            
              | 4729 |  | 
            
              | 4730 | undef if an error occurs, otherwise true. | 
            
              | 4731 |  | 
            
              | 4732 | =back | 
            
              | 4733 |  | 
            
              | 4734 | =cut | 
            
              | 4735 |  | 
            
              | 4736 | sub DelMarcPermissionsRule { | 
            
              | 4737 |     my $id = shift; | 
            
              | 4738 |     my $dbh = C4::Context->dbh; | 
            
              | 4739 |     my $query = ' | 
            
              | 4740 |     DELETE FROM `marc_permissions` | 
            
              | 4741 |     WHERE | 
            
              | 4742 |       id = ? | 
            
              | 4743 |     '; | 
            
              | 4744 |     my $sth = $dbh->prepare($query); | 
            
              | 4745 |     return $sth->execute($id); | 
            
              | 4746 | } | 
        
          | 3788 | 1; | 4747 | 1; | 
        
          | 3789 |  | 4748 |  | 
        
          | 3790 |  | 4749 |  |