| 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 |             $debug and $query and warn $query; | 
            
              | 147 |             # This prevent too general queries to be executed | 
            
              | 148 |             # TODO: This should allow more than these 3 indexes | 
            
              | 149 |             next unless $query =~ /(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 | } |