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

(-)a/misc/migration_tools/dedup_authorities.pl (-1 / +585 lines)
Line 0 Link Here
0
- 
1
#!/usr/bin/perl
2
use Modern::Perl;
3
use C4::Context;
4
use C4::AuthoritiesMarc;
5
use C4::Biblio;
6
use C4::Search;
7
use C4::Charset;
8
use C4::Debug;
9
use C4::ZebraIndex;
10
11
use Getopt::Long;
12
use YAML;
13
use List::MoreUtils qw/uniq/;
14
15
my @matchstrings;
16
my $choosemethod = "u";   # by default, choose to keep the most used authority
17
my ($verbose, $all, $help, $wherestring, $test);
18
19
# default is to check all these subfields for 'auth_tag_to_report'
20
my $check = 'TAGabcdefghitxyz';
21
22
my $result = GetOptions (
23
    "match=s"   => \@matchstrings
24
    , "verbose+"  => \$verbose
25
    , "all|a"  => \$all
26
    , "test|t"  => \$test
27
    , "help|h"   => \$help
28
    , "where=s"   => \$wherestring
29
    , "choose-method=s" => \$choosemethod
30
    , "check=s" => \$check
31
);
32
33
if ( $help || ! (@ARGV || $all)) {
34
    print_usage();
35
    exit 0;
36
}
37
38
my @choose_subs;
39
foreach (split //, $choosemethod) {
40
    given($_) {
41
        when ('d') {
42
            push @choose_subs, \&_get_date;
43
        }
44
        when ('p') {
45
            push @choose_subs, \&_has_ppn;
46
        }
47
        when ('u') {
48
            push @choose_subs, \&_get_usage;
49
        }
50
        default {
51
            warn "Choose method '$_' is not supported";
52
        }
53
    }
54
}
55
56
my @checks;
57
foreach my $c (split /,/, $check) {
58
    my $field = substr $c, 0, 3;
59
    my $subfields = substr $c, 3;
60
    if ($field =~ /^[0-9][0-9.]{2}$/ or $field eq "TAG") {
61
        my @subf = grep /^[0-9a-z]$/, uniq split //, $subfields;
62
        if (@subf == 0 and not MARC::Field->is_controlfield_tag($field)) {
63
            die "Field '$field' is not a control field and no subfields are given";
64
        }
65
        if (@subf > 0 and MARC::Field->is_controlfield_tag($field)) {
66
            die "Field '$field' is a control field but you have given subfields";
67
        }
68
        push @checks, {
69
            field => $field,
70
            subfields => \@subf
71
        };
72
    } else {
73
        die "'$field' is not a valid tag";
74
    }
75
}
76
77
my $dbh = C4::Context->dbh;
78
79
$verbose and logger("Fetching authtypecodes...");
80
my $authtypes_ref = $dbh->selectcol_arrayref(
81
    qq{SELECT authtypecode, auth_tag_to_report FROM auth_types},
82
    { Columns=>[1,2] }
83
);
84
my %authtypes=@$authtypes_ref;
85
$verbose and logger("Fetching authtypecodes done.");
86
87
my %biblios;
88
my %authorities;
89
my @authtypecodes = @ARGV ;
90
@authtypecodes = keys %authtypes unless(@authtypecodes);
91
92
unless (@matchstrings) {
93
    @matchstrings = ('at/152b##he/2..abxyz');
94
}
95
96
$verbose and logger("Preparing matchstrings...");
97
my @attempts = prepare_matchstrings(@matchstrings);
98
$verbose and logger("Preparing matchstrings done.");
99
100
for my $authtypecode (@authtypecodes) {
101
    $verbose and logger("Deduping authtype '$authtypecode'");
102
    $verbose and logger("Fetching all authids for '$authtypecode'... ");
103
    my @sqlparams;
104
    my $strselect
105
        = qq{SELECT authid, NULL FROM auth_header where authtypecode=?};
106
    push @sqlparams, $authtypecode;
107
    if ($wherestring) {
108
        $strselect .= " and $wherestring";
109
    }
110
    my $auth_ref
111
        = $dbh->selectcol_arrayref( $strselect, { Columns => [ 1, 2 ] },
112
        @sqlparams );
113
    $verbose and logger("Fetching authids done.");
114
    my $auth_tag = $authtypes{$authtypecode};
115
    my %hash_authorities_authtypecode;
116
    if ($auth_ref){
117
        %hash_authorities_authtypecode=@$auth_ref;
118
        $verbose and logger("Building authorities hash...");
119
        @authorities{keys %hash_authorities_authtypecode} = values %hash_authorities_authtypecode;
120
        $verbose and logger("Building authorities hash done.");
121
    }
122
    $verbose and logger("Start deduping for authtype '$authtypecode'");
123
    my $size = scalar keys %hash_authorities_authtypecode;
124
    my $i = 1;
125
    for my $authid ( keys %hash_authorities_authtypecode ) {
126
        if ($verbose >= 2) {
127
            my $percentage = sprintf("%.2f", $i * 100 / $size);
128
            logger("Processing authority $authid ($i/$size $percentage%)");
129
        } elsif ($verbose and ($i % 100) == 0) {
130
            my $percentage = sprintf("%.2f", $i * 100 / $size);
131
            logger("Progression for authtype '$authtypecode': $i/$size ($percentage%)");
132
        }
133
134
        #authority was marked as duplicate
135
        next if $authorities{$authid};
136
        my $authrecord = GetAuthority($authid);
137
138
        # next if cannot take authority
139
        next unless $authrecord;
140
        SetUTF8Flag($authrecord);
141
        my $success;
142
        for my $attempt (@attempts) {
143
            ($verbose >= 2) and logger("Building query...");
144
            my $query = _build_query( $authrecord, $attempt );
145
            ($verbose >= 2) and logger("Building query done.");
146
            ($verbose >= 2) and logger ($query);
147
            # This prevent too general queries to be executed
148
            # TODO: This should allow more than these 3 indexes
149
            next unless $query =~ /(ppn|he|he-main|ident)(,\S*)*(=|:)/;
150
151
            ($verbose >= 2) and logger("Searching...");
152
            my ($error, $results) = SimpleSearch($query, undef, undef, ["authorityserver"]);
153
            if ( $error || !$results ) {
154
                $debug and warn $@;
155
                $debug and warn $error;
156
                $debug and warn YAML::Dump($query);
157
                $debug and warn $auth_tag;
158
                next;
159
            }
160
            $debug and warn YAML::Dump($results);
161
            next if ( !$results or scalar( @$results ) < 1 );
162
            my @recordids = map {
163
                _get_id( MARC::Record->new_from_usmarc($_) )
164
            } @$results;
165
            ($verbose >= 2) and logger("Searching done.");
166
167
            ($verbose >= 2) and logger("Choosing records...");
168
            my ( $recordid_to_keep, @recordids_to_merge )
169
                = _choose_records( $authid, @recordids );
170
            ($verbose >= 2) and logger("Choosing records done.");
171
            unless ($test or @recordids_to_merge == 0) {
172
                ($verbose >= 2) and logger("Merging ". join(',',@recordids_to_merge) ." into $recordid_to_keep.");
173
                for my $localauthid (@recordids_to_merge) {
174
                    my @editedbiblios = eval {
175
                        merge( $localauthid, undef, $recordid_to_keep, undef )
176
                    };
177
                    if ($@) {
178
                        warn "merging $localauthid into $recordid_to_keep failed :", $@;
179
                    } else {
180
                        for my $biblio (@editedbiblios){
181
                            $biblios{$biblio} = 1;
182
                        }
183
                        $authorities{$localauthid} = 2;
184
                    }
185
                }
186
                ($verbose >= 2) and logger("Merge done.");
187
                $authorities{$recordid_to_keep} = 1;
188
            } elsif ($verbose >= 2) {
189
                if (@recordids_to_merge > 0) {
190
                    logger('Would merge '
191
                        . join(',', @recordids_to_merge)
192
                        . " into $recordid_to_keep.");
193
                } else {
194
                    logger("No duplicates found for $recordid_to_keep");
195
                }
196
            }
197
        }
198
        $i++;
199
    }
200
    $verbose and logger("End of deduping for authtype '$authtypecode'");
201
}
202
203
# Update biblios
204
my @biblios_to_update = grep {defined $biblios{$_} and $biblios{$_} == 1}
205
                            keys %biblios;
