Bug 17913: [3.22.x] Authority merge fix

[PUSHED_17.05]

Squashed into one patch for 3.22.x.

diff --git a/C4/AuthoritiesMarc.pm b/C4/AuthoritiesMarc.pm
index dd8be73..11dcf0d 100644 (file)
--- a/C4/AuthoritiesMarc.pm
+++ b/C4/AuthoritiesMarc.pm
@@ -1499,46 +1499,67 @@ sub merge {
     #warn scalar(@reccache)." biblios to update";
     # Get All candidate Tags for the change 
     # (This will reduce the search scope in marc records).
-    $sth = $dbh->prepare("select distinct tagfield from marc_subfield_structure where authtypecode=?");
-    $sth->execute($authtypecodefrom);
-    my @tags_using_authtype;
-    while (my ($tagfield) = $sth->fetchrow) {
-        push @tags_using_authtype,$tagfield ;
-    }
-    my $tag_to=0;  
+    my $sql = "SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode=?";
+    my $tags_using_authtype = $dbh->selectcol_arrayref( $sql, undef, ( $authtypecodefrom ));
+    my $tags_new;
     if ($authtypecodeto ne $authtypecodefrom){  
-        # If many tags, take the first
-        $sth->execute($authtypecodeto);    
-        $tag_to=$sth->fetchrow;
-        #warn $tag_to;    
+        $tags_new = $dbh->selectcol_arrayref( $sql, undef, ( $authtypecodeto ));
     }  
     # BulkEdit marc records
     # May be used as a template for a bulkedit field  
+    my $overwrite = C4::Context->preference( 'AuthorityMergeMode' ) eq 'strict';
+    my $skip_subfields = $overwrite
+        # This hash contains all subfields from the authority report fields
+        # Including $MARCfrom as well as $MARCto
+        # We only need it in loose merge mode; replaces the former $exclude
+        ? {}
+        : { map { ( $_->[0], 1 ); } ( @record_from, @record_to ) };
+    # And we need to add $9 in order not to duplicate
+    $skip_subfields->{9} = 1 if !$overwrite;
+
     foreach my $marcrecord(@reccache){
         my $update = 0;
-        foreach my $tagfield (@tags_using_authtype){
+        foreach my $tagfield (@$tags_using_authtype) {
 #             warn "tagfield : $tagfield ";
+            my $countfrom = 0; # used in strict mode to remove duplicates
             foreach my $field ($marcrecord->field($tagfield)){
                 # biblio is linked to authority with $9 subfield containing authid
                 my $auth_number=$field->subfield("9");
-                my $tag=$field->tag();          
-                if ($auth_number==$mergefrom) {
-                my $field_to=MARC::Field->new(($tag_to?$tag_to:$tag),$field->indicator(1),$field->indicator(2),"9"=>$mergeto);
-               my $exclude='9';
+                my $tag=$field->tag();
+                next if !defined($auth_number) || $auth_number ne $mergefrom;
+                $countfrom++;
+                if( $overwrite && $countfrom > 1 ) {
+                    # remove this duplicate in strict mode
+                    $marcrecord->delete_field( $field );
+                    $update = 1;
+                    next;
+                }
+                my $newtag = $tags_new
+                    ? _merge_newtag( $tag, $tags_new )
+                    : $tag;
+                    my $field_to = MARC::Field->new(
+                        $newtag,
+                        $field->indicator(1),
+                        $field->indicator(2),
+                        "9" => $mergeto,
+                    );
                 foreach my $subfield (grep {$_->[0] ne '9'} @record_to) {
                     $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
-                   $exclude.= $subfield->[0];
                 }
-               $exclude='['.$exclude.']';
-#              add subfields in $field not included in @record_to
-               my @restore= grep {$_->[0]!~/$exclude/} $field->subfields();
-                foreach my $subfield (@restore) {
-                   $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
-               }
-                $marcrecord->delete_field($field);
-                $marcrecord->insert_grouped_field($field_to);            
-                $update=1;
+                if( !$overwrite ) {
+                    # add subfields back in loose mode, check skip_subfields
+                    foreach my $subfield ( $field->subfields ) {
+                        next if $skip_subfields->{ $subfield->[0] };
+                        $field_to->add_subfields( $subfield->[0], $subfield->[1] );
+                    }
                 }
+            if( $tags_new ) {
+                $marcrecord->delete_field( $field );
+                append_fields_ordered( $marcrecord, $field_to );
+            } else {
+                $field->replace_with($field_to);
+            }
+                $update=1;
             }#for each tag
         }#foreach tagfield
         my ($bibliotag,$bibliosubf) = GetMarcFromKohaField("biblio.biblionumber","") ;
@@ -1610,6 +1631,34 @@ sub merge {
 #   }#foreach $marc
 }#sub
 
+sub _merge_newtag {
+# Routine is only called for an (exceptional) authtypecode change
+# Fixes old behavior of returning the first tag found
+    my ( $oldtag, $new_tags ) = @_;
+
+    # If we e.g. have 650 and 151,651,751 try 651 and check presence
+    my $prefix = substr( $oldtag, 0, 1 );
+    my $guess = $prefix . substr( $new_tags->[0], -2 );
+    if( grep { $_ eq $guess } @$new_tags ) {
+        return $guess;
+    }
+    # Otherwise return one from the same block e.g. 6XX for 650
+    # If not there too, fall back to first new tag (old behavior!)
+    my @same_block = grep { /^$prefix/ } @$new_tags;
+    return @same_block ? $same_block[0] : $new_tags->[0];
+}
+
+sub append_fields_ordered {
+# while we lack this function in MARC::Record
+# we do not want insert_fields_ordered since it inserts before
+    my ( $record, $field ) = @_;
+    if( my @flds = $record->field( $field->tag ) ) {
+        $record->insert_fields_after( pop @flds, $field );
+    } else { # now fallback to insert_fields_ordered
+        $record->insert_fields_ordered( $field );
+    }
+}
+
 =head2 get_auth_type_location
 
   my ($tag, $subfield) = get_auth_type_location($auth_type_code);

diff --git a/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/authorities.pref b/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/authorities.pref
index 2762411..7237035 100644 (file)
--- a/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/authorities.pref
+++ b/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/authorities.pref
@@ -49,6 +49,15 @@ Authorities:
               defautl: "afrey50      ba0"
               type: textarea
               class: code
+        -
+            - When updating biblio records from an attached authority record ("merging"), handle subfields of relevant biblio record fields in
+            - pref: AuthorityMergeMode
+              default: "loose"
+              choices:
+                  "loose": loose
+                  "strict": strict
+            - mode. In strict mode subfields that are not found in the authority record, are deleted. Loose mode will keep them. Loose mode is the historical behavior and still the default.
+
     Linker:
         -
             - Use the

diff --git a/t/db_dependent/Authorities/Merge.t b/t/db_dependent/Authorities/Merge.t
index 50e4520..3102695 100755 (executable)
--- a/t/db_dependent/Authorities/Merge.t
+++ b/t/db_dependent/Authorities/Merge.t
@@ -10,6 +10,7 @@ use MARC::Record;
 use Test::MockModule;
 use Test::MockObject;
 
+use t::lib::Mocks;
 use t::lib::TestBuilder;
 
 use C4::Biblio;
@@ -40,6 +41,9 @@ subtest 'Test merge A1 to A2 (within same authtype)' => sub {
 # Tests originate from bug 11700
     plan tests => 9;
 
+    # Start in loose mode, although it actually does not matter here
+    t::lib::Mocks::mock_preference('AuthorityMergeMode', 'loose');
+
     # Add two authority records
     my $auth1 = MARC::Record->new;
     $auth1->append_fields( MARC::Field->new( '109', '0', '0', 'a' => 'George Orwell' ));
@@ -65,23 +69,23 @@ subtest 'Test merge A1 to A2 (within same authtype)' => sub {
     # Check the results
     my $newbiblio1 = GetMarcBiblio($biblionumber1);
     $newbiblio1->delete_fields( $newbiblio1->field('100') ); # fix for UNIMARC
-    compare_field_count( $biblio1, $newbiblio1, 1 );
-    compare_field_order( $biblio1, $newbiblio1, 1 );
+    compare_field_count( $biblio1, $newbiblio1 );
+    compare_field_order( $biblio1, $newbiblio1 );
     is( $newbiblio1->subfield('609', '9'), $authid1, 'Check biblio1 609$9' );
     is( $newbiblio1->subfield('609', 'a'), 'George Orwell',
         'Check biblio1 609$a' );
     my $newbiblio2 = GetMarcBiblio($biblionumber2);
     $newbiblio2->delete_fields( $newbiblio2->field('100') ); # fix for UNIMARC
-    compare_field_count( $biblio2, $newbiblio2, 1 );
-    compare_field_order( $biblio2, $newbiblio2, 1 );
+    compare_field_count( $biblio2, $newbiblio2 );
+    compare_field_order( $biblio2, $newbiblio2 );
     is( $newbiblio2->subfield('609', '9'), $authid1, 'Check biblio2 609$9' );
     is( $newbiblio2->subfield('609', 'a'), 'George Orwell',
         'Check biblio2 609$a' );
 };
 
-subtest 'Test merge A1 to modified A1' => sub {
+subtest 'Test merge A1 to modified A1, test strict mode' => sub {
 # Tests originate from bug 11700
-    plan tests => 8;
+    plan tests => 11;
 
     # Simulate modifying an authority from auth1old to auth1new
     my $auth1old = MARC::Record->new;
@@ -94,40 +98,58 @@ subtest 'Test merge A1 to modified A1' => sub {
     my $MARC1 = MARC::Record->new;
     $MARC1->append_fields( MARC::Field->new( '109', '', '', 'a' => 'Bruce Wayne', 'b' => '2014', '9' => $authid1 ));
     $MARC1->append_fields( MARC::Field->new( '245', '', '', 'a' => 'From the depths' ));
+    $MARC1->append_fields( MARC::Field->new( '609', '', '', 'a' => 'Bruce Lee', 'b' => 'Should be cleared too', '9' => $authid1 ));
+    $MARC1->append_fields( MARC::Field->new( '609', '', '', 'a' => 'Bruce Lee', 'c' => 'This is a duplicate to be removed in strict mode', '9' => $authid1 ));
     my $MARC2 = MARC::Record->new;
     $MARC2->append_fields( MARC::Field->new( '109', '', '', 'a' => 'Batman', '9' => $authid1 ));
     $MARC2->append_fields( MARC::Field->new( '245', '', '', 'a' => 'All the way to heaven' ));
     my ( $biblionumber1 ) = AddBiblio( $MARC1, '');
     my ( $biblionumber2 ) = AddBiblio( $MARC2, '');
 
-    # Time to merge
+    # Time to merge in loose mode first
     @zebrarecords = ( $MARC1, $MARC2 );
     $index = 0;
+    t::lib::Mocks::mock_preference('AuthorityMergeMode', 'loose');
     my $rv = C4::AuthoritiesMarc::merge( $authid1, $auth1old, $authid1, $auth1new );
     is( $rv, 2, 'Both records are updated now' );
 
     #Check the results
     my $biblio1 = GetMarcBiblio($biblionumber1);
     $biblio1->delete_fields( $biblio1->field('100') ); # quick fix for UNIMARC
-    compare_field_count( $MARC1, $biblio1, 1 );
-    compare_field_order( $MARC1, $biblio1, 1 );
+    compare_field_count( $MARC1, $biblio1 );
+    compare_field_order( $MARC1, $biblio1 );
     is( $auth1new->field(109)->subfield('a'), $biblio1->field(109)->subfield('a'), 'Record1 values updated correctly' );
     my $biblio2 = GetMarcBiblio( $biblionumber2 );
     $biblio2->delete_fields( $biblio2->field('100') ); # quick fix for UNIMARC
-    compare_field_count( $MARC2, $biblio2, 1 );
-    compare_field_order( $MARC2, $biblio2, 1 );
+    compare_field_count( $MARC2, $biblio2 );
+    compare_field_order( $MARC2, $biblio2 );
     is( $auth1new->field(109)->subfield('a'), $biblio2->field(109)->subfield('a'), 'Record2 values updated correctly' );
+    # This is only true in loose mode:
+    is( $biblio1->field(109)->subfield('b'), $MARC1->field(109)->subfield('b'), 'Subfield not overwritten in loose mode');
 
-    # TODO Following test will change when we improve merge
-    # Will depend on a preference
-    is( $biblio1->field(109)->subfield('b'), $MARC1->field(109)->subfield('b'), 'Record not overwritten while merging');
+    # Merge again in strict mode
+    t::lib::Mocks::mock_preference('AuthorityMergeMode', 'strict');
+    ModBiblio( $MARC1, $biblionumber1, '' );
+    @zebrarecords = ( $MARC1 );
+    $index = 0;
+    $rv = C4::AuthoritiesMarc::merge( $authid1, $auth1old, $authid1, $auth1new );
+    $biblio1 = GetMarcBiblio($biblionumber1);
+    $biblio1->delete_fields( $biblio1->field('100') ); # quick fix for UNIMARC
+    is( $biblio1->field(109)->subfield('b'), undef, 'Subfield overwritten in strict mode' );
+    is( $biblio1->fields, scalar( $MARC1->fields ) - 1, 'strict mode should remove a duplicate 609' );
+    is( $biblio1->field(609)->subfields,
+        scalar($auth1new->field('109')->subfields) + 1,
+        'Check number of subfields in strict mode for the remaining 609' );
+        # Note: the +1 comes from the added subfield $9 in the biblio
 };
 
 subtest 'Test merge A1 to B1 (changing authtype)' => sub {
 # Tests were aimed for bug 9988, moved to 17909 in adjusted form
 # Would not encourage this type of merge, but we should test what we offer
-# The merge routine still needs the fixes on bug 17913
-    plan tests => 8;
+    plan tests => 13;
+
+    # Get back to loose mode now
+    t::lib::Mocks::mock_preference('AuthorityMergeMode', 'loose');
 
     # create two auth recs of different type
     my $auth1 = MARC::Record->new;
@@ -162,9 +184,14 @@ subtest 'Test merge A1 to B1 (changing authtype)' => sub {
     # Get new marc record for compares
     my $newbiblio = C4::Biblio::GetMarcBiblio( $biblionumber );
     $newbiblio->delete_fields( $newbiblio->field('100') ); # fix for UNIMARC
-    compare_field_count( $oldbiblio, $newbiblio, 1 );
-    # TODO The following test will still fail; refined after 17913
-    compare_field_order( $oldbiblio, $newbiblio, 0 );
+    compare_field_count( $oldbiblio, $newbiblio );
+    # Exclude 109/609 and 112/612 in comparing order
+    compare_field_order( $oldbiblio, $newbiblio,
+        { '109' => 1, '112' => 1, '609' => 1, '612' => 1 },
+    );
+    # Check position of 612s in the new record
+    my $full_order = join q/,/, map { $_->tag } $newbiblio->fields;
+    is( $full_order =~ /611(,612){3}/, 1, 'Check position of all 612s' );
 
     # Check some fields
     is( $newbiblio->field('003')->data,
@@ -178,9 +205,23 @@ subtest 'Test merge A1 to B1 (changing authtype)' => sub {
     is( $newbiblio->subfield( '112', 'c' ),
         $auth2->subfield( '112', 'c' ), 'Check new 112c' );
 
-    #TODO Check the new 612s (after fix on 17913, they are 112s now)
-    is( $newbiblio->subfield( '612', 'a' ),
+    # Check 112b; this subfield was cleared when moving from 109 to 112
+    # Note that this fix only applies to the current loose mode only
+    is( $newbiblio->subfield( '112', 'b' ), undef,
+        'Merge respects a cleared subfield in loose mode' );
+
+    # Check the original 612
+    is( ( $newbiblio->field('612') )[0]->subfield( 'a' ),
         $oldbiblio->subfield( '612', 'a' ), 'Check untouched 612a' );
+    # Check second 612
+    is( ( $newbiblio->field('612') )[1]->subfield( 'a' ),
+        $auth2->subfield( '112', 'a' ), 'Check second touched 612a' );
+    # Check second new 612ax (in LOOSE mode)
+    is( ( $newbiblio->field('612') )[2]->subfield( 'a' ),
+        $auth2->subfield( '112', 'a' ), 'Check touched 612a' );
+    is( ( $newbiblio->field('612') )[2]->subfield( 'x' ),
+        ( $oldbiblio->field('609') )[1]->subfield('x'),
+        'Check 612x' );
 };
 
 sub set_mocks {
@@ -263,26 +304,18 @@ sub modify_framework {
 }
 
 sub compare_field_count {
-    my ( $oldmarc, $newmarc, $pass ) = @_;
+    my ( $oldmarc, $newmarc ) = @_;
     my $t;
-    if( $pass ) {
-        is( scalar $newmarc->fields, $t = $oldmarc->fields, "Number of fields still equal to $t" );
-    } else {
-        isnt( scalar $newmarc->fields, $t = $oldmarc->fields, "Number of fields not equal to $t" );
-    }
+    is( scalar $newmarc->fields, $t = $oldmarc->fields, "Number of fields still equal to $t" );
 }
 
 sub compare_field_order {
-    my ( $oldmarc, $newmarc, $pass ) = @_;
-    if( $pass ) {
-        is( ( join q/,/, map { $_->tag; } $newmarc->fields ),
-            ( join q/,/, map { $_->tag; } $oldmarc->fields ),
-            'Order of fields unchanged' );
-    } else {
-        isnt( ( join q/,/, map { $_->tag; } $newmarc->fields ),
-            ( join q/,/, map { $_->tag; } $oldmarc->fields ),
-            'Order of fields changed' );
-    }
+    my ( $oldmarc, $newmarc, $exclude ) = @_;
+    $exclude //= {};
+    my @oldfields = map { $exclude->{$_->tag} ? () : $_->tag } $oldmarc->fields;
+    my @newfields = map { $exclude->{$_->tag} ? () : $_->tag } $newmarc->fields;
+    is( ( join q/,/, @newfields ), ( join q/,/, @oldfields ),
+        'Order of fields unchanged' );
 }
 
 $schema->storage->txn_rollback;