C4/Matcher.pm

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