206
if( @biblios_to_update > 0 ) {
207
    logger("Updating biblios index (" . scalar(@biblios_to_update) . " biblios to update)");
208
    C4::ZebraIndex::IndexRecord("biblio", \@biblios_to_update,
209
        { as_xml => 1, record_format => "marcxml" });
210
} else {
211
    logger("No biblios to update");
212
}
213
214
# Update authorities
215
my @authorities_to_update = grep{defined $authorities{$_} and $authorities{$_} == 1}
216
                                keys %authorities;
217
if( @authorities_to_update > 0 ) {
218
    logger("Updating authorities index (" . scalar(@authorities_to_update) . " authorities to update)");
219
    C4::ZebraIndex::IndexRecord("authority", \@authorities_to_update,
220
        { as_xml => 1, record_format => "marcxml" });
221
} else {
222
    logger("No autorities to update");
223
}
224
225
# Delete authorities
226
my @authorities_to_delete = grep{defined $authorities{$_} and $authorities{$_} == 2}
227
                                keys %authorities;
228
if( @authorities_to_delete > 0 ) {
229
    logger("Deleting authorities from index (" . scalar(@authorities_to_delete) . " authorities to delete)");
230
    C4::ZebraIndex::DeleteRecordIndex("authority", \@authorities_to_delete,
231
        { as_xml => 1, record_format => "marcxml" });
232
} else {
233
    logger("No authorities to delete");
234
}
235
236
exit 0;
237
238
sub compare_arrays{
239
    my ($arrayref1,$arrayref2)=@_;
240
    return 0 if scalar(@$arrayref1)!=scalar(@$arrayref2);
241
    my $compare=1;
242
    for (my $i=0;$i<scalar(@$arrayref1);$i++){
243
        $compare = ($compare and ($arrayref1->[$i] eq $arrayref2->[$i]));
244
    }
245
    return $compare;
246
}
247
248
sub prepare_matchstrings {
249
    my @structure;
250
    for my $matchstring (@_) {
251
        my @andstrings      = split /##/,$matchstring;
252
        my @matchelements = map {
253
            my $hash;
254
            @$hash{qw(index subfieldtag)} = split '/', $_;
255
            if ($$hash{subfieldtag}=~m/([0-9\.]{3})(.*)/) {
256
                @$hash{qw(tag subfields)}=($1,[ split (//, $2) ]);
257
            }
258
            delete $$hash{subfieldtag};
259
            $hash
260
        } @andstrings;
261
        push @structure , \@matchelements;
262
    }
263
    return @structure;
264
}
265
266
#trims the spaces before and after a string
267
#and normalize the number of spaces inside
268
sub trim{
269
    map{
270
       my $value=$_;
271
       $value=~s/\s+$//g;
272
       $value=~s/^\s+//g;
273
       $value=~s/\s+/ /g;
274
       $value;
275
    }@_
276
}
277
278
sub prepare_strings{
279
    my $authrecord=shift;
280
    my $attempt=shift;
281
    my @stringstosearch;
282
    for my $field ($authrecord->field($attempt->{tag})){
283
        if ($attempt->{tag} le '009'){
284
            if ($field->data()){
285
                push @stringstosearch, trim($field->data());
286
            }
287
        }
288
        else {
289
            if ($attempt->{subfields}){
290
                for my $subfield (@{$attempt->{subfields}}){
291
                    push @stringstosearch, trim(map { NormalizeString($_, undef, 1) } $field->subfield($subfield));
292
                }
293
            }
294
            else {
295
                push @stringstosearch,  trim(map { NormalizeString($_, undef, 1) } $field->as_string());
296
            }
297
298
        }
299
    }
300
    return map {
301
                ( $_
302
                ?  qq<$$attempt{'index'}=\"$_\">
303
                : () )
304
            }@stringstosearch;
305
}
306
307
sub _build_query{
308
    my $authrecord = shift;
309
    my $attempt = shift;
310
    if ($attempt) {
311
        my $query = join ' AND ', map {
312
            prepare_strings($authrecord, $_)
313
        } @$attempt;
314
        return $query;
315
    }
316
    return;
317
}
318
319
sub _get_id {
320
    my $record = shift;
321
322
    if($record and (my $field = $record->field('001'))) {
323
        return $field->data();
324
    }
325
    return 0;
326
}
327
328
sub _has_ppn {
329
    my $record = shift;
330
331
    if($record and (my $field = $record->field('009'))) {
332
        return $field->data() ? 1 : 0;
333
    }
334
    return 0;
335
}
336
337
sub _get_date {
338
    my $record = shift;
339
340
    if($record and (my $field = $record->field('005'))) {
341
        return $field->data();
342
    }
343
    return 0;
344
}
345
346
sub _get_usage {
347
    my $record = shift;
348
349
    if($record and (my $field = $record->field('001'))) {
350
        return CountUsage($field->data());
351
    }
352
    return 0;
353
}
354
355
=head2 _choose_records
356
    this function takes input of candidate record ids to merging
357
    and returns
358
        first the record to merge to
359
        and list of records to merge from
360
=cut
361
sub _choose_records {
362
    my @recordids = @_;
363
364
    my @records = map { GetAuthority($_) } @recordids;
365
    my @candidate_auths =
366
      grep { _is_duplicate( $recordids[0], $records[0], _get_id($_), $_ ) }
367
      ( @records[ 1 .. $#records ] );
368
369
    # See http://www.sysarch.com/Perl/sort_paper.html Schwartzian transform
370
    my @candidate_authids =
371
        map $_->[0] =>
372
        sort {
373
            $b->[1] <=> $a->[1] ||
374
            $b->[2] <=> $a->[2] ||
375
            $b->[3] <=> $a->[3]
376
        }
377
        map [
378
            _get_id($_),
379
            $choose_subs[0] ? $choose_subs[0]->($_) : 0,
380
            $choose_subs[1] ? $choose_subs[1]->($_) : 0,
381
            $choose_subs[2] ? $choose_subs[2]->($_) : 0
382
        ] =>
383
        ( $records[0], @candidate_auths );
384
385
    return @candidate_authids;
386
}
387
388
sub compare_subfields {
389
    my ($field1, $field2, $subfields) = @_;
390
391
    my $certainty = 1;
392
    foreach my $subfield (@$subfields) {
393
        $debug && warn "Comparing ". $field1->tag() ."\$$subfield ",
394
            "to ". $field2->tag(). "\$$subfield";
395
396
        my @subfields1 = $field1->subfield($subfield);
397
        my @subfields2 = $field2->subfield($subfield);
398
399
        if (compare_arrays([ trim(@subfields1) ], [ trim(@subfields2) ])) {
400
            $debug && warn "certainty 1 ", @subfields1, " ", @subfields2;
401
        } else {
402
            $debug && warn "certainty 0 ", @subfields1, " ", @subfields2;
403
            $certainty = 0;
404
            last;
405
        }
406
    }
407
408
    return $certainty;
409
}
410
411
sub _is_duplicate {
412
    my ( $authid1, $authrecord, $authid2, $marc ) = @_;
413
    return 0 if ( $authid1 == $authid2 );
414
    $authrecord ||= GetAuthority($authid1);
415
    $marc       ||= GetAuthority($authid2);
416
    if (!$authrecord){
417
        warn "no or bad record for $authid1";
418
        return 0;
419
    }
420
    if (!$marc){
421
        warn "no or bad record for $authid2";
422
        return 0;
423
    }
424
    my $at1        = GetAuthTypeCode($authid1);
425
    if (!$at1){
426
        warn "no or bad authoritytypecode for $authid1";
427
        return 0;
428
    }
429
    my $auth_tag   = $authtypes{$at1} if (exists $authtypes{$at1});
430
    my $at2        = GetAuthTypeCode($authid2);
431
    if (!$at2){
432
        warn "no or bad authoritytypecode for $authid2";
433
        return 0;
434
    }
435
    my $auth_tag2  = $authtypes{$at2} if (exists $authtypes{$at2});
436
    $debug and warn YAML::Dump($authrecord);
437
    $debug and warn YAML::Dump($marc);
438
    SetUTF8Flag($authrecord);
439
    SetUTF8Flag($marc);
440
    my $certainty = 1;
441
442
    $debug and warn "_is_duplicate ($authid1, $authid2)";
443
    if ( $marc->field($auth_tag2)
444
        and !( $authrecord->field($auth_tag) ) )
445
    {
446
        $debug && warn "certainty 0 ";
447
        return 0;
448
    }
449
    elsif ( $authrecord->field($auth_tag)
450
        && !( $marc->field($auth_tag2) ) )
451
    {
452
        $debug && warn "certainty 0 ";
453
        return 0;
454
    }
455
456
    foreach my $check (@checks) {
457
        last if ($certainty == 0);
458
        my $field = $check->{field};
459
        my $subfields = $check->{subfields};
460
        my ($tag1, $tag2) = ($field, $field);
461
        if ($field eq "TAG") {
462
            $tag1 = $auth_tag;
463
            $tag2 = $auth_tag2;
464
        }
465
466
        my @fields1 = $marc->field($tag1);
467
        my @fields2 = $authrecord->field($tag2);
468
        if (scalar @fields1 != scalar @fields2) {
469
            $debug && warn "Not the same number of fields: ",
470
                "id $authid1: ". scalar @fields1 ." fields '$tag1', ",
471
                "id $authid2: ". scalar @fields2 ." fields '$tag2'.";
472
            $certainty = 0;
473
            last;
474
        }
475
476
        for (my $i=0; $i<@fields1; $i++) {
477
            if (@$subfields > 0) {
478
                $certainty = compare_subfields($fields1[$i], $fields2[$i], $subfields);
479
                last if ($certainty == 0);
480
            } else {
481
                $debug && warn "Comparing ".$fields1[$i]->tag()." data ",
482
                    "to ".$fields2[$i]->tag()." data";
483
                if ($fields1[$i]->data() ne $fields2[$i]->data()) {
484
                    $debug && warn "certainty 0 ", $fields1[$i]->data(), " ",
485
                        $fields2[$i]->data();
486
                    $certainty = 0;
487
                    last;
488
                }
489
            }
490
        }
491
    }
492
493
    return $certainty;
494
}
495
496
sub logger {
497
    my ($sec, $min, $hour, $mday, $mon, $year) = localtime;
498
    my $time_msg = sprintf "[%04d-%02d-%02d %02d:%02d:%02d]",
499
        1900+$year, 1+$mon, $mday, $hour, $min, $sec;
500
    say $time_msg, ' ', @_;
501
}
502
503
sub print_usage {
504
    print <<_USAGE_;
505
$0: deduplicate authorities
506
507
Use this batch job to remove duplicate authorities
508
509
Parameters:
510
    --match <matchstring>
511
512
        matchstring is composed of : index1/tagsubfield1[##index2/tagsubfield2]
513
        the matching will be done with an AND between all elements of ONE
514
        matchstring.
515
        tagsubfield can be 123a or 123abc or 123.
516
517
        If multiple match parameters are sent, then it will try to match in the
518
        order it is provided to the script.
519
520
        Examples:
521
            at/152b##he-main/2..a##he/2..bxyzt##ident/009
522
            authtype/152b##he-main,ext/2..a##he,ext/2..bxyz
523
            sn,ne,st-numeric/001##authtype/152b##he-main,ext/2..a##he,ext/2..bxyz
524
525
        Match strings MUST contains at least one of the
526
        following indexes: he, he-main and ident
527
528
529
    --check <tag1><subfieldcodes>[,<tag2><subfieldcodes>[,...]]
530
531
        Check only these fields and subfields to determine whether two
532
        authorities are duplicates.
533
534
        <tag> is a three-digit number which represents the field tag, or the
535
        string 'TAG' which represents auth_tag_to_report and depends on
536
        authtypecode. You can use '.' as wildcards. E.g. '2..'
537
538
        <subfieldcodes> is a list of subfield codes, matching [0-9a-z]
539
540
        Examples:
541
            200abxyz will check subfields a,b,x,y,z of 200 fields
542
            009,152b will check 009 data and 152\$b subfields
543
            TAGab will check 250\$a and 250\$b if auth_tag_to_report is 250 for
544
                the type of the authority currently being checked
545
546
        Default: TAGabcdefghitxyz
547
548
549
    --choose-method <methods>
550
551
        Method(s) used to choose which authority to keep in case we found
552
        duplicates.
553
        <methods> is a string composed of letters describing what methods to use
554
        and in which order.
555
        Letters can be:
556
            d:  date, keep the most recent authority (based on 005 field)
557
            u:  usage, keep the most used authority
558
            p:  PPN (UNIMARC only), keep the authority with a ppn (when some
559
                authorities don't have one, based on 009 field)
560
561
        Examples:
562
            'pdu':  Among the authorities that have a PPN, keep the most recent,
563
                    and if two (or more) have the same date in 005, keep the
564
                    most used.
565
566
        Default is 'u'
567
        You cannot type more than 3 letters
568
569
570
    --where <sqlstring>     limit the deduplication to SOME authorities only
571
572
    --verbose               display logs
573
574
    --all                   deduplicate all authority type
575
576
    --help or -h            show this message.
577
578
Other paramters :
579
   Authtypecode to deduplicate authorities on
580
exemple:
581
    $0 --match ident/009 --match he-main,ext/200a##he,ext/200bxz NC
582
583
Note : If launched with DEBUG=1 it will print more messages
584
_USAGE_
585
}

Return to bug 13706