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

(-)a/C4/AuthoritiesMarc.pm (-15 / +49 lines)
Lines 1458-1489 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, ( $authtypefrom->authtypecode ));
1463
    my @tags_using_authtype;
1463
    my $tags_new;
1464
    while (my ($tagfield) = $sth->fetchrow) {
1465
        push @tags_using_authtype,$tagfield ;
1466
    }
1467
    my $tag_to=0;  
1468
    if ($authtypeto->authtypecode ne $authtypefrom->authtypecode){
1464
    if ($authtypeto->authtypecode ne $authtypefrom->authtypecode){
1469
        # If many tags, take the first
1465
        $tags_new = $dbh->selectcol_arrayref( $sql, undef, ( $authtypeto->authtypecode ));
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  
1476
    my $overwrite = C4::Context->preference( 'AuthorityMergeMode' ) eq 'strict';
1469
    my $overwrite = C4::Context->preference( 'AuthorityMergeMode' ) eq 'strict';
1477
    foreach my $marcrecord(@reccache){
1470
    foreach my $marcrecord(@reccache){
1478
        my $update = 0;
1471
        my $update = 0;
1479
        foreach my $tagfield (@tags_using_authtype){
1472
        foreach my $tagfield (@$tags_using_authtype){
1480
#             warn "tagfield : $tagfield ";
1473
#             warn "tagfield : $tagfield ";
1481
            foreach my $field ($marcrecord->field($tagfield)){
1474
            foreach my $field ($marcrecord->field($tagfield)){
1482
                # biblio is linked to authority with $9 subfield containing authid
1475
                # biblio is linked to authority with $9 subfield containing authid
1483
                my $auth_number=$field->subfield("9");
1476
                my $auth_number=$field->subfield("9");
1484
                my $tag=$field->tag();          
1477
                my $tag=$field->tag();
1478
                my $newtag = $tags_new
1479
                    ? _merge_newtag( $tag, $tags_new )
1480
                    : $tag;
1485
                if ($auth_number==$mergefrom) {
1481
                if ($auth_number==$mergefrom) {
1486
                my $field_to=MARC::Field->new(($tag_to?$tag_to:$tag),$field->indicator(1),$field->indicator(2),"9"=>$mergeto);
1482
                    my $field_to = MARC::Field->new(
1483
                        $newtag,
1484
                        $field->indicator(1),
1485
                        $field->indicator(2),
1486
                        "9" => $mergeto,
1487
                    );
1487
		my $exclude='9';
1488
		my $exclude='9';
1488
                foreach my $subfield (grep {$_->[0] ne '9'} @record_to) {
1489
                foreach my $subfield (grep {$_->[0] ne '9'} @record_to) {
1489
                    $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
1490
                    $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
Lines 1495-1501 sub merge { Link Here
1495
                foreach my $subfield (@restore) {
1496
                foreach my $subfield (@restore) {
1496
                   $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
1497
                   $field_to->add_subfields($subfield->[0] =>$subfield->[1]);
1497
		}
1498
		}
1498
            $field->replace_with($field_to);
1499
            if( $tags_new ) {
1500
                $marcrecord->delete_field( $field );
1501
                append_fields_ordered( $marcrecord, $field_to );
1502
            } else {
1503
                $field->replace_with($field_to);
1504
            }
1499
                $update=1;
1505
                $update=1;
1500
                }
1506
                }
1501
            }#for each tag
1507
            }#for each tag
Lines 1569-1574 sub merge { Link Here
1569
#   }#foreach $marc
1575
#   }#foreach $marc
1570
}#sub
1576
}#sub
1571
1577
1578
sub _merge_newtag {
1579
# Routine is only called for an (exceptional) authtypecode change
1580
# Fixes old behavior of returning the first tag found
1581
    my ( $oldtag, $new_tags ) = @_;
1582
1583
    # If we e.g. have 650 and 151,651,751 try 651 and check presence
1584
    my $prefix = substr( $oldtag, 0, 1 );
1585
    my $guess = $prefix . substr( $new_tags->[0], -2 );
1586
    if( grep { $_ eq $guess } @$new_tags ) {
1587
        return $guess;
1588
    }
1589
    # Otherwise return one from the same block e.g. 6XX for 650
1590
    # If not there too, fall back to first new tag (old behavior!)
1591
    my @same_block = grep { /^$prefix/ } @$new_tags;
1592
    return @same_block ? $same_block[0] : $new_tags->[0];
1593
}
1594
1595
sub append_fields_ordered {
1596
# while we lack this function in MARC::Record
1597
# we do not want insert_fields_ordered since it inserts before
1598
    my ( $record, $field ) = @_;
1599
    if( my @flds = $record->field( $field->tag ) ) {
1600
        $record->insert_fields_after( pop @flds, $field );
1601
    } else { # now fallback to insert_fields_ordered
1602
        $record->insert_fields_ordered( $field );
1603
    }
1604
}
1605
1572
=head2 get_auth_type_location
1606
=head2 get_auth_type_location
1573
1607
1574
  my ($tag, $subfield) = get_auth_type_location($auth_type_code);
1608
  my ($tag, $subfield) = get_auth_type_location($auth_type_code);
(-)a/t/db_dependent/Authorities/Merge.t (-31 / +36 lines)
Lines 67-80 subtest 'Test merge A1 to A2 (within same authtype)' => sub { Link Here
67
67
68
    # Check the results
68
    # Check the results
69
    my $newbiblio1 = GetMarcBiblio($biblionumber1);
69
    my $newbiblio1 = GetMarcBiblio($biblionumber1);
70
    compare_field_count( $biblio1, $newbiblio1, 1 );
70
    compare_field_count( $biblio1, $newbiblio1 );
71
    compare_field_order( $biblio1, $newbiblio1, 1 );
71
    compare_field_order( $biblio1, $newbiblio1 );
72
    is( $newbiblio1->subfield('609', '9'), $authid1, 'Check biblio1 609$9' );
72
    is( $newbiblio1->subfield('609', '9'), $authid1, 'Check biblio1 609$9' );
73
    is( $newbiblio1->subfield('609', 'a'), 'George Orwell',
73
    is( $newbiblio1->subfield('609', 'a'), 'George Orwell',
74
        'Check biblio1 609$a' );
74
        'Check biblio1 609$a' );
75
    my $newbiblio2 = GetMarcBiblio($biblionumber2);
75
    my $newbiblio2 = GetMarcBiblio($biblionumber2);
76
    compare_field_count( $biblio2, $newbiblio2, 1 );
76
    compare_field_count( $biblio2, $newbiblio2 );
77
    compare_field_order( $biblio2, $newbiblio2, 1 );
77
    compare_field_order( $biblio2, $newbiblio2 );
78
    is( $newbiblio2->subfield('609', '9'), $authid1, 'Check biblio2 609$9' );
78
    is( $newbiblio2->subfield('609', '9'), $authid1, 'Check biblio2 609$9' );
79
    is( $newbiblio2->subfield('609', 'a'), 'George Orwell',
79
    is( $newbiblio2->subfield('609', 'a'), 'George Orwell',
80
        'Check biblio2 609$a' );
80
        'Check biblio2 609$a' );
Lines 110-121 subtest 'Test merge A1 to modified A1' => sub { Link Here
110
110
111
    #Check the results
111
    #Check the results
112
    my $biblio1 = GetMarcBiblio($biblionumber1);
112
    my $biblio1 = GetMarcBiblio($biblionumber1);
113
    compare_field_count( $MARC1, $biblio1, 1 );
113
    compare_field_count( $MARC1, $biblio1 );
114
    compare_field_order( $MARC1, $biblio1, 1 );
114
    compare_field_order( $MARC1, $biblio1 );
115
    is( $auth1new->field(109)->subfield('a'), $biblio1->field(109)->subfield('a'), 'Record1 values updated correctly' );
115
    is( $auth1new->field(109)->subfield('a'), $biblio1->field(109)->subfield('a'), 'Record1 values updated correctly' );
116
    my $biblio2 = GetMarcBiblio( $biblionumber2 );
116
    my $biblio2 = GetMarcBiblio( $biblionumber2 );
117
    compare_field_count( $MARC2, $biblio2, 1 );
117
    compare_field_count( $MARC2, $biblio2 );
118
    compare_field_order( $MARC2, $biblio2, 1 );
118
    compare_field_order( $MARC2, $biblio2 );
119
    is( $auth1new->field(109)->subfield('a'), $biblio2->field(109)->subfield('a'), 'Record2 values updated correctly' );
119
    is( $auth1new->field(109)->subfield('a'), $biblio2->field(109)->subfield('a'), 'Record2 values updated correctly' );
120
    # This is only true in loose mode:
120
    # This is only true in loose mode:
121
    is( $biblio1->field(109)->subfield('b'), $MARC1->field(109)->subfield('b'), 'Subfield not overwritten in loose mode');
121
    is( $biblio1->field(109)->subfield('b'), $MARC1->field(109)->subfield('b'), 'Subfield not overwritten in loose mode');
Lines 135-141 subtest 'Test merge A1 to B1 (changing authtype)' => sub { Link Here
135
# Tests were aimed for bug 9988, moved to 17909 in adjusted form
135
# Tests were aimed for bug 9988, moved to 17909 in adjusted form
136
# Would not encourage this type of merge, but we should test what we offer
136
# Would not encourage this type of merge, but we should test what we offer
137
# The merge routine still needs the fixes on bug 17913
137
# The merge routine still needs the fixes on bug 17913
138
    plan tests => 8;
138
    plan tests => 12;
139
139
140
    # create two auth recs of different type
140
    # create two auth recs of different type
141
    my $auth1 = MARC::Record->new;
141
    my $auth1 = MARC::Record->new;
Lines 168-176 subtest 'Test merge A1 to B1 (changing authtype)' => sub { Link Here
168
168
169
    # Get new marc record for compares
169
    # Get new marc record for compares
170
    my $newbiblio = C4::Biblio::GetMarcBiblio( $biblionumber );
170
    my $newbiblio = C4::Biblio::GetMarcBiblio( $biblionumber );
171
    compare_field_count( $oldbiblio, $newbiblio, 1 );
171
    compare_field_count( $oldbiblio, $newbiblio );
172
    # TODO The following test will still fail; refined after 17913
172
    # Exclude 109/609 and 112/612 in comparing order
173
    compare_field_order( $oldbiblio, $newbiblio, 0 );
173
    compare_field_order( $oldbiblio, $newbiblio,
174
        { '109' => 1, '112' => 1, '609' => 1, '612' => 1 },
175
    );
176
    # Check position of 612s in the new record
177
    my $full_order = join q/,/, map { $_->tag } $newbiblio->fields;
178
    is( $full_order =~ /611(,612){3}/, 1, 'Check position of all 612s' );
174
179
175
    # Check some fields
180
    # Check some fields
176
    is( $newbiblio->field('003')->data,
181
    is( $newbiblio->field('003')->data,
Lines 184-192 subtest 'Test merge A1 to B1 (changing authtype)' => sub { Link Here
184
    is( $newbiblio->subfield( '112', 'c' ),
189
    is( $newbiblio->subfield( '112', 'c' ),
185
        $auth2->subfield( '112', 'c' ), 'Check new 112c' );
190
        $auth2->subfield( '112', 'c' ), 'Check new 112c' );
186
191
187
    #TODO Check the new 612s (after fix on 17913, they are 112s now)
192
    # Check the original 612
188
    is( $newbiblio->subfield( '612', 'a' ),
193
    is( ( $newbiblio->field('612') )[0]->subfield( 'a' ),
189
        $oldbiblio->subfield( '612', 'a' ), 'Check untouched 612a' );
194
        $oldbiblio->subfield( '612', 'a' ), 'Check untouched 612a' );
195
    # Check second 612
196
    is( ( $newbiblio->field('612') )[1]->subfield( 'a' ),
197
        $auth2->subfield( '112', 'a' ), 'Check second touched 612a' );
198
    # Check second new 612ax (in LOOSE mode)
199
    is( ( $newbiblio->field('612') )[2]->subfield( 'a' ),
200
        $auth2->subfield( '112', 'a' ), 'Check touched 612a' );
201
    is( ( $newbiblio->field('612') )[2]->subfield( 'x' ),
202
        ( $oldbiblio->field('609') )[1]->subfield('x'),
203
        'Check 612x' );
190
};
204
};
191
205
192
sub set_mocks {
206
sub set_mocks {
Lines 267-292 sub modify_framework { Link Here
267
}
281
}
268
282
269
sub compare_field_count {
283
sub compare_field_count {
270
    my ( $oldmarc, $newmarc, $pass ) = @_;
284
    my ( $oldmarc, $newmarc ) = @_;
271
    my $t;
285
    my $t;
272
    if( $pass ) {
286
    is( scalar $newmarc->fields, $t = $oldmarc->fields, "Number of fields still equal to $t" );
273
        is( scalar $newmarc->fields, $t = $oldmarc->fields, "Number of fields still equal to $t" );
274
    } else {
275
        isnt( scalar $newmarc->fields, $t = $oldmarc->fields, "Number of fields not equal to $t" );
276
    }
277
}
287
}
278
288
279
sub compare_field_order {
289
sub compare_field_order {
280
    my ( $oldmarc, $newmarc, $pass ) = @_;
290
    my ( $oldmarc, $newmarc, $exclude ) = @_;
281
    if( $pass ) {
291
    $exclude //= {};
282
        is( ( join q/,/, map { $_->tag; } $newmarc->fields ),
292
    my @oldfields = map { $exclude->{$_->tag} ? () : $_->tag } $oldmarc->fields;
283
            ( join q/,/, map { $_->tag; } $oldmarc->fields ),
293
    my @newfields = map { $exclude->{$_->tag} ? () : $_->tag } $newmarc->fields;
284
            'Order of fields unchanged' );
294
    is( ( join q/,/, @newfields ), ( join q/,/, @oldfields ),
285
    } else {
295
        'Order of fields unchanged' );
286
        isnt( ( join q/,/, map { $_->tag; } $newmarc->fields ),
287
            ( join q/,/, map { $_->tag; } $oldmarc->fields ),
288
            'Order of fields changed' );
289
    }
290
}
296
}
291
297
292
$schema->storage->txn_rollback;
298
$schema->storage->txn_rollback;
293
- 

Return to bug 17913