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

(-)a/C4/AuthoritiesMarc.pm (-27 / +76 lines)
Lines 1458-1503 sub merge { Link Here
1458
    #warn scalar(@reccache)." biblios to update";
1458
    #warn scalar(@reccache)." biblios to update";
1459
    # Get All candidate Tags for the change 
1459
    # Get All candidate Tags for the change 
1460
    # (This will reduce the search scope in marc records).
1460
    # (This will reduce the search scope in marc records).
1461
    my $sth = $dbh->prepare("select distinct tagfield from marc_subfield_structure where authtypecode=?");
1461
    my $sql = "SELECT DISTINCT tagfield FROM marc_subfield_structure WHERE authtypecode=?";
1462
    $sth->execute($authtypefrom->authtypecode);
1462
    my $tags_using_authtype = $dbh->selectcol_arrayref( $sql, undef, ( $authtypecodefrom ));
1463
    my @tags_using_authtype;
1463
    my $tags_new;
1464
    while (my ($tagfield) = $sth->fetchrow) {
1464
    if ($authtypecodeto ne $authtypecodefrom){  
1465
        push @tags_using_authtype,$tagfield ;
1465
        $tags_new = $dbh->selectcol_arrayref( $sql, undef, ( $authtypecodeto ));
1466
    }
1467
    my $tag_to=0;  
1468
    if ($authtypeto->authtypecode ne $authtypefrom->authtypecode){
1469
        # If many tags, take the first
1470
        $sth->execute($authtypeto->authtypecode);
1471
        $tag_to=$sth->fetchrow;
1472
        #warn $tag_to;    
1473
    }  
1466
    }  
1474
    # BulkEdit marc records
1467
    # BulkEdit marc records
1475
    # May be used as a template for a bulkedit field  
1468
    # May be used as a template for a bulkedit field  
1469
    my $overwrite = C4::Context->preference( 'AuthorityMergeMode' ) eq 'strict';
1470
    my $skip_subfields = $overwrite
1471
        # This hash contains all subfields from the authority report fields
1472
        # Including $MARCfrom as well as $MARCto
1473
        # We only need it in loose merge mode; replaces the former $exclude
1474
        ? {}
1475
        : { map { ( $_->[0], 1 ); } ( @record_from, @record_to ) };
1476
    # And we need to add $9 in order not to duplicate
1477
    $skip_subfields->{9} = 1 if !$overwrite;
1478
1476
    foreach my $marcrecord(@reccache){
1479
    foreach my $marcrecord(@reccache){
1477
        my $update = 0;
1480
        my $update = 0;
1478
        foreach my $tagfield (@tags_using_authtype){
1481
        foreach my $tagfield (@$tags_using_authtype) {
1479
#             warn "tagfield : $tagfield ";
1482
#             warn "tagfield : $tagfield ";
1483
            my $countfrom = 0; # used in strict mode to remove duplicates
1480
            foreach my $field ($marcrecord->field($tagfield)){
1484
            foreach my $field ($marcrecord->field($tagfield)){
1481
                # biblio is linked to authority with $9 subfield containing authid
1485
                # biblio is linked to authority with $9 subfield containing authid
1482
                my $auth_number=$field->subfield("9");
1486
                my $auth_number=$field->subfield("9");
1483
                my $tag=$field->tag();          
1487
                my $tag=$field->tag();
1484
                if ($auth_number==$mergefrom) {
1488
                next if !defined($auth_number) || $auth_number ne $mergefrom;
1485
                my $field_to=MARC::Field->new(($tag_to?$tag_to:$tag),$field->indicator(1),$field->indicator(2),"9"=>$mergeto);
1489
                $countfrom++;
1486
		my $exclude='9';
1490
                if( $overwrite && $countfrom > 1 ) {
1491
                    # remove this duplicate in strict mode
1492
                    $marcrecord->delete_field( $field );
1493
                    $update = 1;
1494
                    next;
1495
                }
1496
                my $newtag = $tags_new
1497
                    ? _merge_newtag( $tag, $tags_new )
1498
                    : $tag;
1499
                    my $field_to = MARC::Field->new(
1500
                        $newtag,
1501
                        $field->indicator(1),
1502
                        $field->indicator(2),
1503
                        "9" => $mergeto,
1504
                    );
1487
                foreach my $subfield (grep {$_->[0] ne '9'} @record_to) {
1505
                foreach my $subfield (grep {$_->[0] ne '9'} @record_to) {
1488
                    $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
1506
                    $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
1489
		    $exclude.= $subfield->[0];
1490
                }
1507
                }
1491
		$exclude='['.$exclude.']';
1508
                if( !$overwrite ) {
1492
#		add subfields in $field not included in @record_to
1509
                    # add subfields back in loose mode, check skip_subfields
1493
		my @restore= grep {$_->[0]!~/$exclude/} $field->subfields();
1510
                    foreach my $subfield ( $field->subfields ) {
1494
                foreach my $subfield (@restore) {
1511
                        next if $skip_subfields->{ $subfield->[0] };
1495
                   $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
1512
                        $field_to->add_subfields( $subfield->[0], $subfield->[1] );
1496
		}
1513
                    }
1497
                $marcrecord->delete_field($field);
1498
                $marcrecord->insert_grouped_field($field_to);            
1499
                $update=1;
1500
                }
1514
                }
1515
            if( $tags_new ) {
1516
                $marcrecord->delete_field( $field );
1517
                append_fields_ordered( $marcrecord, $field_to );
1518
            } else {
1519
                $field->replace_with($field_to);
1520
            }
1521
                $update=1;
1501
            }#for each tag
1522
            }#for each tag
1502
        }#foreach tagfield
1523
        }#foreach tagfield
1503
        my ($bibliotag,$bibliosubf) = GetMarcFromKohaField("biblio.biblionumber","") ;
1524
        my ($bibliotag,$bibliosubf) = GetMarcFromKohaField("biblio.biblionumber","") ;
Lines 1569-1574 sub merge { Link Here
1569
#   }#foreach $marc
1590
#   }#foreach $marc
1570
}#sub
1591
}#sub
1571
1592
1593
sub _merge_newtag {
1594
# Routine is only called for an (exceptional) authtypecode change
1595
# Fixes old behavior of returning the first tag found
1596
    my ( $oldtag, $new_tags ) = @_;
1597
1598
    # If we e.g. have 650 and 151,651,751 try 651 and check presence
1599
    my $prefix = substr( $oldtag, 0, 1 );
1600
    my $guess = $prefix . substr( $new_tags->[0], -2 );
1601
    if( grep { $_ eq $guess } @$new_tags ) {
1602
        return $guess;
1603
    }
1604
    # Otherwise return one from the same block e.g. 6XX for 650
1605
    # If not there too, fall back to first new tag (old behavior!)
1606
    my @same_block = grep { /^$prefix/ } @$new_tags;
1607
    return @same_block ? $same_block[0] : $new_tags->[0];
1608
}
1609
1610
sub append_fields_ordered {
1611
# while we lack this function in MARC::Record
1612
# we do not want insert_fields_ordered since it inserts before
1613
    my ( $record, $field ) = @_;
1614
    if( my @flds = $record->field( $field->tag ) ) {
1615
        $record->insert_fields_after( pop @flds, $field );
1616
    } else { # now fallback to insert_fields_ordered
1617
        $record->insert_fields_ordered( $field );
1618
    }
1619
}
1620
1572
=head2 get_auth_type_location
1621
=head2 get_auth_type_location
1573
1622
1574
  my ($tag, $subfield) = get_auth_type_location($auth_type_code);
1623
  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