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

(-)a/misc/maintenance/dedup_authorities.pl (-1 / +330 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::Heading;
9
use Koha::SearchEngine;
10
use Koha::SearchEngine::QueryBuilder;
11
use Koha::Logger;
12
13
use Koha::Authorities;
14
15
use Getopt::Long;
16
use YAML;
17
use List::MoreUtils qw/uniq/;
18
use Pod::Usage qw( pod2usage );
19
20
=head1 NAME
21
22
misc/migration_tools/dedup_authorities.pl - Deduping authorities script
23
24
=head1 SYNOPSIS
25
26
dedup_authorities.pl [ -h ] [ -where="authid < 5000" ] -c [ -v ] [ -m d ] [ -a PERSO_NAME ]
27
28
 Options:
29
     -h --help          display usage statement
30
     -v --verbose       increase verbosity, can be repeated for greater verbosity
31
     -m --method        method for choosing the reference authority, can be: date, used, or ppn (UNIMARC)
32
                        can be repeated
33
     -w --where         a SQL WHERE statement to limit the authority records checked
34
     -c --confirm       without this parameter no changes will be made, script will run in test mode
35
     -a --authtypecode  check only specified auth type, repeatable
36
37
=head1 OPTIONS
38
39
=over
40
41
=item B<--method>
42
43
Method(s) used to choose which authority to keep in case we found
44
duplicates.
45
<methods> is a string composed of letters describing what methods to use
46
and in which order.
47
Letters can be:
48
    date:  keep the most recent authority (based on 005 field)
49
    used:  keep the most used authority
50
    ppn:   PPN (UNIMARC only), keep the authority with a ppn (when some
51
        authorities don't have one, based on 009 field)
52
53
Example:
54
-m ppn -m date -m used
55
Among the authorities that have a PPN, keep the most recent,
56
and if two (or more) have the same date in 005, keep the
57
most used.
58
59
Default is 'used'
60
61
=item B<--where>
62
63
limit the deduplication to SOME authorities only
64
65
Example:
66
-where="authid < 5000"
67
will only auths with a low auth_id (old records)
68
69
=item B<--verbose>
70
71
display verbose loggin, can be repeated twice for more info
72
73
74
=item B<--help>
75
76
show usage information.
77
78
=back
79
80
=cut
81
82
my @methods;
83
my @authtypecodes;
84
my $help        = 0;
85
my $confirm     = 0;
86
my $verbose     = 0;
87
my $wherestring = "";
88
my $debug       = 0;
89
90
my $result = GetOptions(
91
    "d|debug"          => \$debug,
92
    "v|verbose+"       => \$verbose,
93
    "c|confirm"        => \$confirm,
94
    "h|help"           => \$help,
95
    "w|where=s"        => \$wherestring,
96
    "m|method=s"       => \@methods,
97
    "a|authtypecode=s" => \@authtypecodes
98
);
99
100
pod2usage( -verbose => 2 ) if ($help);
101
102
print "RUNNING IN TEST MODE, NO CHANGES WILL BE MADE\n" unless $confirm;
103
$verbose = 1 unless ( $confirm || $verbose );
104
105
my @choose_subs;
106
@methods = ('used') unless @methods;
107
foreach my $method (@methods) {
108
    if ( $method eq 'date' ) {
109
        push @choose_subs, \&_get_date;
110
    } elsif ( $method eq 'ppn' ) {
111
        die 'PPN method is only valid for UNIMARC'
112
            unless ( C4::Context->preference('marcflavour') eq 'UNIMARC' );
113
        push @choose_subs, \&_has_ppn;
114
    } elsif ( $method eq 'used' ) {
115
        push @choose_subs, \&_get_usage;
116
    } else {
117
        warn "Choose method '$method' is not supported";
118
    }
119
}
120
121
my $dbh = C4::Context->dbh;
122
123
$verbose and print "Fetching authtypecodes...\n";
124
my $params = undef;
125
if (@authtypecodes) {
126
    $params = { authtypecode => { -in => \@authtypecodes } };
127
}
128
my @auth_types = Koha::Authority::Types->search($params)->as_list;
129
my %auth_match_headings =
130
    map { $_->authtypecode => $_->auth_tag_to_report } @auth_types;
131
$verbose and print "Fetching authtypecodes done.\n";
132
133
my %biblios;
134
my $seen;
135
136
for my $authtype (@auth_types) {
137
    my $authtypecode = $authtype->authtypecode;
138
    my %duplicated;
139
    my $deleted      = 0;
140
    my $updated_bibs = 0;
141
    my $i            = 0;
142
    $verbose and print "Deduping authtype '$authtypecode' \n";
143
144
    $verbose and print "Fetching authorities for '$authtypecode'... ";
145
    my $authorities = Koha::Authorities->search( { authtypecode => $authtypecode } );
146
    $authorities = $authorities->search( \$wherestring ) if $wherestring;
147
    my $size = $authorities->count;
148
    $verbose and print "$size authorities found\n";
149
150
    while ( my $authority = $authorities->next ) {
151
        next if defined $seen->{ $authority->authid };
152
        $seen->{ $authority->authid } = 1;
153
        $i++;
154
        if ( $verbose >= 2 ) {
155
            my $percentage = sprintf( "%.2f", $i * 100 / $size );
156
            print "Processing authority " . $authority->authid . " ($i/$size $percentage%)\n";
157
        } elsif ( $verbose and ( $i % 100 ) == 0 ) {
158
            my $percentage = sprintf( "%.2f", $i * 100 / $size );
159
            print "Progression for authtype '$authtypecode': $i/$size ($percentage%)\n";
160
        }
161
162
        #authority was marked as duplicate
163
        next if defined $duplicated{ $authority->authid };
164
        my $authrecord = C4::AuthoritiesMarc::GetAuthority( $authority->authid );
165
166
        next unless $authrecord;
167
        C4::Charset::SetUTF8Flag($authrecord);
168
169
        $debug and print "    Building query...\n";
170
        my $field = $authrecord->field( $auth_match_headings{$authtypecode} );
171
        unless ($field) {
172
            warn "    Malformed authority record, no heading";
173
            next;
174
        }
175
        unless ( $field->as_string ) {
176
            warn "    Malformed authority record, blank heading";
177
            next;
178
        }
179
        my $heading     = C4::Heading->new_from_field( $field, undef, 1 );    #new auth heading
180
        my $search_term = $heading->search_form;
181
        $debug and print "    Building query done\n";
182
        $debug and print "    $search_term\n";
183
184
        $debug and print "    Searching...";
185
186
        my $builder  = Koha::SearchEngine::QueryBuilder->new( { index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
187
        my $searcher = Koha::SearchEngine::Search->new( { index => $Koha::SearchEngine::AUTHORITIES_INDEX } );
188
        my $query    = $builder->build_authorities_query_compat(
189
            ['match-heading'], [''],
190
            [''], ['exact'], [$search_term], $authtypecode, ''
191
        );
192
        my ( $results, $total ) = $searcher->search_auth_compat( $query, 0, 50, undef );
193
        if ( !$results ) {
194
            $debug and warn "    " . $@;
195
            $debug and warn "    " . YAML::Dump($search_term);
196
            $debug and warn "    " . $field->as_string;
197
            next;
198
        }
199
200
        $debug and warn "    " . YAML::Dump($results);
201
202
        my @recordids =
203
            map { $_->{authid} != $authority->authid ? $_->{authid} : () } @$results;
204
        if ( !$results || scalar(@$results) < 1 || scalar @recordids < 1 ) {
205
            ( $verbose >= 2 )
206
                and print '    No duplicates found for ' . $heading->display_form . "\n";
207
            next;
208
        }
209
        map { $seen->{$_} = 1 } @recordids;
210
        $debug and print "    Searching done.\n";
211
212
        $debug and print "    Choosing records...";
213
        my ( $recordid_to_keep, @recordids_to_merge ) = _choose_records( $authority->authid, @recordids );
214
        $debug and print "    Choosing records done.\n";
215
        unless ( !$confirm or @recordids_to_merge == 0 ) {
216
            ( $verbose >= 2 )
217
                and print "    Merging " . join( ',', @recordids_to_merge ) . " into $recordid_to_keep.\n";
218
            for my $localauthid (@recordids_to_merge) {
219
                next if $recordid_to_keep == $localauthid;
220
                my $MARCto        = C4::AuthoritiesMarc::GetAuthority($recordid_to_keep);
221
                my $editedbiblios = 0;
222
                eval {
223
                    $editedbiblios = C4::AuthoritiesMarc::merge(
224
                        {
225
                            mergefrom => $localauthid,
226
                            MARCfrom  => undef,
227
                            mergeto   => $recordid_to_keep,
228
                            MARCto    => $MARCto
229
                        }
230
                    );
231
                };
232
                if ($@) {
233
                    warn "    Merging $localauthid into $recordid_to_keep failed :",
234
                        $@;
235
                } else {
236
                    print "    Updated " . $editedbiblios . " biblios\n";
237
                    $updated_bibs += $editedbiblios;
238
                    $duplicated{$localauthid} = 2;
239
                    print "    Deleting $localauthid\n";
240
                    C4::AuthoritiesMarc::DelAuthority( { authid => $localauthid, skip_merge => 1 } );
241
                    $deleted++;
242
                }
243
            }
244
            ( $verbose >= 2 ) and print "    Merge done.\n";
245
            $duplicated{$recordid_to_keep} = 1;
246
        } elsif ( $verbose >= 2 ) {
247
            if ( @recordids_to_merge > 0 ) {
248
                print '    Would merge '
249
                    . join( ',', @recordids_to_merge )
250
                    . " into $recordid_to_keep ("
251
                    . $heading->display_form . ")\n";
252
            } else {
253
                print "    No duplicates found for $recordid_to_keep\n";
254
            }
255
        }
256
    }
257
    $verbose and print "End of deduping for authtype '$authtypecode'\n";
258
    $verbose and print "Updated $updated_bibs biblios\n";
259
    $verbose and print "Deleted $deleted authorities\n";
260
}
261
262
# Update biblios
263
my @biblios_to_update = grep { defined $biblios{$_} and $biblios{$_} == 1 }
264
    keys %biblios;
265
if ( @biblios_to_update > 0 ) {
266
} else {
267
    print "No biblios to update\n";
268
}
269
270
exit 0;
271
272
sub _get_id {
273
    my $record = shift;
274
275
    if ( $record and ( my $field = $record->field('001') ) ) {
276
        return $field->data();
277
    }
278
    return 0;
279
}
280
281
sub _has_ppn {
282
    my $record = shift;
283
284
    if ( $record and ( my $field = $record->field('009') ) ) {
285
        return $field->data() ? 1 : 0;
286
    }
287
    return 0;
288
}
289
290
sub _get_date {
291
    my $record = shift;
292
293
    if ( $record and ( my $field = $record->field('005') ) ) {
294
        return $field->data();
295
    }
296
    return 0;
297
}
298
299
sub _get_usage {
300
    my $record = shift;
301
302
    if ( $record and ( my $field = $record->field('001') ) ) {
303
        return Koha::Authorities->get_usage_count( { authid => $field->data() } );
304
    }
305
    return 0;
306
}
307
308
=head2 _choose_records
309
    this function takes input of candidate record ids to merging
310
    and returns
311
        first the record to merge to
312
        and list of records to merge from
313
=cut
314
315
sub _choose_records {
316
    my @recordids = @_;
317
318
    my @records         = map { C4::AuthoritiesMarc::GetAuthority($_) } @recordids;
319
    my @candidate_auths = @records;
320
321
    # See http://www.sysarch.com/Perl/sort_paper.html Schwartzian transform
322
    my @candidate_authids =
323
        map $_->[0] => sort { $b->[1] <=> $a->[1] || $b->[2] <=> $a->[2] || $b->[3] <=> $a->[3] }
324
        map [ _get_id($_),
325
        $choose_subs[0] ? $choose_subs[0]->($_) : 0,
326
        $choose_subs[1] ? $choose_subs[1]->($_) : 0,
327
        $choose_subs[2] ? $choose_subs[2]->($_) : 0 ] => ( $records[0], @candidate_auths );
328
329
    return @candidate_authids;
330
}

Return to bug 13706