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