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