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