| 
      
            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 | 
              }  |