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 =back
  66
  67 =head1 FUNCTIONS
  68
  69 =cut
  70
  71 =head2 GetMatcherList
  72
  73 =over 4
  74
  75 my @matchers = C4::Matcher::GetMatcherList();
  76
  77 =back
  78
  79 Returns an array of hashrefs list all matchers
  80 present in the database.  Each hashref includes:
  81
  82 matcher_id
  83 code
  84 description
  85
  86 =cut
  87
  88 sub GetMatcherList {
  89     my $dbh = C4::Context->dbh;
  90
  91     my $sth = $dbh->prepare_cached("SELECT matcher_id, code, description FROM marc_matchers ORDER BY matcher_id");
  92     $sth->execute();
  93     my @results = ();
  94     while (my $row = $sth->fetchrow_hashref) {
  95         push @results, $row;
  96     }
  97     return @results;
  98 }
  99
 100 =head1 METHODS
 101
 102 =cut
 103
 104 =head2 new
 105
 106 =over 4
 107
 108 my $matcher = C4::Matcher->new($record_type, $threshold);
 109
 110 =back
 111
 112 Creates a new Matcher.  C<$record_type> indicates which search
 113 database to use, e.g., 'biblio' or 'authority' and defaults to
 114 'biblio', while C<$threshold> is the minimum score required for a match
 115 and defaults to 1000.
 116
 117 =cut
 118
 119 sub new {
 120     my $class = shift;
 121     my $self = {};
 122
 123     $self->{'id'} = undef;
 124
 125     if ($#_ > -1) {
 126         $self->{'record_type'} = shift;
 127     } else {
 128         $self->{'record_type'} = 'biblio';
 129     }
 130
 131     if ($#_ > -1) {
 132         $self->{'threshold'} = shift;
 133     } else {
 134         $self->{'threshold'} = 1000;
 135     }
 136
 137     $self->{'code'} = '';
 138     $self->{'description'} = '';
 139
 140     $self->{'matchpoints'} = [];
 141     $self->{'required_checks'} = [];
 142
 143     bless $self, $class;
 144     return $self;
 145 }
 146
 147 =head2 fetch
 148
 149 =over 4
 150
 151 my $matcher = C4::Matcher->fetch($id);
 152
 153 =back
 154
 155 Creates a matcher object from the version stored
 156 in the database.  If a matcher with the given
 157 id does not exist, returns undef.
 158
 159 =cut
 160
 161 sub fetch {
 162     my $class = shift;
 163     my $id = shift;
 164     my $dbh = C4::Context->dbh();
 165
 166     my $sth = $dbh->prepare_cached("SELECT * FROM marc_matchers WHERE matcher_id = ?");
 167     $sth->execute($id);
 168     my $row = $sth->fetchrow_hashref;
 169     $sth->finish();
 170     return undef unless defined $row;
 171
 172     my $self = {};
 173     $self->{'id'} = $row->{'matcher_id'};
 174     $self->{'record_type'} = $row->{'record_type'};
 175     $self->{'code'} = $row->{'code'};
 176     $self->{'description'} = $row->{'description'};
 177     $self->{'threshold'} = int($row->{'threshold'});
 178     bless $self, $class;
 179
 180     # matchpoints
 181     $self->{'matchpoints'} = [];
 182     $sth = $dbh->prepare_cached("SELECT * FROM matcher_matchpoints WHERE matcher_id = ? ORDER BY matchpoint_id");
 183     $sth->execute($self->{'id'});
 184     while (my $row = $sth->fetchrow_hashref) {
 185         my $matchpoint = $self->_fetch_matchpoint($row->{'matchpoint_id'});
 186         push @{ $self->{'matchpoints'} }, $matchpoint;
 187     }
 188
 189     # required checks
 190     $self->{'required_checks'} = [];
 191     $sth = $dbh->prepare_cached("SELECT * FROM matchchecks WHERE matcher_id = ? ORDER BY matchcheck_id");
 192     $sth->execute($self->{'id'});
 193     while (my $row = $sth->fetchrow_hashref) {
 194         my $source_matchpoint = $self->_fetch_matchpoint($row->{'source_matchpoint_id'});
 195         my $target_matchpoint = $self->_fetch_matchpoint($row->{'target_matchpoint_id'});
 196         my $matchcheck = {};
 197         $matchcheck->{'source_matchpoint'} = $source_matchpoint;
 198         $matchcheck->{'target_matchpoint'} = $target_matchpoint;
 199         push @{ $self->{'required_checks'} }, $matchcheck;
 200     }
 201
 202     return $self;
 203 }
 204
 205 sub _fetch_matchpoint {
 206     my $self = shift;
 207     my $matchpoint_id = shift;
 208
 209     my $dbh = C4::Context->dbh;
 210     my $sth = $dbh->prepare_cached("SELECT * FROM matchpoints WHERE matchpoint_id = ?");
 211     $sth->execute($matchpoint_id);
 212     my $row = $sth->fetchrow_hashref;
 213     my $matchpoint = {};
 214     $matchpoint->{'index'} = $row->{'search_index'};
 215     $matchpoint->{'score'} = int($row->{'score'});
 216     $sth->finish();
 217
 218     $matchpoint->{'components'} = [];
 219     $sth = $dbh->prepare_cached("SELECT * FROM matchpoint_components WHERE matchpoint_id = ? ORDER BY sequence");
 220     $sth->execute($matchpoint_id);
 221     while ($row = $sth->fetchrow_hashref) {
 222         my $component = {};
 223         $component->{'tag'} = $row->{'tag'};
 224         $component->{'subfields'} = { map { $_ => 1 } split(//,  $row->{'subfields'}) };
 225         $component->{'offset'} = int($row->{'offset'});
 226         $component->{'length'} = int($row->{'length'});
 227         $component->{'norms'} = [];
 228         my $sth2 = $dbh->prepare_cached("SELECT *
 229                                          FROM matchpoint_component_norms
 230                                          WHERE matchpoint_component_id = ? ORDER BY sequence");
 231         $sth2->execute($row->{'matchpoint_component_id'});
 232         while (my $row2 = $sth2->fetchrow_hashref) {
 233             push @{ $component->{'norms'} }, $row2->{'norm_routine'};
 234         }
 235         push @{ $matchpoint->{'components'} }, $component;
 236     }
 237     return $matchpoint;
 238 }
 239
 240 =head2 store
 241
 242 =over 4
 243
 244 my $id = $matcher->store();
 245
 246 =back
 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 =head2 threshold
 369
 370 =over 4
 371
 372 $matcher->threshold(1000);
 373 my $threshold = $matcher->threshold();
 374
 375 =back
 376
 377 Accessor method.
 378
 379 =cut
 380
 381 sub threshold {
 382     my $self = shift;
 383     @_ ? $self->{'threshold'} = shift : $self->{'threshold'};
 384 }
 385
 386 =head2 code
 387
 388 =over 4
 389
 390 $matcher->code('ISBN');
 391 my $code = $matcher->code();
 392
 393 =back
 394
 395 Accessor method.
 396
 397 =cut
 398
 399 sub code {
 400     my $self = shift;
 401     @_ ? $self->{'code'} = shift : $self->{'code'};
 402 }
 403
 404 =head2 description
 405
 406 =over 4
 407
 408 $matcher->description('match on ISBN');
 409 my $description = $matcher->description();
 410
 411 =back
 412
 413 Accessor method.
 414
 415 =cut
 416
 417 sub description {
 418     my $self = shift;
 419     @_ ? $self->{'description'} = shift : $self->{'description'};
 420 }
 421
 422 =head2 add_matchpoint
 423
 424 =over 4
 425
 426 $matcher->add_matchpoint($index, $score, $matchcomponents);
 427
 428 =back
 429
 430 Adds a matchpoint that may include multiple components.  The $index
 431 parameter identifies the index that will be searched, while $score
 432 is the weight that will be added if a match is found.
 433
 434 $matchcomponents should be a reference to an array of matchpoint
 435 compoents, each of which should be a hash containing the following
 436 keys:
 437     tag
 438     subfields
 439     offset
 440     length
 441     norms
 442
 443 The normalization_rules value should in turn be a reference to an
 444 array, each element of which should be a reference to a
 445 normalization subroutine (under C4::Normalize) to be applied
 446 to the source string.
 447
 448 =cut
 449
 450 sub add_matchpoint {
 451     my $self = shift;
 452     my ($index, $score, $matchcomponents) = @_;
 453
 454     my $matchpoint = {};
 455     $matchpoint->{'index'} = $index;
 456     $matchpoint->{'score'} = $score;
 457     $matchpoint->{'components'} = [];
 458     foreach my $input_component (@{ $matchcomponents }) {
 459         push @{ $matchpoint->{'components'} }, _parse_match_component($input_component);
 460     }
 461     push @{ $self->{'matchpoints'} }, $matchpoint;
 462 }
 463
 464 =head2 add_simple_matchpoint
 465
 466 =over 4
 467
 468 $matcher->add_simple_matchpoint($index, $score, $source_tag, $source_subfields,
 469                                 $source_offset, $source_length,
 470                                 $source_normalizer);
 471
 472 =back
 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 =over 4
 495
 496 $match->add_required_check($source_matchpoint, $target_matchpoint);
 497
 498 =back
 499
 500 Adds a required check definition.  A required check means that in
 501 order for a match to be considered valid, the key derived from the
 502 source (incoming) record must match the key derived from the target
 503 (already in DB) record.
 504
 505 Unlike a regular matchpoint, only the first repeat of each tag
 506 in the source and target match criteria are considered.
 507
 508 A typical example of a required check would be verifying that the
 509 titles and publication dates match.
 510
 511 $source_matchpoint and $target_matchpoint are each a reference to
 512 an array of hashes, where each hash follows the same definition
 513 as the matchpoint component specification in add_matchpoint, i.e.,
 514
 515     tag
 516     subfields
 517     offset
 518     length
 519     norms
 520
 521 The normalization_rules value should in turn be a reference to an
 522 array, each element of which should be a reference to a
 523 normalization subroutine (under C4::Normalize) to be applied
 524 to the source string.
 525
 526 =cut
 527
 528 sub add_required_check {
 529     my $self = shift;
 530     my ($source_matchpoint, $target_matchpoint) = @_;
 531
 532     my $matchcheck = {};
 533     $matchcheck->{'source_matchpoint'}->{'index'} = '';
 534     $matchcheck->{'source_matchpoint'}->{'score'} = 0;
 535     $matchcheck->{'source_matchpoint'}->{'components'} = [];
 536     $matchcheck->{'target_matchpoint'}->{'index'} = '';
 537     $matchcheck->{'target_matchpoint'}->{'score'} = 0;
 538     $matchcheck->{'target_matchpoint'}->{'components'} = [];
 539     foreach my $input_component (@{ $source_matchpoint }) {
 540         push @{ $matchcheck->{'source_matchpoint'}->{'components'} }, _parse_match_component($input_component);
 541     }
 542     foreach my $input_component (@{ $target_matchpoint }) {
 543         push @{ $matchcheck->{'target_matchpoint'}->{'components'} }, _parse_match_component($input_component);
 544     }
 545     push @{ $self->{'required_checks'} }, $matchcheck;
 546 }
 547
 548 =head2 add_simple_required_check
 549
 550 $matcher->add_simple_required_check($source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer,
 551                                     $target_tag, $target_subfields, $target_offset, $target_length, $target_normalizer);
 552
 553 =over 4
 554
 555 Adds a required check, which requires that the normalized keys made from the source and targets
 556 must match for a match to be considered valid.
 557
 558 =back
 559
 560 =cut
 561
 562 sub add_simple_required_check {
 563     my $self = shift;
 564     my ($source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer,
 565         $target_tag, $target_subfields, $target_offset, $target_length, $target_normalizer) = @_;
 566
 567     $self->add_required_check(
 568       [ { tag => $source_tag, subfields => $source_subfields, offset => $source_offset, length => $source_length,
 569           norms => [ $source_normalizer ] } ],
 570       [ { tag => $target_tag, subfields => $target_subfields, offset => $target_offset, length => $target_length,
 571           norms => [ $target_normalizer ] } ]
 572     );
 573 }
 574
 575 =head2 find_matches
 576
 577 =over 4
 578
 579 my @matches = $matcher->get_matches($marc_record, $max_matches);
 580 foreach $match (@matches) {
 581   # matches already sorted in order of
 582   # decreasing score
 583   print "record ID: $match->{'record_id'};
 584   print "score:     $match->{'score'};
 585 }
 586
 587 =back
 588
 589 Identifies all of the records matching the given MARC record.  For a record already
 590 in the database to be considered a match, it must meet the following criteria:
 591
 592 =over 2
 593
 594 =item 1. Total score from its matching field must exceed the supplied threshold.
 595
 596 =item 2. It must pass all required checks.
 597
 598 =back
 599
 600 Only the top $max_matches matches are returned.  The returned array is sorted
 601 in order of decreasing score, i.e., the best match is first.
 602
 603 =cut
 604
 605 sub get_matches {
 606     my $self = shift;
 607     my ($source_record, $max_matches) = @_;
 608
 609     my %matches = ();
 610
 611     foreach my $matchpoint (@{ $self->{'matchpoints'} }) {
 612         my @source_keys = _get_match_keys($source_record, $matchpoint);
 613         next if scalar(@source_keys) == 0;
 614         # build query
 615         my $query = join(" or ", map { "$matchpoint->{'index'}=$_" } @source_keys);
 616         # FIXME only searching biblio index at the moment
 617         my ($error, $searchresults) = SimpleSearch($query);
 618
 619         warn "search failed ($query) $error" if $error;
 620         foreach my $matched (@$searchresults) {
 621             $matches{$matched} += $matchpoint->{'score'};
 622         }
 623     }
 624
 625     # get rid of any that don't meet the threshold
 626     %matches = map { ($matches{$_} >= $self->{'threshold'}) ? ($_ => $matches{$_}) : () } keys %matches;
 627
 628     # get rid of any that don't meet the required checks
 629     %matches = map { _passes_required_checks($source_record, $_, $self->{'required_checks'}) ?  ($_ => $matches{$_}) : () }
 630                 keys %matches;
 631
 632     my @results = ();
 633     foreach my $marcblob (keys %matches) {
 634         my $target_record = MARC::Record->new_from_usmarc($marcblob);
 635         my $result = TransformMarcToKoha(C4::Context->dbh, $target_record, '');
 636         # FIXME - again, bibliospecific
 637         # also, can search engine be induced to give just the number in the first place?
 638         my $record_number = $result->{'biblionumber'};
 639         push @results, { 'record_id' => $record_number, 'score' => $matches{$marcblob} };
 640     }
 641     @results = sort { $b->{'score'} cmp $a->{'score'} } @results;
 642     if (scalar(@results) > $max_matches) {
 643         @results = @results[0..$max_matches-1];
 644     }
 645     return @results;
 646
 647 }
 648
 649 sub _passes_required_checks {
 650     my ($source_record, $target_blob, $matchchecks) = @_;
 651     my $target_record = MARC::Record->new_from_usmarc($target_blob); # FIXME -- need to avoid parsing record twice
 652
 653     # no checks supplied == automatic pass
 654     return 1 if $#{ $matchchecks } == -1;
 655
 656     foreach my $matchcheck (@{ $matchchecks }) {
 657         my $source_key = join "", _get_match_keys($source_record, $matchcheck->{'source_matchpoint'});
 658         my $target_key = join "", _get_match_keys($target_record, $matchcheck->{'target_matchpoint'});
 659         return 0 unless $source_key eq $target_key;
 660     }
 661     return 1;
 662 }
 663
 664 sub _get_match_keys {
 665     my $source_record = shift;
 666     my $matchpoint = shift;
 667     my $check_only_first_repeat = @_ ? shift : 0;
 668
 669     # If there is more than one component to the matchpoint (e.g.,
 670     # matchpoint includes both 003 and 001), any repeats
 671     # of the first component's tag are identified; repeats
 672     # of the subsequent components' tags are appended to
 673     # each parallel key dervied from the first component,
 674     # up to the number of repeats of the first component's tag.
 675     #
 676     # For example, if the record has one 003 and two 001s, only
 677     # one key is retrieved because there is only one 003.  The key
 678     # will consist of the contents of the first 003 and first 001.
 679     #
 680     # If there are two 003s and two 001s, there will be two keys:
 681     #    first 003 + first 001
 682     #    second 003 + second 001
 683
 684     my @keys = ();
 685     for (my $i = 0; $i <= $#{ $matchpoint->{'components'} }; $i++) {
 686         my $component = $matchpoint->{'components'}->[$i];
 687         my $j = -1;
 688         FIELD: foreach my $field ($source_record->field($component->{'tag'})) {
 689             $j++;
 690             last FIELD if $j > 0 and $check_only_first_repeat;
 691             last FIELD if $i > 0 and $j > $#keys;
 692             my $key = "";
 693             if ($field->is_control_field()) {
 694                 if ($component->{'length'}) {
 695                     $key = _normalize(substr($field->data(), $component->{'offset'}, $component->{'length'}))
 696                             # FIXME normalize, substr
 697                 } else {
 698                     $key = _normalize($field->data());
 699                 }
 700             } else {
 701                 foreach my $subfield ($field->subfields()) {
 702                     if (exists $component->{'subfields'}->{$subfield->[0]}) {
 703                         $key .= " " . $subfield->[1];
 704                     }
 705                 }
 706                 $key = _normalize($key);
 707             }
 708             if ($i == 0) {
 709                 push @keys, $key if $key;
 710             } else {
 711                 $keys[$j] .= " $key" if $key;
 712             }
 713         }
 714     }
 715     return @keys;
 716
 717 }
 718
 719
 720 sub _parse_match_component {
 721     my $input_component = shift;
 722
 723     my $component = {};
 724     $component->{'tag'} = $input_component->{'tag'};
 725     $component->{'subfields'} = { map { $_ => 1 } split(//, $input_component->{'subfields'}) };
 726     $component->{'offset'} = exists($input_component->{'offset'}) ? $input_component->{'offset'} : -1;
 727     $component->{'length'} = $input_component->{'length'} ? $input_component->{'length'} : 0;
 728     $component->{'norms'} =  $input_component->{'norms'} ? $input_component->{'norms'} : [];
 729
 730     return $component;
 731 }
 732
 733 # FIXME - default normalizer
 734 sub _normalize {
 735     my $value = uc shift;
 736     $value =~ s/^\s+//;
 737     $value =~ s/^\s+$//;
 738     $value =~ s/\s+/ /g;
 739     $value =~ s/[.;,\]\[\)\(\/"']//g;
 740     return $value;
 741 }
 742
 743 1;
 744
 745 =head1 AUTHOR
 746
 747 Koha Development Team <info@koha.org>
 748
 749 Galen Charlton <galen.charlton@liblime.com>
 750
 751 =cut