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