View | Details | Raw Unified | Return to bug 17913
Collapse All | Expand All

(-)a/C4/AuthoritiesMarc.pm (-26 / +75 lines)
Lines 1499-1544 sub merge { Link Here
1499
    #warn scalar(@reccache)." biblios to update";
1499
    #warn scalar(@reccache)." biblios to update";
1500
    # Get All candidate Tags for the change 
1500
    # Get All candidate Tags for the change 
1501
    # (This will reduce the search scope in marc records).
1501
    # (This will reduce the search scope in marc records).
1502
    $sth = $dbh->prepare("select distinct tagfield from marc_subfield_structure where authtypecode=?");
1502
    my $sql = "SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode=?";
1503
    $sth->execute($authtypecodefrom);
1503
    my $tags_using_authtype = $dbh->selectcol_arrayref( $sql, undef, ( $authtypecodefrom ));
1504
    my @tags_using_authtype;
1504
    my $tags_new;
1505
    while (my ($tagfield) = $sth->fetchrow) {
1506
        push @tags_using_authtype,$tagfield ;
1507
    }
1508
    my $tag_to=0;  
1509
    if ($authtypecodeto ne $authtypecodefrom){  
1505
    if ($authtypecodeto ne $authtypecodefrom){  
1510
        # If many tags, take the first
1506
        $tags_new = $dbh->selectcol_arrayref( $sql, undef, ( $authtypecodeto ));
1511
        $sth->execute($authtypecodeto);    
1512
        $tag_to=$sth->fetchrow;
1513
        #warn $tag_to;    
1514
    }  
1507
    }  
1515
    # BulkEdit marc records
1508
    # BulkEdit marc records
1516
    # May be used as a template for a bulkedit field  
1509
    # May be used as a template for a bulkedit field  
1510
    my $overwrite = C4::Context->preference( 'AuthorityMergeMode' ) eq 'strict';
1511
    my $skip_subfields = $overwrite
1512
        # This hash contains all subfields from the authority report fields
1513
        # Including $MARCfrom as well as $MARCto
1514
        # We only need it in loose merge mode; replaces the former $exclude
1515
        ? {}
1516
        : { map { ( $_->[0], 1 ); } ( @record_from, @record_to ) };
1517
    # And we need to add $9 in order not to duplicate
1518
    $skip_subfields->{9} = 1 if !$overwrite;
1519
1517
    foreach my $marcrecord(@reccache){
1520
    foreach my $marcrecord(@reccache){
1518
        my $update = 0;
1521
        my $update = 0;
1519
        foreach my $tagfield (@tags_using_authtype){
1522
        foreach my $tagfield (@$tags_using_authtype) {
1520
#             warn "tagfield : $tagfield ";
1523
#             warn "tagfield : $tagfield ";
1524
            my $countfrom = 0; # used in strict mode to remove duplicates
1521
            foreach my $field ($marcrecord->field($tagfield)){
1525
            foreach my $field ($marcrecord->field($tagfield)){
1522
                # biblio is linked to authority with $9 subfield containing authid
1526
                # biblio is linked to authority with $9 subfield containing authid
1523
                my $auth_number=$field->subfield("9");
1527
                my $auth_number=$field->subfield("9");
1524
                my $tag=$field->tag();          
1528
                my $tag=$field->tag();
1525
                if ($auth_number==$mergefrom) {
1529
                next if !defined($auth_number) || $auth_number ne $mergefrom;
1526
                my $field_to=MARC::Field->new(($tag_to?$tag_to:$tag),$field->indicator(1),$field->indicator(2),"9"=>$mergeto);
1530
                $countfrom++;
1527
		my $exclude='9';
1531
                if( $overwrite && $countfrom > 1 ) {
1532
                    # remove this duplicate in strict mode
1533
                    $marcrecord->delete_field( $field );
1534
                    $update = 1;
1535
                    next;
1536
                }
1537
                my $newtag = $tags_new
1538
                    ? _merge_newtag( $tag, $tags_new )
1539
                    : $tag;
1540
                    my $field_to = MARC::Field->new(
1541
                        $newtag,
1542
                        $field->indicator(1),
1543
                        $field->indicator(2),
1544
                        "9" => $mergeto,
1545
                    );
1528
                foreach my $subfield (grep {$_->[0] ne '9'} @record_to) {
1546
                foreach my $subfield (grep {$_->[0] ne '9'} @record_to) {
1529
                    $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
1547
                    $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
1530
		    $exclude.= $subfield->[0];
1531
                }
1548
                }
1532
		$exclude='['.$exclude.']';
1549
                if( !$overwrite ) {
1533
#		add subfields in $field not included in @record_to
1550
                    # add subfields back in loose mode, check skip_subfields
1534
		my @restore= grep {$_->[0]!~/$exclude/} $field->subfields();
1551
                    foreach my $subfield ( $field->subfields ) {
1535
                foreach my $subfield (@restore) {
1552
                        next if $skip_subfields->{ $subfield->[0] };
1536
                   $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
1553
                        $field_to->add_subfields( $subfield->[0], $subfield->[1] );
1537
		}
1554
                    }
1538
                $marcrecord->delete_field($field);
1539
                $marcrecord->insert_grouped_field($field_to);            
1540
                $update=1;
1541
                }
1555
                }
1556
            if( $tags_new ) {
1557
                $marcrecord->delete_field( $field );
1558
                append_fields_ordered( $marcrecord, $field_to );
1559
            } else {
1560
                $field->replace_with($field_to);
1561
            }
1562
                $update=1;
1542
            }#for each tag
1563
            }#for each tag
1543
        }#foreach tagfield
1564
        }#foreach tagfield
1544
        my ($bibliotag,$bibliosubf) = GetMarcFromKohaField("biblio.biblionumber","") ;
1565
        my ($bibliotag,$bibliosubf) = GetMarcFromKohaField("biblio.biblionumber","") ;
Lines 1610-1615 sub merge { Link Here
1610
#   }#foreach $marc
1631
#   }#foreach $marc
1611
}#sub
1632
}#sub
1612
1633
1634
sub _merge_newtag {
1635
# Routine is only called for an (exceptional) authtypecode change
1636
# Fixes old behavior of returning the first tag found
1637
    my ( $oldtag, $new_tags ) = @_;
1638
1639
    # If we e.g. have 650 and 151,651,751 try 651 and check presence
1640
    my $prefix = substr( $oldtag, 0, 1 );
1641
    my $guess = $prefix . substr( $new_tags->[0], -2 );
1642
    if( grep { $_ eq $guess } @$new_tags ) {
1643
        return $guess;
1644
    }
1645
    # Otherwise return one from the same block e.g. 6XX for 650
1646
    # If not there too, fall back to first new tag (old behavior!)
1647
    my @same_block = grep { /^$prefix/ } @$new_tags;
1648
    return @same_block ? $same_block[0] : $new_tags->[0];
1649
}
1650
1651
sub append_fields_ordered {
1652
# while we lack this function in MARC::Record
1653
# we do not want insert_fields_ordered since it inserts before
1654
    my ( $record, $field ) = @_;
1655
    if( my @flds = $record->field( $field->tag ) ) {
1656
        $record->insert_fields_after( pop @flds, $field );
1657
    } else { # now fallback to insert_fields_ordered
1658
        $record->insert_fields_ordered( $field );
1659
    }
1660
}
1661
1613
=head2 get_auth_type_location
1662
=head2 get_auth_type_location
1614
1663
1615
  my ($tag, $subfield) = get_auth_type_location($auth_type_code);
1664
  my ($tag, $subfield) = get_auth_type_location($auth_type_code);
(-)a/koha-tmpl/intranet-tmpl/prog/en/modules/admin/preferences/authorities.pref (+9 lines)
Lines 49-54 Authorities: Link Here
49
              defautl: "afrey50      ba0"
49
              defautl: "afrey50      ba0"
50
              type: textarea
50
              type: textarea
51
              class: code
51
              class: code
52
        -
53
            - When updating biblio records from an attached authority record ("merging"), handle subfields of relevant biblio record fields in
54
            - pref: AuthorityMergeMode
55
              default: "loose"
56
              choices:
57
                  "loose": loose
58
                  "strict": strict
59
            - 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.
60
52
    Linker:
61
    Linker:
53
        -
62
        -
54
            - Use the
63
            - Use the
(-)a/t/db_dependent/Authorities/Merge.t (-38 / +70 lines)
Lines 10-15 use MARC::Record; Link Here
10
use Test::MockModule;
10
use Test::MockModule;
11
use Test::MockObject;
11
use Test::MockObject;
12
12
13
use t::lib::Mocks;
13
use t::lib::TestBuilder;
14
use t::lib::TestBuilder;
14
15
15
use C4::Biblio;
16
use C4::Biblio;
Lines 40-45 subtest 'Test merge A1 to A2 (within same authtype)' => sub { Link Here
40
# Tests originate from bug 11700
41
# Tests originate from bug 11700
41
    plan tests => 9;
42
    plan tests => 9;
42
43
44
    # Start in loose mode, although it actually does not matter here
45
    t::lib::Mocks::mock_preference('AuthorityMergeMode', 'loose');
46
43
    # Add two authority records
47
    # Add two authority records
44
    my $auth1 = MARC::Record->new;
48
    my $auth1 = MARC::Record->new;
45
    $auth1->append_fields( MARC::Field->new( '109', '0', '0', 'a' => 'George Orwell' ));
49
    $auth1->append_fields( MARC::Field->new( '109', '0', '0', 'a' => 'George Orwell' ));
Lines 65-87 subtest 'Test merge A1 to A2 (within same authtype)' => sub { Link Here
65
    # Check the results
69
    # Check the results
66
    my $newbiblio1 = GetMarcBiblio($biblionumber1);
70
    my $newbiblio1 = GetMarcBiblio($biblionumber1);
67
    $newbiblio1->delete_fields( $newbiblio1->field('100') ); # fix for UNIMARC
71
    $newbiblio1->delete_fields( $newbiblio1->field('100') ); # fix for UNIMARC
68
    compare_field_count( $biblio1, $newbiblio1, 1 );
72
    compare_field_count( $biblio1, $newbiblio1 );
69
    compare_field_order( $biblio1, $newbiblio1, 1 );
73
    compare_field_order( $biblio1, $newbiblio1 );
70
    is( $newbiblio1->subfield('609', '9'), $authid1, 'Check biblio1 609$9' );
74
    is( $newbiblio1->subfield('609', '9'), $authid1, 'Check biblio1 609$9' );
71
    is( $newbiblio1->subfield('609', 'a'), 'George Orwell',
75
    is( $newbiblio1->subfield('609', 'a'), 'George Orwell',
72
        'Check biblio1 609$a' );
76
        'Check biblio1 609$a' );
73
    my $newbiblio2 = GetMarcBiblio($biblionumber2);
77
    my $newbiblio2 = GetMarcBiblio($biblionumber2);
74
    $newbiblio2->delete_fields( $newbiblio2->field('100') ); # fix for UNIMARC
78
    $newbiblio2->delete_fields( $newbiblio2->field('100') ); # fix for UNIMARC
75
    compare_field_count( $biblio2, $newbiblio2, 1 );
79
    compare_field_count( $biblio2, $newbiblio2 );
76
    compare_field_order( $biblio2, $newbiblio2, 1 );
80
    compare_field_order( $biblio2, $newbiblio2 );
77
    is( $newbiblio2->subfield('609', '9'), $authid1, 'Check biblio2 609$9' );
81
    is( $newbiblio2->subfield('609', '9'), $authid1, 'Check biblio2 609$9' );
78
    is( $newbiblio2->subfield('609', 'a'), 'George Orwell',
82
    is( $newbiblio2->subfield('609', 'a'), 'George Orwell',
79
        'Check biblio2 609$a' );
83
        'Check biblio2 609$a' );
80
};
84
};
81
85
82
subtest 'Test merge A1 to modified A1' => sub {
86
subtest 'Test merge A1 to modified A1, test strict mode' => sub {
83
# Tests originate from bug 11700
87
# Tests originate from bug 11700
84
    plan tests => 8;
88
    plan tests => 11;
85
89
86
    # Simulate modifying an authority from auth1old to auth1new
90
    # Simulate modifying an authority from auth1old to auth1new
87
    my $auth1old = MARC::Record->new;
91
    my $auth1old = MARC::Record->new;
Lines 94-133 subtest 'Test merge A1 to modified A1' => sub { Link Here
94
    my $MARC1 = MARC::Record->new;
98
    my $MARC1 = MARC::Record->new;
95
    $MARC1->append_fields( MARC::Field->new( '109', '', '', 'a' => 'Bruce Wayne', 'b' => '2014', '9' => $authid1 ));
99
    $MARC1->append_fields( MARC::Field->new( '109', '', '', 'a' => 'Bruce Wayne', 'b' => '2014', '9' => $authid1 ));
96
    $MARC1->append_fields( MARC::Field->new( '245', '', '', 'a' => 'From the depths' ));
100
    $MARC1->append_fields( MARC::Field->new( '245', '', '', 'a' => 'From the depths' ));
101
    $MARC1->append_fields( MARC::Field->new( '609', '', '', 'a' => 'Bruce Lee', 'b' => 'Should be cleared too', '9' => $authid1 ));
102
    $MARC1->append_fields( MARC::Field->new( '609', '', '', 'a' => 'Bruce Lee', 'c' => 'This is a duplicate to be removed in strict mode', '9' => $authid1 ));
97
    my $MARC2 = MARC::Record->new;
103
    my $MARC2 = MARC::Record->new;
98
    $MARC2->append_fields( MARC::Field->new( '109', '', '', 'a' => 'Batman', '9' => $authid1 ));
104
    $MARC2->append_fields( MARC::Field->new( '109', '', '', 'a' => 'Batman', '9' => $authid1 ));
99
    $MARC2->append_fields( MARC::Field->new( '245', '', '', 'a' => 'All the way to heaven' ));
105
    $MARC2->append_fields( MARC::Field->new( '245', '', '', 'a' => 'All the way to heaven' ));
100
    my ( $biblionumber1 ) = AddBiblio( $MARC1, '');
106
    my ( $biblionumber1 ) = AddBiblio( $MARC1, '');
101
    my ( $biblionumber2 ) = AddBiblio( $MARC2, '');
107
    my ( $biblionumber2 ) = AddBiblio( $MARC2, '');
102
108
103
    # Time to merge
109
    # Time to merge in loose mode first
104
    @zebrarecords = ( $MARC1, $MARC2 );
110
    @zebrarecords = ( $MARC1, $MARC2 );
105
    $index = 0;
111
    $index = 0;
112
    t::lib::Mocks::mock_preference('AuthorityMergeMode', 'loose');
106
    my $rv = C4::AuthoritiesMarc::merge( $authid1, $auth1old, $authid1, $auth1new );
113
    my $rv = C4::AuthoritiesMarc::merge( $authid1, $auth1old, $authid1, $auth1new );
107
    is( $rv, 2, 'Both records are updated now' );
114
    is( $rv, 2, 'Both records are updated now' );
108
115
109
    #Check the results
116
    #Check the results
110
    my $biblio1 = GetMarcBiblio($biblionumber1);
117
    my $biblio1 = GetMarcBiblio($biblionumber1);
111
    $biblio1->delete_fields( $biblio1->field('100') ); # quick fix for UNIMARC
118
    $biblio1->delete_fields( $biblio1->field('100') ); # quick fix for UNIMARC
112
    compare_field_count( $MARC1, $biblio1, 1 );
119
    compare_field_count( $MARC1, $biblio1 );
113
    compare_field_order( $MARC1, $biblio1, 1 );
120
    compare_field_order( $MARC1, $biblio1 );
114
    is( $auth1new->field(109)->subfield('a'), $biblio1->field(109)->subfield('a'), 'Record1 values updated correctly' );
121
    is( $auth1new->field(109)->subfield('a'), $biblio1->field(109)->subfield('a'), 'Record1 values updated correctly' );
115
    my $biblio2 = GetMarcBiblio( $biblionumber2 );
122
    my $biblio2 = GetMarcBiblio( $biblionumber2 );
116
    $biblio2->delete_fields( $biblio2->field('100') ); # quick fix for UNIMARC
123
    $biblio2->delete_fields( $biblio2->field('100') ); # quick fix for UNIMARC
117
    compare_field_count( $MARC2, $biblio2, 1 );
124
    compare_field_count( $MARC2, $biblio2 );
118
    compare_field_order( $MARC2, $biblio2, 1 );
125
    compare_field_order( $MARC2, $biblio2 );
119
    is( $auth1new->field(109)->subfield('a'), $biblio2->field(109)->subfield('a'), 'Record2 values updated correctly' );
126
    is( $auth1new->field(109)->subfield('a'), $biblio2->field(109)->subfield('a'), 'Record2 values updated correctly' );
127
    # This is only true in loose mode:
128
    is( $biblio1->field(109)->subfield('b'), $MARC1->field(109)->subfield('b'), 'Subfield not overwritten in loose mode');
120
129
121
    # TODO Following test will change when we improve merge
130
    # Merge again in strict mode
122
    # Will depend on a preference
131
    t::lib::Mocks::mock_preference('AuthorityMergeMode', 'strict');
123
    is( $biblio1->field(109)->subfield('b'), $MARC1->field(109)->subfield('b'), 'Record not overwritten while merging');
132
    ModBiblio( $MARC1, $biblionumber1, '' );
133
    @zebrarecords = ( $MARC1 );
134
    $index = 0;
135
    $rv = C4::AuthoritiesMarc::merge( $authid1, $auth1old, $authid1, $auth1new );
136
    $biblio1 = GetMarcBiblio($biblionumber1);
137
    $biblio1->delete_fields( $biblio1->field('100') ); # quick fix for UNIMARC
138
    is( $biblio1->field(109)->subfield('b'), undef, 'Subfield overwritten in strict mode' );
139
    is( $biblio1->fields, scalar( $MARC1->fields ) - 1, 'strict mode should remove a duplicate 609' );
140
    is( $biblio1->field(609)->subfields,
141
        scalar($auth1new->field('109')->subfields) + 1,
142
        'Check number of subfields in strict mode for the remaining 609' );
143
        # Note: the +1 comes from the added subfield $9 in the biblio
124
};
144
};
125
145
126
subtest 'Test merge A1 to B1 (changing authtype)' => sub {
146
subtest 'Test merge A1 to B1 (changing authtype)' => sub {
127
# Tests were aimed for bug 9988, moved to 17909 in adjusted form
147
# Tests were aimed for bug 9988, moved to 17909 in adjusted form
128
# Would not encourage this type of merge, but we should test what we offer
148
# Would not encourage this type of merge, but we should test what we offer
129
# The merge routine still needs the fixes on bug 17913
149
    plan tests => 13;
130
    plan tests => 8;
150
151
    # Get back to loose mode now
152
    t::lib::Mocks::mock_preference('AuthorityMergeMode', 'loose');
131
153
132
    # create two auth recs of different type
154
    # create two auth recs of different type
133
    my $auth1 = MARC::Record->new;
155
    my $auth1 = MARC::Record->new;
Lines 162-170 subtest 'Test merge A1 to B1 (changing authtype)' => sub { Link Here
162
    # Get new marc record for compares
184
    # Get new marc record for compares
163
    my $newbiblio = C4::Biblio::GetMarcBiblio( $biblionumber );
185
    my $newbiblio = C4::Biblio::GetMarcBiblio( $biblionumber );
164
    $newbiblio->delete_fields( $newbiblio->field('100') ); # fix for UNIMARC
186
    $newbiblio->delete_fields( $newbiblio->field('100') ); # fix for UNIMARC
165
    compare_field_count( $oldbiblio, $newbiblio, 1 );
187
    compare_field_count( $oldbiblio, $newbiblio );
166
    # TODO The following test will still fail; refined after 17913
188
    # Exclude 109/609 and 112/612 in comparing order
167
    compare_field_order( $oldbiblio, $newbiblio, 0 );
189
    compare_field_order( $oldbiblio, $newbiblio,
190
        { '109' => 1, '112' => 1, '609' => 1, '612' => 1 },
191
    );
192
    # Check position of 612s in the new record
193
    my $full_order = join q/,/, map { $_->tag } $newbiblio->fields;
194
    is( $full_order =~ /611(,612){3}/, 1, 'Check position of all 612s' );
168
195
169
    # Check some fields
196
    # Check some fields
170
    is( $newbiblio->field('003')->data,
197
    is( $newbiblio->field('003')->data,
Lines 178-186 subtest 'Test merge A1 to B1 (changing authtype)' => sub { Link Here
178
    is( $newbiblio->subfield( '112', 'c' ),
205
    is( $newbiblio->subfield( '112', 'c' ),
179
        $auth2->subfield( '112', 'c' ), 'Check new 112c' );
206
        $auth2->subfield( '112', 'c' ), 'Check new 112c' );
180
207
181
    #TODO Check the new 612s (after fix on 17913, they are 112s now)
208
    # Check 112b; this subfield was cleared when moving from 109 to 112
182
    is( $newbiblio->subfield( '612', 'a' ),
209
    # Note that this fix only applies to the current loose mode only
210
    is( $newbiblio->subfield( '112', 'b' ), undef,
211
        'Merge respects a cleared subfield in loose mode' );
212
213
    # Check the original 612
214
    is( ( $newbiblio->field('612') )[0]->subfield( 'a' ),
183
        $oldbiblio->subfield( '612', 'a' ), 'Check untouched 612a' );
215
        $oldbiblio->subfield( '612', 'a' ), 'Check untouched 612a' );
216
    # Check second 612
217
    is( ( $newbiblio->field('612') )[1]->subfield( 'a' ),
218
        $auth2->subfield( '112', 'a' ), 'Check second touched 612a' );
219
    # Check second new 612ax (in LOOSE mode)
220
    is( ( $newbiblio->field('612') )[2]->subfield( 'a' ),
221
        $auth2->subfield( '112', 'a' ), 'Check touched 612a' );
222
    is( ( $newbiblio->field('612') )[2]->subfield( 'x' ),
223
        ( $oldbiblio->field('609') )[1]->subfield('x'),
224
        'Check 612x' );
184
};
225
};
185
226
186
sub set_mocks {
227
sub set_mocks {
Lines 263-288 sub modify_framework { Link Here
263
}
304
}
264
305
265
sub compare_field_count {
306
sub compare_field_count {
266
    my ( $oldmarc, $newmarc, $pass ) = @_;
307
    my ( $oldmarc, $newmarc ) = @_;
267
    my $t;
308
    my $t;
268
    if( $pass ) {
309
    is( scalar $newmarc->fields, $t = $oldmarc->fields, "Number of fields still equal to $t" );
269
        is( scalar $newmarc->fields, $t = $oldmarc->fields, "Number of fields still equal to $t" );
270
    } else {
271
        isnt( scalar $newmarc->fields, $t = $oldmarc->fields, "Number of fields not equal to $t" );
272
    }
273
}
310
}
274
311
275
sub compare_field_order {
312
sub compare_field_order {
276
    my ( $oldmarc, $newmarc, $pass ) = @_;
313
    my ( $oldmarc, $newmarc, $exclude ) = @_;
277
    if( $pass ) {
314
    $exclude //= {};
278
        is( ( join q/,/, map { $_->tag; } $newmarc->fields ),
315
    my @oldfields = map { $exclude->{$_->tag} ? () : $_->tag } $oldmarc->fields;
279
            ( join q/,/, map { $_->tag; } $oldmarc->fields ),
316
    my @newfields = map { $exclude->{$_->tag} ? () : $_->tag } $newmarc->fields;
280
            'Order of fields unchanged' );
317
    is( ( join q/,/, @newfields ), ( join q/,/, @oldfields ),
281
    } else {
318
        'Order of fields unchanged' );
282
        isnt( ( join q/,/, map { $_->tag; } $newmarc->fields ),
283
            ( join q/,/, map { $_->tag; } $oldmarc->fields ),
284
            'Order of fields changed' );
285
    }
286
}
319
}
287
320
288
$schema->storage->txn_rollback;
321
$schema->storage->txn_rollback;
289
- 

Return to bug 17913