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