C4/Matcher.pm

   1 package C4::Matcher;
   2
   3 # Copyright (C) 2007 LibLime, 2012 C & P Bibliography Services
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use strict;
  21 use warnings;
  22
  23 use C4::Context;
  24 use MARC::Record;
  25
  26 use vars qw();
  27
  28 BEGIN {
  29 }
  30
  31 =head1 NAME
  32
  33 C4::Matcher - find MARC records matching another one
  34
  35 =head1 SYNOPSIS
  36
  37   my @matchers = C4::Matcher::GetMatcherList();
  38
  39   my $matcher = C4::Matcher->new($record_type);
  40   $matcher->threshold($threshold);
  41   $matcher->code($code);
  42   $matcher->description($description);
  43
  44   $matcher->add_simple_matchpoint('isbn', 1000, '020', 'a', -1, 0, '');
  45   $matcher->add_simple_matchpoint('Date', 1000, '008', '', 7, 4, '');
  46   $matcher->add_matchpoint('isbn', 1000, [ { tag => '020', subfields => 'a', norms => [] } ]);
  47
  48   $matcher->add_simple_required_check('245', 'a', -1, 0, '', '245', 'a', -1, 0, '');
  49   $matcher->add_required_check([ { tag => '245', subfields => 'a', norms => [] } ],
  50                                [ { tag => '245', subfields => 'a', norms => [] } ]);
  51
  52   my @matches = $matcher->get_matches($marc_record, $max_matches);
  53
  54   foreach $match (@matches) {
  55
  56       # matches already sorted in order of
  57       # decreasing score
  58       print "record ID: $match->{'record_id'};
  59       print "score:     $match->{'score'};
  60
  61   }
  62
  63   my $matcher_description = $matcher->dump();
  64
  65 =head1 FUNCTIONS
  66
  67 =cut
  68
  69 =head2 GetMatcherList
  70
  71   my @matchers = C4::Matcher::GetMatcherList();
  72
  73 Returns an array of hashrefs list all matchers
  74 present in the database.  Each hashref includes:
  75
  76  * matcher_id
  77  * code
  78  * description
  79
  80 =cut
  81
  82 sub GetMatcherList {
  83     my $dbh = C4::Context->dbh;
  84
  85     my $sth = $dbh->prepare_cached("SELECT matcher_id, code, description FROM marc_matchers ORDER BY matcher_id");
  86     $sth->execute();
  87     my @results = ();
  88     while (my $row = $sth->fetchrow_hashref) {
  89         push @results, $row;
  90     }
  91     return @results;
  92 }
  93
  94 =head2 GetMatcherId
  95
  96   my $matcher_id = C4::Matcher::GetMatcherId($code);
  97
  98 Returns the matcher_id of a code.
  99
 100 =cut
 101
 102 sub GetMatcherId {
 103     my ($code) = @_;
 104     my $dbh = C4::Context->dbh;
 105
 106     my $matcher_id = $dbh->selectrow_array("SELECT matcher_id FROM marc_matchers WHERE code = ?", undef, $code);
 107     return $matcher_id;
 108 }
 109
 110 =head1 METHODS
 111
 112 =head2 new
 113
 114   my $matcher = C4::Matcher->new($record_type, $threshold);
 115
 116 Creates a new Matcher.  C<$record_type> indicates which search
 117 database to use, e.g., 'biblio' or 'authority' and defaults to
 118 'biblio', while C<$threshold> is the minimum score required for a match
 119 and defaults to 1000.
 120
 121 =cut
 122
 123 sub new {
 124     my $class = shift;
 125     my $self = {};
 126
 127     $self->{'id'} = undef;
 128
 129     if ($#_ > -1) {
 130         $self->{'record_type'} = shift;
 131     } else {
 132         $self->{'record_type'} = 'biblio';
 133     }
 134
 135     if ($#_ > -1) {
 136         $self->{'threshold'} = shift;
 137     } else {
 138         $self->{'threshold'} = 1000;
 139     }
 140
 141     $self->{'code'} = '';
 142     $self->{'description'} = '';
 143
 144     $self->{'matchpoints'} = [];
 145     $self->{'required_checks'} = [];
 146
 147     bless $self, $class;
 148     return $self;
 149 }
 150
 151 =head2 fetch
 152
 153   my $matcher = C4::Matcher->fetch($id);
 154
 155 Creates a matcher object from the version stored
 156 in the database.  If a matcher with the given
 157 id does not exist, returns undef.
 158
 159 =cut
 160
 161 sub fetch {
 162     my $class = shift;
 163     my $id = shift;
 164     my $dbh = C4::Context->dbh();
 165
 166     my $sth = $dbh->prepare_cached("SELECT * FROM marc_matchers WHERE matcher_id = ?");
 167     $sth->execute($id);
 168     my $row = $sth->fetchrow_hashref;
 169     $sth->finish();
 170     return undef unless defined $row;
 171
 172     my $self = {};
 173     $self->{'id'} = $row->{'matcher_id'};
 174     $self->{'record_type'} = $row->{'record_type'};
 175     $self->{'code'} = $row->{'code'};
 176     $self->{'description'} = $row->{'description'};
 177     $self->{'threshold'} = int($row->{'threshold'});
 178     bless $self, $class;
 179
 180     # matchpoints
 181     $self->{'matchpoints'} = [];
 182     $sth = $dbh->prepare_cached("SELECT * FROM matcher_matchpoints WHERE matcher_id = ? ORDER BY matchpoint_id");
 183     $sth->execute($self->{'id'});
 184     while (my $row = $sth->fetchrow_hashref) {
 185         my $matchpoint = $self->_fetch_matchpoint($row->{'matchpoint_id'});
 186         push @{ $self->{'matchpoints'} }, $matchpoint;
 187     }
 188
 189     # required checks
 190     $self->{'required_checks'} = [];
 191     $sth = $dbh->prepare_cached("SELECT * FROM matchchecks WHERE matcher_id = ? ORDER BY matchcheck_id");
 192     $sth->execute($self->{'id'});
 193     while (my $row = $sth->fetchrow_hashref) {
 194         my $source_matchpoint = $self->_fetch_matchpoint($row->{'source_matchpoint_id'});
 195         my $target_matchpoint = $self->_fetch_matchpoint($row->{'target_matchpoint_id'});
 196         my $matchcheck = {};
 197         $matchcheck->{'source_matchpoint'} = $source_matchpoint;
 198         $matchcheck->{'target_matchpoint'} = $target_matchpoint;
 199         push @{ $self->{'required_checks'} }, $matchcheck;
 200     }
 201
 202     return $self;
 203 }
 204
 205 sub _fetch_matchpoint {
 206     my $self = shift;
 207     my $matchpoint_id = shift;
 208
 209     my $dbh = C4::Context->dbh;
 210     my $sth = $dbh->prepare_cached("SELECT * FROM matchpoints WHERE matchpoint_id = ?");
 211     $sth->execute($matchpoint_id);
 212     my $row = $sth->fetchrow_hashref;
 213     my $matchpoint = {};
 214     $matchpoint->{'index'} = $row->{'search_index'};
 215     $matchpoint->{'score'} = int($row->{'score'});
 216     $sth->finish();
 217
 218     $matchpoint->{'components'} = [];
 219     $sth = $dbh->prepare_cached("SELECT * FROM matchpoint_components WHERE matchpoint_id = ? ORDER BY sequence");
 220     $sth->execute($matchpoint_id);
 221     while ($row = $sth->fetchrow_hashref) {
 222         my $component = {};
 223         $component->{'tag'} = $row->{'tag'};
 224         $component->{'subfields'} = { map { $_ => 1 } split(//,  $row->{'subfields'}) };
 225         $component->{'offset'} = int($row->{'offset'});
 226         $component->{'length'} = int($row->{'length'});
 227         $component->{'norms'} = [];
 228         my $sth2 = $dbh->prepare_cached("SELECT *
 229                                          FROM matchpoint_component_norms
 230                                          WHERE matchpoint_component_id = ? ORDER BY sequence");
 231         $sth2->execute($row->{'matchpoint_component_id'});
 232         while (my $row2 = $sth2->fetchrow_hashref) {
 233             push @{ $component->{'norms'} }, $row2->{'norm_routine'};
 234         }
 235         push @{ $matchpoint->{'components'} }, $component;
 236     }
 237     return $matchpoint;
 238 }
 239
 240 =head2 store
 241
 242   my $id = $matcher->store();
 243
 244 Stores matcher in database.  The return value is the ID
 245 of the marc_matchers row.  If the matcher was
 246 previously retrieved from the database via the fetch()
 247 method, the DB representation of the matcher
 248 is replaced.
 249
 250 =cut
 251
 252 sub store {
 253     my $self = shift;
 254
 255     if (defined $self->{'id'}) {
 256         # update
 257         $self->_del_matcher_components();
 258         $self->_update_marc_matchers();
 259     } else {
 260         # create new
 261         $self->_new_marc_matchers();
 262     }
 263     $self->_store_matcher_components();
 264     return $self->{'id'};
 265 }
 266
 267 sub _del_matcher_components {
 268     my $self = shift;
 269
 270     my $dbh = C4::Context->dbh();
 271     my $sth = $dbh->prepare_cached("DELETE FROM matchpoints WHERE matcher_id = ?");
 272     $sth->execute($self->{'id'});
 273     $sth = $dbh->prepare_cached("DELETE FROM matchchecks WHERE matcher_id = ?");
 274     $sth->execute($self->{'id'});
 275     # foreign key delete cascades take care of deleting relevant rows
 276     # from matcher_matchpoints, matchpoint_components, and
 277     # matchpoint_component_norms
 278 }
 279
 280 sub _update_marc_matchers {
 281     my $self = shift;
 282
 283     my $dbh = C4::Context->dbh();
 284     my $sth = $dbh->prepare_cached("UPDATE marc_matchers
 285                                     SET code = ?,
 286                                         description = ?,
 287                                         record_type = ?,
 288                                         threshold = ?
 289                                     WHERE matcher_id = ?");
 290     $sth->execute($self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'}, $self->{'id'});
 291 }
 292
 293 sub _new_marc_matchers {
 294     my $self = shift;
 295
 296     my $dbh = C4::Context->dbh();
 297     my $sth = $dbh->prepare_cached("INSERT INTO marc_matchers
 298                                     (code, description, record_type, threshold)
 299                                     VALUES (?, ?, ?, ?)");
 300     $sth->execute($self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'});
 301     $self->{'id'} = $dbh->{'mysql_insertid'};
 302 }
 303
 304 sub _store_matcher_components {
 305     my $self = shift;
 306
 307     my $dbh = C4::Context->dbh();
 308     my $sth;
 309     my $matcher_id = $self->{'id'};
 310     foreach my $matchpoint (@{ $self->{'matchpoints'}}) {
 311         my $matchpoint_id = $self->_store_matchpoint($matchpoint);
 312         $sth = $dbh->prepare_cached("INSERT INTO matcher_matchpoints (matcher_id, matchpoint_id)
 313                                      VALUES (?, ?)");
 314         $sth->execute($matcher_id, $matchpoint_id);
 315     }
 316     foreach my $matchcheck (@{ $self->{'required_checks'} }) {
 317         my $source_matchpoint_id = $self->_store_matchpoint($matchcheck->{'source_matchpoint'});
 318         my $target_matchpoint_id = $self->_store_matchpoint($matchcheck->{'target_matchpoint'});
 319         $sth = $dbh->prepare_cached("INSERT INTO matchchecks
 320                                      (matcher_id, source_matchpoint_id, target_matchpoint_id)
 321                                      VALUES (?, ?, ?)");
 322         $sth->execute($matcher_id, $source_matchpoint_id,  $target_matchpoint_id);
 323     }
 324
 325 }
 326
 327 sub _store_matchpoint {
 328     my $self = shift;
 329     my $matchpoint = shift;
 330
 331     my $dbh = C4::Context->dbh();
 332     my $sth;
 333     my $matcher_id = $self->{'id'};
 334     $sth = $dbh->prepare_cached("INSERT INTO matchpoints (matcher_id, search_index, score)
 335                                  VALUES (?, ?, ?)");
 336     $sth->execute($matcher_id, $matchpoint->{'index'}, $matchpoint->{'score'});
 337     my $matchpoint_id = $dbh->{'mysql_insertid'};
 338     my $seqnum = 0;
 339     foreach my $component (@{ $matchpoint->{'components'} }) {
 340         $seqnum++;
 341         $sth = $dbh->prepare_cached("INSERT INTO matchpoint_components
 342                                      (matchpoint_id, sequence, tag, subfields, offset, length)
 343                                      VALUES (?, ?, ?, ?, ?, ?)");
 344         $sth->bind_param(1, $matchpoint_id);
 345         $sth->bind_param(2, $seqnum);
 346         $sth->bind_param(3, $component->{'tag'});
 347         $sth->bind_param(4, join "", sort keys %{ $component->{'subfields'} });
 348         $sth->bind_param(5, $component->{'offset'});
 349         $sth->bind_param(6, $component->{'length'});
 350         $sth->execute();
 351         my $matchpoint_component_id = $dbh->{'mysql_insertid'};
 352         my $normseq = 0;
 353         foreach my $norm (@{ $component->{'norms'} }) {
 354             $normseq++;
 355             $sth = $dbh->prepare_cached("INSERT INTO matchpoint_component_norms
 356                                          (matchpoint_component_id, sequence, norm_routine)
 357                                          VALUES (?, ?, ?)");
 358             $sth->execute($matchpoint_component_id, $normseq, $norm);
 359         }
 360     }
 361     return $matchpoint_id;
 362 }
 363
 364
 365 =head2 delete
 366
 367   C4::Matcher->delete($id);
 368
 369 Deletes the matcher of the specified ID
 370 from the database.
 371
 372 =cut
 373
 374 sub delete {
 375     my $class = shift;
 376     my $matcher_id = shift;
 377
 378     my $dbh = C4::Context->dbh;
 379     my $sth = $dbh->prepare("DELETE FROM marc_matchers WHERE matcher_id = ?");
 380     $sth->execute($matcher_id); # relying on cascading deletes to clean up everything
 381 }
 382
 383 =head2 record_type
 384
 385   $matcher->record_type('biblio');
 386   my $record_type = $matcher->record_type();
 387
 388 Accessor method.
 389
 390 =cut
 391
 392 sub record_type {
 393     my $self = shift;
 394     @_ ? $self->{'record_type'} = shift : $self->{'record_type'};
 395 }
 396
 397 =head2 threshold
 398
 399   $matcher->threshold(1000);
 400   my $threshold = $matcher->threshold();
 401
 402 Accessor method.
 403
 404 =cut
 405
 406 sub threshold {
 407     my $self = shift;
 408     @_ ? $self->{'threshold'} = shift : $self->{'threshold'};
 409 }
 410
 411 =head2 _id
 412
 413   $matcher->_id(123);
 414   my $id = $matcher->_id();
 415
 416 Accessor method.  Note that using this method
 417 to set the DB ID of the matcher should not be
 418 done outside of the editing CGI.
 419
 420 =cut
 421
 422 sub _id {
 423     my $self = shift;
 424     @_ ? $self->{'id'} = shift : $self->{'id'};
 425 }
 426
 427 =head2 code
 428
 429   $matcher->code('ISBN');
 430   my $code = $matcher->code();
 431
 432 Accessor method.
 433
 434 =cut
 435
 436 sub code {
 437     my $self = shift;
 438     @_ ? $self->{'code'} = shift : $self->{'code'};
 439 }
 440
 441 =head2 description
 442
 443   $matcher->description('match on ISBN');
 444   my $description = $matcher->description();
 445
 446 Accessor method.
 447
 448 =cut
 449
 450 sub description {
 451     my $self = shift;
 452     @_ ? $self->{'description'} = shift : $self->{'description'};
 453 }
 454
 455 =head2 add_matchpoint
 456
 457   $matcher->add_matchpoint($index, $score, $matchcomponents);
 458
 459 Adds a matchpoint that may include multiple components.  The $index
 460 parameter identifies the index that will be searched, while $score
 461 is the weight that will be added if a match is found.
 462
 463 $matchcomponents should be a reference to an array of matchpoint
 464 compoents, each of which should be a hash containing the following
 465 keys:
 466     tag
 467     subfields
 468     offset
 469     length
 470     norms
 471
 472 The normalization_rules value should in turn be a reference to an
 473 array, each element of which should be a reference to a
 474 normalization subroutine (under C4::Normalize) to be applied
 475 to the source string.
 476
 477 =cut
 478
 479 sub add_matchpoint {
 480     my $self = shift;
 481     my ($index, $score, $matchcomponents) = @_;
 482
 483     my $matchpoint = {};
 484     $matchpoint->{'index'} = $index;
 485     $matchpoint->{'score'} = $score;
 486     $matchpoint->{'components'} = [];
 487     foreach my $input_component (@{ $matchcomponents }) {
 488         push @{ $matchpoint->{'components'} }, _parse_match_component($input_component);
 489     }
 490     push @{ $self->{'matchpoints'} }, $matchpoint;
 491 }
 492
 493 =head2 add_simple_matchpoint
 494
 495   $matcher->add_simple_matchpoint($index, $score, $source_tag,
 496                             $source_subfields, $source_offset,
 497                             $source_length, $source_normalizer);
 498
 499
 500 Adds a simple matchpoint rule -- after composing a key based on the source tag and subfields,
 501 normalized per the normalization fuction, search the index.  All records retrieved
 502 will receive the assigned score.
 503
 504 =cut
 505
 506 sub add_simple_matchpoint {
 507     my $self = shift;
 508     my ($index, $score, $source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer) = @_;
 509
 510     $self->add_matchpoint($index, $score, [
 511                           { tag => $source_tag, subfields => $source_subfields,
 512                             offset => $source_offset, 'length' => $source_length,
 513                             norms => [ $source_normalizer ]
 514                           }
 515                          ]);
 516 }
 517
 518 =head2 add_required_check
 519
 520   $match->add_required_check($source_matchpoint, $target_matchpoint);
 521
 522 Adds a required check definition.  A required check means that in
 523 order for a match to be considered valid, the key derived from the
 524 source (incoming) record must match the key derived from the target
 525 (already in DB) record.
 526
 527 Unlike a regular matchpoint, only the first repeat of each tag
 528 in the source and target match criteria are considered.
 529
 530 A typical example of a required check would be verifying that the
 531 titles and publication dates match.
 532
 533 $source_matchpoint and $target_matchpoint are each a reference to
 534 an array of hashes, where each hash follows the same definition
 535 as the matchpoint component specification in add_matchpoint, i.e.,
 536
 537     tag
 538     subfields
 539     offset
 540     length
 541     norms
 542
 543 The normalization_rules value should in turn be a reference to an
 544 array, each element of which should be a reference to a
 545 normalization subroutine (under C4::Normalize) to be applied
 546 to the source string.
 547
 548 =cut
 549
 550 sub add_required_check {
 551     my $self = shift;
 552     my ($source_matchpoint, $target_matchpoint) = @_;
 553
 554     my $matchcheck = {};
 555     $matchcheck->{'source_matchpoint'}->{'index'} = '';
 556     $matchcheck->{'source_matchpoint'}->{'score'} = 0;
 557     $matchcheck->{'source_matchpoint'}->{'components'} = [];
 558     $matchcheck->{'target_matchpoint'}->{'index'} = '';
 559     $matchcheck->{'target_matchpoint'}->{'score'} = 0;
 560     $matchcheck->{'target_matchpoint'}->{'components'} = [];
 561     foreach my $input_component (@{ $source_matchpoint }) {
 562         push @{ $matchcheck->{'source_matchpoint'}->{'components'} }, _parse_match_component($input_component);
 563     }
 564     foreach my $input_component (@{ $target_matchpoint }) {
 565         push @{ $matchcheck->{'target_matchpoint'}->{'components'} }, _parse_match_component($input_component);
 566     }
 567     push @{ $self->{'required_checks'} }, $matchcheck;
 568 }
 569
 570 =head2 add_simple_required_check
 571
 572   $matcher->add_simple_required_check($source_tag, $source_subfields,
 573                 $source_offset, $source_length, $source_normalizer,
 574                 $target_tag, $target_subfields, $target_offset,
 575                 $target_length, $target_normalizer);
 576
 577 Adds a required check, which requires that the normalized keys made from the source and targets
 578 must match for a match to be considered valid.
 579
 580 =cut
 581
 582 sub add_simple_required_check {
 583     my $self = shift;
 584     my ($source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer,
 585         $target_tag, $target_subfields, $target_offset, $target_length, $target_normalizer) = @_;
 586
 587     $self->add_required_check(
 588       [ { tag => $source_tag, subfields => $source_subfields, offset => $source_offset, 'length' => $source_length,
 589           norms => [ $source_normalizer ] } ],
 590       [ { tag => $target_tag, subfields => $target_subfields, offset => $target_offset, 'length' => $target_length,
 591           norms => [ $target_normalizer ] } ]
 592     );
 593 }
 594
 595 =head2 get_matches
 596
 597   my @matches = $matcher->get_matches($marc_record, $max_matches);
 598   foreach $match (@matches) {
 599       # matches already sorted in order of
 600       # decreasing score
 601       print "record ID: $match->{'record_id'};
 602       print "score:     $match->{'score'};
 603   }
 604
 605 Identifies all of the records matching the given MARC record.  For a record already
 606 in the database to be considered a match, it must meet the following criteria:
 607
 608 =over 2
 609
 610 =item 1. Total score from its matching field must exceed the supplied threshold.
 611
 612 =item 2. It must pass all required checks.
 613
 614 =back
 615
 616 Only the top $max_matches matches are returned.  The returned array is sorted
 617 in order of decreasing score, i.e., the best match is first.
 618
 619 =cut
 620
 621 sub get_matches {
 622     my $self = shift;
 623     my ($source_record, $max_matches) = @_;
 624
 625     my %matches = ();
 626
 627     my $QParser;
 628     $QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser'));
 629     foreach my $matchpoint ( @{ $self->{'matchpoints'} } ) {
 630         my @source_keys = _get_match_keys( $source_record, $matchpoint );
 631
 632         next if scalar(@source_keys) == 0;
 633
 634         # FIXME - because of a bug in QueryParser, an expression ofthe
 635         # format 'isbn:"isbn1" || isbn:"isbn2" || isbn"isbn3"...'
 636         # does not get parsed correctly, so we will not
 637         # do AggressiveMatchOnISBN if UseQueryParser is on
 638         @source_keys = C4::Koha::GetVariationsOfISBNs(@source_keys)
 639           if ( $matchpoint->{index} =~ /^isbn$/i
 640             && C4::Context->preference('AggressiveMatchOnISBN') )
 641             && !C4::Context->preference('UseQueryParser');
 642
 643         # build query
 644         my $query;
 645         my $error;
 646         my $searchresults;
 647         my $total_hits;
 648         if ( $self->{'record_type'} eq 'biblio' ) {
 649
 650             if ($QParser) {
 651                 $query = join( " || ",
 652                     map { "$matchpoint->{'index'}:$_" } @source_keys );
 653             }
 654             else {
 655                 my $phr = C4::Context->preference('AggressiveMatchOnISBN') ? ',phr' : q{};
 656                 $query = join( " or ",
 657                     map { "$matchpoint->{'index'}$phr=$_" } @source_keys );
 658             }
 659
 660             require C4::Search;
 661
 662             ( $error, $searchresults, $total_hits ) =
 663               C4::Search::SimpleSearch( $query, 0, $max_matches );
 664         }
 665         elsif ( $self->{'record_type'} eq 'authority' ) {
 666             my $authresults;
 667             my @marclist;
 668             my @and_or;
 669             my @excluding = [];
 670             my @operator;
 671             my @value;
 672             foreach my $key (@source_keys) {
 673                 push @marclist, $matchpoint->{'index'};
 674                 push @and_or,   'or';
 675                 push @operator, 'exact';
 676                 push @value,    $key;
 677             }
 678             require C4::AuthoritiesMarc;
 679             ( $authresults, $total_hits ) =
 680               C4::AuthoritiesMarc::SearchAuthorities(
 681                 \@marclist,  \@and_or, \@excluding, \@operator,
 682                 \@value,     0,        20,          undef,
 683                 'AuthidAsc', 1
 684               );
 685             foreach my $result (@$authresults) {
 686                 push @$searchresults, $result->{'authid'};
 687             }
 688         }
 689
 690         if ( defined $error ) {
 691             warn "search failed ($query) $error";
 692         }
 693         else {
 694             foreach my $matched ( @{$searchresults} ) {
 695                 $matches{$matched} += $matchpoint->{'score'};
 696             }
 697         }
 698     }
 699
 700     # get rid of any that don't meet the threshold
 701     %matches = map { ($matches{$_} >= $self->{'threshold'}) ? ($_ => $matches{$_}) : () } keys %matches;
 702
 703     # get rid of any that don't meet the required checks
 704     %matches = map { _passes_required_checks($source_record, $_, $self->{'required_checks'}) ?  ($_ => $matches{$_}) : () }
 705                 keys %matches unless ($self->{'record_type'} eq 'auth');
 706
 707     my @results = ();
 708     if ($self->{'record_type'} eq 'biblio') {
 709         require C4::Biblio;
 710         foreach my $marcblob (keys %matches) {
 711             my $target_record = C4::Search::new_record_from_zebra('biblioserver',$marcblob);
 712             my $record_number;
 713             my $result = C4::Biblio::TransformMarcToKoha(C4::Context->dbh, $target_record, '');
 714             $record_number = $result->{'biblionumber'};
 715             push @results, { 'record_id' => $record_number, 'score' => $matches{$marcblob} };
 716         }
 717     } elsif ($self->{'record_type'} eq 'authority') {
 718         require C4::AuthoritiesMarc;
 719         foreach my $authid (keys %matches) {
 720             push @results, { 'record_id' => $authid, 'score' => $matches{$authid} };
 721         }
 722     }
 723     @results = sort { $b->{'score'} cmp $a->{'score'} } @results;
 724     if (scalar(@results) > $max_matches) {
 725         @results = @results[0..$max_matches-1];
 726     }
 727     return @results;
 728
 729 }
 730
 731 =head2 dump
 732
 733   $description = $matcher->dump();
 734
 735 Returns a reference to a structure containing all of the information
 736 in the matcher object.  This is mainly a convenience method to
 737 aid setting up a HTML editing form.
 738
 739 =cut
 740
 741 sub dump {
 742     my $self = shift;
 743
 744     my $result = {};
 745
 746     $result->{'matcher_id'} = $self->{'id'};
 747     $result->{'code'} = $self->{'code'};
 748     $result->{'description'} = $self->{'description'};
 749     $result->{'record_type'} = $self->{'record_type'};
 750
 751     $result->{'matchpoints'} = [];
 752     foreach my $matchpoint (@{ $self->{'matchpoints'} }) {
 753         push @{  $result->{'matchpoints'} }, $matchpoint;
 754     }
 755     $result->{'matchchecks'} = [];
 756     foreach my $matchcheck (@{ $self->{'required_checks'} }) {
 757         push @{  $result->{'matchchecks'} }, $matchcheck;
 758     }
 759
 760     return $result;
 761 }
 762
 763 sub _passes_required_checks {
 764     my ($source_record, $target_blob, $matchchecks) = @_;
 765     my $target_record = MARC::Record->new_from_usmarc($target_blob); # FIXME -- need to avoid parsing record twice
 766
 767     # no checks supplied == automatic pass
 768     return 1 if $#{ $matchchecks } == -1;
 769
 770     foreach my $matchcheck (@{ $matchchecks }) {
 771         my $source_key = join "", _get_match_keys($source_record, $matchcheck->{'source_matchpoint'});
 772         my $target_key = join "", _get_match_keys($target_record, $matchcheck->{'target_matchpoint'});
 773         return 0 unless $source_key eq $target_key;
 774     }
 775     return 1;
 776 }
 777
 778 sub _get_match_keys {
 779     my $source_record = shift;
 780     my $matchpoint = shift;
 781     my $check_only_first_repeat = @_ ? shift : 0;
 782
 783     # If there is more than one component to the matchpoint (e.g.,
 784     # matchpoint includes both 003 and 001), any repeats
 785     # of the first component's tag are identified; repeats
 786     # of the subsequent components' tags are appended to
 787     # each parallel key dervied from the first component,
 788     # up to the number of repeats of the first component's tag.
 789     #
 790     # For example, if the record has one 003 and two 001s, only
 791     # one key is retrieved because there is only one 003.  The key
 792     # will consist of the contents of the first 003 and first 001.
 793     #
 794     # If there are two 003s and two 001s, there will be two keys:
 795     #    first 003 + first 001
 796     #    second 003 + second 001
 797
 798     my @keys = ();
 799     for (my $i = 0; $i <= $#{ $matchpoint->{'components'} }; $i++) {
 800         my $component = $matchpoint->{'components'}->[$i];
 801         my $j = -1;
 802         FIELD: foreach my $field ($source_record->field($component->{'tag'})) {
 803             $j++;
 804             last FIELD if $j > 0 and $check_only_first_repeat;
 805             last FIELD if $i > 0 and $j > $#keys;
 806             my $key = "";
 807                         my $string;
 808             if ($field->is_control_field()) {
 809                                 $string=$field->data();
 810             } else {
 811                 foreach my $subfield ($field->subfields()) {
 812                     if (exists $component->{'subfields'}->{$subfield->[0]}) {
 813                         $string .= " " . $subfield->[1];
 814                     }
 815                 }
 816                         }
 817             if ($component->{'length'}>0) {
 818                     $string= substr($string, $component->{'offset'}, $component->{'length'});
 819                             # FIXME normalize, substr
 820             } elsif ($component->{'offset'}) {
 821                     $string= substr($string, $component->{'offset'});
 822             }
 823             $key = _normalize($string);
 824             if ($i == 0) {
 825                 push @keys, $key if $key;
 826             } else {
 827                 $keys[$j] .= " $key" if $key;
 828             }
 829         }
 830     }
 831     return @keys;
 832 }
 833
 834
 835 sub _parse_match_component {
 836     my $input_component = shift;
 837
 838     my $component = {};
 839     $component->{'tag'} = $input_component->{'tag'};
 840     $component->{'subfields'} = { map { $_ => 1 } split(//, $input_component->{'subfields'}) };
 841     $component->{'offset'} = exists($input_component->{'offset'}) ? $input_component->{'offset'} : -1;
 842     $component->{'length'} = $input_component->{'length'} ? $input_component->{'length'} : 0;
 843     $component->{'norms'} =  $input_component->{'norms'} ? $input_component->{'norms'} : [];
 844
 845     return $component;
 846 }
 847
 848 # FIXME - default normalizer
 849 sub _normalize {
 850     my $value = uc shift;
 851     $value =~ s/[.;:,\]\[\)\(\/'"]//g;
 852     $value =~ s/^\s+//;
 853     #$value =~ s/^\s+$//;
 854     $value =~ s/\s+$//;
 855     $value =~ s/\s+/ /g;
 856     #$value =~ s/[.;,\]\[\)\(\/"']//g;
 857     return $value;
 858 }
 859
 860 1;
 861 __END__
 862
 863 =head1 AUTHOR
 864
 865 Koha Development Team <http://koha-community.org/>
 866
 867 Galen Charlton <galen.charlton@liblime.com>
 868
 869 =cut