Attachment #33080 for bug #13181

View | Details | Raw Unified | Return to bug 13181
Collapse All | Expand All





BEGIN {
	# set the version for version checking
	$VERSION = 3.07.00.049;
}

=head1 NAME


  $matcher->add_simple_required_check('245', 'a', -1, 0, '', '245', 'a', -1, 0, '');
  $matcher->add_required_check([ { tag => '245', subfields => 'a', norms => [] } ], 
							   [ { tag => '245', subfields => 'a', norms => [] } ]);

  my @matches = $matcher->get_matches($marc_record, $max_matches);

  foreach $match (@matches) {

	  # matches already sorted in order of
	  # decreasing score
	  print "record ID: $match->{'record_id'};
	  print "score:     $match->{'score'};

  }


=cut

sub GetMatcherList {
	my $dbh = C4::Context->dbh;

	my $sth = $dbh->prepare_cached("SELECT matcher_id, code, description FROM marc_matchers ORDER BY matcher_id");
	$sth->execute();
	my @results = ();
	while (my $row = $sth->fetchrow_hashref) {
		push @results, $row;
	}
	return @results;
}

=head2 GetMatcherId

=cut

sub GetMatcherId {
	my ($code) = @_;
	my $dbh = C4::Context->dbh;

	my $matcher_id = $dbh->selectrow_array("SELECT matcher_id FROM marc_matchers WHERE code = ?", undef, $code);
	return $matcher_id;
}

=head1 METHODS

=cut

sub new {
	my $class = shift;
	my $self = {};

	$self->{'id'} = undef;

	if ($#_ > -1) {
		$self->{'record_type'} = shift;
	} else {
		$self->{'record_type'} = 'biblio';
	}

	if ($#_ > -1) {
		$self->{'threshold'} = shift;
	} else {
		$self->{'threshold'} = 1000;
	}

	$self->{'code'} = '';
	$self->{'description'} = '';

	$self->{'matchpoints'} = [];
	$self->{'required_checks'} = [];

	bless $self, $class;
	return $self;
}

=head2 fetch

=cut

sub fetch {
	my $class = shift;
	my $id = shift;
	my $dbh = C4::Context->dbh();

	my $sth = $dbh->prepare_cached("SELECT * FROM marc_matchers WHERE matcher_id = ?");
	$sth->execute($id);
	my $row = $sth->fetchrow_hashref;
	$sth->finish();
	return undef unless defined $row;

	my $self = {};
	$self->{'id'} = $row->{'matcher_id'};
	$self->{'record_type'} = $row->{'record_type'};
	$self->{'code'} = $row->{'code'};
	$self->{'description'} = $row->{'description'};
	$self->{'threshold'} = int($row->{'threshold'});
	bless $self, $class;

	# matchpoints
	$self->{'matchpoints'} = [];
	$sth = $dbh->prepare_cached("SELECT * FROM matcher_matchpoints WHERE matcher_id = ? ORDER BY matchpoint_id");
	$sth->execute($self->{'id'});
	while (my $row = $sth->fetchrow_hashref) {
		my $matchpoint = $self->_fetch_matchpoint($row->{'matchpoint_id'});
		push @{ $self->{'matchpoints'} }, $matchpoint;
	}

	# required checks
	$self->{'required_checks'} = [];
	$sth = $dbh->prepare_cached("SELECT * FROM matchchecks WHERE matcher_id = ? ORDER BY matchcheck_id");
	$sth->execute($self->{'id'});
	while (my $row = $sth->fetchrow_hashref) {
		my $source_matchpoint = $self->_fetch_matchpoint($row->{'source_matchpoint_id'});
		my $target_matchpoint = $self->_fetch_matchpoint($row->{'target_matchpoint_id'});
		my $matchcheck = {};
		$matchcheck->{'source_matchpoint'} = $source_matchpoint;
		$matchcheck->{'target_matchpoint'} = $target_matchpoint;
		push @{ $self->{'required_checks'} }, $matchcheck;
	}

	return $self;
}

sub _fetch_matchpoint {
	my $self = shift;
	my $matchpoint_id = shift;

	my $dbh = C4::Context->dbh;
	my $sth = $dbh->prepare_cached("SELECT * FROM matchpoints WHERE matchpoint_id = ?");
	$sth->execute($matchpoint_id);
	my $row = $sth->fetchrow_hashref;
	my $matchpoint = {};
	$matchpoint->{'index'} = $row->{'search_index'};
	$matchpoint->{'score'} = int($row->{'score'});
	$sth->finish();

	$matchpoint->{'components'} = [];
	$sth = $dbh->prepare_cached("SELECT * FROM matchpoint_components WHERE matchpoint_id = ? ORDER BY sequence");
	$sth->execute($matchpoint_id);
	while ($row = $sth->fetchrow_hashref) {
		my $component = {};
		$component->{'tag'} = $row->{'tag'};
		$component->{'subfields'} = { map { $_ => 1 } split(//,  $row->{'subfields'}) };
		$component->{'offset'} = int($row->{'offset'});
		$component->{'length'} = int($row->{'length'});
		$component->{'norms'} = [];
		my $sth2 = $dbh->prepare_cached("SELECT *
										 FROM matchpoint_component_norms
										 WHERE matchpoint_component_id = ? ORDER BY sequence");
		$sth2->execute($row->{'matchpoint_component_id'});
		while (my $row2 = $sth2->fetchrow_hashref) {
			push @{ $component->{'norms'} }, $row2->{'norm_routine'};
		}
		push @{ $matchpoint->{'components'} }, $component;
	}
	return $matchpoint;
}

=head2 store

=cut

sub store {
	my $self = shift;

	if (defined $self->{'id'}) {
		# update
		$self->_del_matcher_components();
		$self->_update_marc_matchers();
	} else {
		# create new
		$self->_new_marc_matchers();
	}
	$self->_store_matcher_components();
	return $self->{'id'};
}

sub _del_matcher_components {
	my $self = shift;

	my $dbh = C4::Context->dbh();
	my $sth = $dbh->prepare_cached("DELETE FROM matchpoints WHERE matcher_id = ?");
	$sth->execute($self->{'id'});
	$sth = $dbh->prepare_cached("DELETE FROM matchchecks WHERE matcher_id = ?");
	$sth->execute($self->{'id'});
	# foreign key delete cascades take care of deleting relevant rows
	# from matcher_matchpoints, matchpoint_components, and
	# matchpoint_component_norms
}

sub _update_marc_matchers {
	my $self = shift;

	my $dbh = C4::Context->dbh();
	my $sth = $dbh->prepare_cached("UPDATE marc_matchers
									SET code = ?,
										description = ?,
										record_type = ?,
										threshold = ?
									WHERE matcher_id = ?");
	$sth->execute($self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'}, $self->{'id'});
}

sub _new_marc_matchers {
	my $self = shift;

	my $dbh = C4::Context->dbh();
	my $sth = $dbh->prepare_cached("INSERT INTO marc_matchers
									(code, description, record_type, threshold)
									VALUES (?, ?, ?, ?)");
	$sth->execute($self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'});
	$self->{'id'} = $dbh->{'mysql_insertid'};
}

sub _store_matcher_components {
	my $self = shift;

	my $dbh = C4::Context->dbh();
	my $sth;
	my $matcher_id = $self->{'id'};
	foreach my $matchpoint (@{ $self->{'matchpoints'}}) {
		my $matchpoint_id = $self->_store_matchpoint($matchpoint);
		$sth = $dbh->prepare_cached("INSERT INTO matcher_matchpoints (matcher_id, matchpoint_id)
									 VALUES (?, ?)");
		$sth->execute($matcher_id, $matchpoint_id);
	}
	foreach my $matchcheck (@{ $self->{'required_checks'} }) {
		my $source_matchpoint_id = $self->_store_matchpoint($matchcheck->{'source_matchpoint'});
		my $target_matchpoint_id = $self->_store_matchpoint($matchcheck->{'target_matchpoint'});
		$sth = $dbh->prepare_cached("INSERT INTO matchchecks
									 (matcher_id, source_matchpoint_id, target_matchpoint_id)
									 VALUES (?, ?, ?)");
		$sth->execute($matcher_id, $source_matchpoint_id,  $target_matchpoint_id);
	}

}

sub _store_matchpoint {
	my $self = shift;
	my $matchpoint = shift;

	my $dbh = C4::Context->dbh();
	my $sth;
	my $matcher_id = $self->{'id'};
	$sth = $dbh->prepare_cached("INSERT INTO matchpoints (matcher_id, search_index, score)
								 VALUES (?, ?, ?)");
	$sth->execute($matcher_id, $matchpoint->{'index'}, $matchpoint->{'score'});
	my $matchpoint_id = $dbh->{'mysql_insertid'};
	my $seqnum = 0;
	foreach my $component (@{ $matchpoint->{'components'} }) {
		$seqnum++;
		$sth = $dbh->prepare_cached("INSERT INTO matchpoint_components
									 (matchpoint_id, sequence, tag, subfields, offset, length)
									 VALUES (?, ?, ?, ?, ?, ?)");
		$sth->bind_param(1, $matchpoint_id);
		$sth->bind_param(2, $seqnum);
		$sth->bind_param(3, $component->{'tag'});
		$sth->bind_param(4, join "", sort keys %{ $component->{'subfields'} });
		$sth->bind_param(5, $component->{'offset'});
		$sth->bind_param(6, $component->{'length'});
		$sth->execute();
		my $matchpoint_component_id = $dbh->{'mysql_insertid'};
		my $normseq = 0;
		foreach my $norm (@{ $component->{'norms'} }) {
			$normseq++;
			$sth = $dbh->prepare_cached("INSERT INTO matchpoint_component_norms
										 (matchpoint_component_id, sequence, norm_routine)
										 VALUES (?, ?, ?)");
			$sth->execute($matchpoint_component_id, $normseq, $norm);
		}
	}
	return $matchpoint_id;
}



=cut

sub delete {
	my $class = shift;
	my $matcher_id = shift;

	my $dbh = C4::Context->dbh;
	my $sth = $dbh->prepare("DELETE FROM marc_matchers WHERE matcher_id = ?");
	$sth->execute($matcher_id); # relying on cascading deletes to clean up everything
}

=head2 record_type

=cut

sub record_type {
	my $self = shift;
	@_ ? $self->{'record_type'} = shift : $self->{'record_type'};
}

=head2 threshold

=cut

sub threshold {
	my $self = shift;
	@_ ? $self->{'threshold'} = shift : $self->{'threshold'};
}

=head2 _id

=cut

sub _id {
	my $self = shift;
	@_ ? $self->{'id'} = shift : $self->{'id'};
}

=head2 code

=cut

sub code {
	my $self = shift;
	@_ ? $self->{'code'} = shift : $self->{'code'};
}

=head2 description

=cut

sub description {
	my $self = shift;
	@_ ? $self->{'description'} = shift : $self->{'description'};
}

=head2 add_matchpoint

$matchcomponents should be a reference to an array of matchpoint
compoents, each of which should be a hash containing the following 
keys:
	tag
	subfields
	offset
	length
	norms

The normalization_rules value should in turn be a reference to an
array, each element of which should be a reference to a 

to the source string.

=cut

sub add_matchpoint {
	my $self = shift;
	my ($index, $score, $matchcomponents) = @_;

	my $matchpoint = {};
	$matchpoint->{'index'} = $index;
	$matchpoint->{'score'} = $score;
	$matchpoint->{'components'} = [];
	foreach my $input_component (@{ $matchcomponents }) {
		push @{ $matchpoint->{'components'} }, _parse_match_component($input_component);
	}
	push @{ $self->{'matchpoints'} }, $matchpoint;
}

=head2 add_simple_matchpoint

  $matcher->add_simple_matchpoint($index, $score, $source_tag,
							$source_subfields, $source_offset,
							$source_length, $source_normalizer);


Adds a simple matchpoint rule -- after composing a key based on the source tag and subfields,

=cut

sub add_simple_matchpoint {
	my $self = shift;
	my ($index, $score, $source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer) = @_;

	$self->add_matchpoint($index, $score, [
						  { tag => $source_tag, subfields => $source_subfields,
							offset => $source_offset, 'length' => $source_length,
							norms => [ $source_normalizer ]
						  }
						 ]);
}

=head2 add_required_check

an array of hashes, where each hash follows the same definition
as the matchpoint component specification in add_matchpoint, i.e.,

	tag
	subfields
	offset
	length
	norms

The normalization_rules value should in turn be a reference to an
array, each element of which should be a reference to a 

=cut

sub add_required_check {
	my $self = shift;
	my ($source_matchpoint, $target_matchpoint) = @_;

	my $matchcheck = {};
	$matchcheck->{'source_matchpoint'}->{'index'} = '';
	$matchcheck->{'source_matchpoint'}->{'score'} = 0;
	$matchcheck->{'source_matchpoint'}->{'components'} = [];
	$matchcheck->{'target_matchpoint'}->{'index'} = '';
	$matchcheck->{'target_matchpoint'}->{'score'} = 0;
	$matchcheck->{'target_matchpoint'}->{'components'} = [];
	foreach my $input_component (@{ $source_matchpoint }) {
		push @{ $matchcheck->{'source_matchpoint'}->{'components'} }, _parse_match_component($input_component);
	}
	foreach my $input_component (@{ $target_matchpoint }) {
		push @{ $matchcheck->{'target_matchpoint'}->{'components'} }, _parse_match_component($input_component);
	}
	push @{ $self->{'required_checks'} }, $matchcheck;
}

=head2 add_simple_required_check

  $matcher->add_simple_required_check($source_tag, $source_subfields,
				$source_offset, $source_length, $source_normalizer,
				$target_tag, $target_subfields, $target_offset,
				$target_length, $target_normalizer);

Adds a required check, which requires that the normalized keys made from the source and targets
must match for a match to be considered valid.

=cut

sub add_simple_required_check {
	my $self = shift;
	my ($source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer,
		$target_tag, $target_subfields, $target_offset, $target_length, $target_normalizer) = @_;

	$self->add_required_check(
	  [ { tag => $source_tag, subfields => $source_subfields, offset => $source_offset, 'length' => $source_length,
		  norms => [ $source_normalizer ] } ],
	  [ { tag => $target_tag, subfields => $target_subfields, offset => $target_offset, 'length' => $target_length,
		  norms => [ $target_normalizer ] } ]
	);
}

=head2 get_matches

  my @matches = $matcher->get_matches($marc_record, $max_matches);
  foreach $match (@matches) {
	  # matches already sorted in order of
	  # decreasing score
	  print "record ID: $match->{'record_id'};
	  print "score:     $match->{'score'};
  }

Identifies all of the records matching the given MARC record.  For a record already 

=cut

sub get_matches {
	my $self = shift;
	my ($source_record, $max_matches) = @_;

	my %matches = ();

	my $QParser;
	$QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser'));
	foreach my $matchpoint ( @{ $self->{'matchpoints'} } ) {
		my @source_keys = _get_match_keys( $source_record, $matchpoint );

		next if scalar(@source_keys) == 0;

		# FIXME - because of a bug in QueryParser, an expression ofthe
		# format 'isbn:"isbn1" || isbn:"isbn2" || isbn"isbn3"...'
		# does not get parsed correctly, so we will not
		# do AggressiveMatchOnISBN if UseQueryParser is on
		@source_keys = C4::Koha::GetVariationsOfISBNs(@source_keys)
		  if ( $matchpoint->{index} =~ /^isbn$/i
			&& C4::Context->preference('AggressiveMatchOnISBN') )
			&& !C4::Context->preference('UseQueryParser');

		# build query
		my $query;
		my $error;
		my $searchresults;
		my $total_hits;
		if ( $self->{'record_type'} eq 'biblio' ) {

			if ($QParser) {
				$query = join( " || ",
					map { "$matchpoint->{'index'}:$_" } @source_keys );
			}
			else {
				my $phr = C4::Context->preference('AggressiveMatchOnISBN') ? ',phr' : q{};
				$query = join( " or ",
					map { "$matchpoint->{'index'}$phr=$_" } @source_keys );
			}

            require C4::Search;

            ( $error, $searchresults, $total_hits ) =
              C4::Search::SimpleSearch( $query, 0, $max_matches );
        }
        elsif ( $self->{'record_type'} eq 'authority' ) {
            my $authresults;
            my @marclist;
            my @and_or;
            my @excluding = [];
            my @operator;
            my @value;
            foreach my $key (@source_keys) {
                push @marclist, $matchpoint->{'index'};
                push @and_or,   'or';
                push @operator, 'exact';
                push @value,    $key;
            }
            require C4::AuthoritiesMarc;
            ( $authresults, $total_hits ) =
              C4::AuthoritiesMarc::SearchAuthorities(
                \@marclist,  \@and_or, \@excluding, \@operator,
                \@value,     0,        20,          undef,
                'AuthidAsc', 1
              );
            foreach my $result (@$authresults) {
                push @$searchresults, $result->{'authid'};
            }
        }

        #Collect the results
        if ( defined $error ) {
            warn "search failed ($query) $error";
        }
        else {
            if ($self->{'record_type'} eq 'authority') {
                foreach my $matched ( @{$searchresults} ) {
                    $matches{$matched}->{score} += $matchpoint->{'score'};
                }
            }
            elsif ($self->{'record_type'} eq 'biblio') {
                foreach my $matched ( @{$searchresults} ) {
                    my $record = C4::Search::new_record_from_zebra( 'biblioserver', $matched );
                    $matches{$record}->{score} += $matchpoint->{'score'}; #Using $record HASH string representation as the key :)
                    $matches{$record}->{record} = $record;
                }
            }

			require C4::Search;

			( $error, $searchresults, $total_hits ) =
			  C4::Search::SimpleSearch( $query, 0, $max_matches );
		}
		elsif ( $self->{'record_type'} eq 'authority' ) {
			my $authresults;
			my @marclist;
			my @and_or;
			my @excluding = [];
			my @operator;
			my @value;
			foreach my $key (@source_keys) {
				push @marclist, $matchpoint->{'index'};
				push @and_or,   'or';
				push @operator, 'exact';
				push @value,    $key;
			}
			require C4::AuthoritiesMarc;
			( $authresults, $total_hits ) =
			  C4::AuthoritiesMarc::SearchAuthorities(
				\@marclist,  \@and_or, \@excluding, \@operator,
				\@value,     0,        20,          undef,
				'AuthidAsc', 1
			  );
			foreach my $result (@$authresults) {
				push @$searchresults, $result->{'authid'};
			}
		}

		#Collect the results
		if ( defined $error ) {
			warn "search failed ($query) $error";
		}
		else {
			if ($self->{'record_type'} eq 'authority') {
				foreach my $matched ( @{$searchresults} ) {
					$matches{$matched}->{score} += $matchpoint->{'score'};
				}
			}
			elsif ($self->{'record_type'} eq 'biblio') {
				foreach my $matched ( @{$searchresults} ) {
					my $record = C4::Search::new_record_from_zebra( 'biblioserver', $matched );
					$matches{$record}->{score} += $matchpoint->{'score'}; #Using $record HASH string representation as the key :)
					$matches{$record}->{record} = $record;
				}
			}

		}
	}

	# get rid of any that don't meet the threshold
	%matches = map { ($matches{$_}->{score} >= $self->{'threshold'}) ? ($_ => $matches{$_}) : () } keys %matches;

	# get rid of any that don't meet the required checks
	%matches = map { _passes_required_checks($source_record, $matches{$_}->{record}, $self->{'required_checks'}) ?  ($_ => $matches{$_}) : () }
				keys %matches unless ($self->{'record_type'} eq 'auth');

	my @results = ();
	if ($self->{'record_type'} eq 'biblio') {
		require C4::Biblio;
		foreach my $hashkey (keys %matches) {
			my $target_record = $matches{$hashkey}->{record};
			my $record_number;
			my $result = C4::Biblio::TransformMarcToKoha(C4::Context->dbh, $target_record, '');
			$record_number = $result->{'biblionumber'};
			push @results, { 'record_id' => $record_number, 'score' => $matches{$hashkey}->{score}, 'target_record' => $target_record, 'target_biblio' => $result };
		}
	} elsif ($self->{'record_type'} eq 'authority') {
		require C4::AuthoritiesMarc;
		foreach my $authid (keys %matches) {
			push @results, { 'record_id' => $authid, 'score' => $matches{$authid}->{score} };
		}
	}
	@results = sort { $b->{'score'} cmp $a->{'score'} } @results;
	if (scalar(@results) > $max_matches) {
		@results = @results[0..$max_matches-1];
	}
	return @results;

}


=cut

sub dump {
	my $self = shift;
   
	my $result = {};

	$result->{'matcher_id'} = $self->{'id'};
	$result->{'code'} = $self->{'code'};
	$result->{'description'} = $self->{'description'};
	$result->{'record_type'} = $self->{'record_type'};

	$result->{'matchpoints'} = [];
	foreach my $matchpoint (@{ $self->{'matchpoints'} }) {
		push @{  $result->{'matchpoints'} }, $matchpoint;
	}
	$result->{'matchchecks'} = [];
	foreach my $matchcheck (@{ $self->{'required_checks'} }) {
		push @{  $result->{'matchchecks'} }, $matchcheck;
	}

	return $result;
}

sub _passes_required_checks {
	my ($source_record, $target_record, $matchchecks) = @_;

	# no checks supplied == automatic pass
	return 1 if $#{ $matchchecks } == -1;

	foreach my $matchcheck (@{ $matchchecks }) {
		my $source_key = join "", _get_match_keys($source_record, $matchcheck->{'source_matchpoint'});
		my $target_key = join "", _get_match_keys($target_record, $matchcheck->{'target_matchpoint'});
		return 0 unless $source_key eq $target_key;
	}
	return 1;
}

sub _get_match_keys {
	my $source_record = shift;
	my $matchpoint = shift;
	my $check_only_first_repeat = @_ ? shift : 0;

	# If there is more than one component to the matchpoint (e.g.,
	# matchpoint includes both 003 and 001), any repeats
	# of the first component's tag are identified; repeats
	# of the subsequent components' tags are appended to
	# each parallel key dervied from the first component,
	# up to the number of repeats of the first component's tag.
	#
	# For example, if the record has one 003 and two 001s, only
	# one key is retrieved because there is only one 003.  The key
	# will consist of the contents of the first 003 and first 001.
	#
	# If there are two 003s and two 001s, there will be two keys:
	#    first 003 + first 001
	#    second 003 + second 001

	my @keys = ();
	for (my $i = 0; $i <= $#{ $matchpoint->{'components'} }; $i++) {
		my $component = $matchpoint->{'components'}->[$i];
		my $j = -1;
		FIELD: foreach my $field ($source_record->field($component->{'tag'})) {
			$j++;
			last FIELD if $j > 0 and $check_only_first_repeat;
			last FIELD if $i > 0 and $j > $#keys;
			my $key = "";
			my $string;
			if ($field->is_control_field()) {
				$string=$field->data();
			} else {
				foreach my $subfield ($field->subfields()) {
					if (exists $component->{'subfields'}->{$subfield->[0]}) {
						$string .= " " . $subfield->[1];
					}
				}
			}
			if ($component->{'length'}>0) {
					$string= substr($string, $component->{'offset'}, $component->{'length'});
							# FIXME normalize, substr
			} elsif ($component->{'offset'}) {
					$string= substr($string, $component->{'offset'});
			}
			$key = _normalize($string);
			if ($i == 0) {
				push @keys, $key if $key;
			} else {
				$keys[$j] .= " $key" if $key;
			}
		}
	}
	return @keys;
}


sub _parse_match_component {
	my $input_component = shift;

	my $component = {};
	$component->{'tag'} = $input_component->{'tag'};
	$component->{'subfields'} = { map { $_ => 1 } split(//, $input_component->{'subfields'}) };
	$component->{'offset'} = exists($input_component->{'offset'}) ? $input_component->{'offset'} : -1;
	$component->{'length'} = $input_component->{'length'} ? $input_component->{'length'} : 0;
	$component->{'norms'} =  $input_component->{'norms'} ? $input_component->{'norms'} : [];

	return $component;
}

# FIXME - default normalizer
sub _normalize {
	my $value = uc shift;
	$value =~ s/[.;:,\]\[\)\(\/'"]//g;
	$value =~ s/^\s+//;
	#$value =~ s/^\s+$//;
	$value =~ s/\s+$//;
	$value =~ s/\s+/ /g;
	#$value =~ s/[.;,\]\[\)\(\/"']//g;
	return $value;
}

=head2 overlayRecord

  $mergedRecord = $matcher->overlayRecord($old_record, $new_record);

@Param1 MARC:Record of the old record whose fields should be preserved
@Param2 MARC:Record of the record whose fields should be overwritten with the old ones
@Returns MARC::Record-object with overlayed fields.

Overlays the new_record with the designated fields from the old_record.
Fields are defined using this C4::Matcher's "Match points".
-Tag and subfields can be used. If only tag is given, all subfields for all the tags present in the old_record are selected.
-If subfields are defined, only the defined subfields are selected and other subfields are lost.
-Selected subfields/fields are copied over same elements in the new_record, or if the new_record misses those elements,
  new ones are created.

=cut

sub overlayRecord {
    my $matcher = shift; #Get my $self!
    my ($old_record, $record) = @_;
    foreach my $matchpoint ( @{$matcher->{matchpoints}} ) {
        foreach my $component ( @{$matchpoint->{components}} ) {
            my $tag = $component->{tag};
            my @t = keys(%{$component->{subfields}});
            my $subfield = shift(@t);
            my $normalizer = $component->{norms}->[0];

            _copyFieldsTo( $old_record, $record, $tag, $subfield );
        }
    }

    foreach my $required_check (@{$matcher->{required_checks}}) {
        my $source_field = $required_check->{source_matchpoint}->{components}->[0]->{tag};
        my @t = keys(%{$required_check->{source_matchpoint}->{components}->[0]->{subfields}});
        my $source_subfield = shift @t;
        my $source_norms = $required_check->{source_matchpoint}->{components}->[0]->{norms}->[0];
        my $target_field = $required_check->{target_matchpoint}->{components}->[0]->{tag};
        @t = keys(%{$required_check->{target_matchpoint}->{components}->[0]->{subfields}});
        my $target_subfield = shift @t;
        my $target_norms = $required_check->{target_matchpoint}->{components}->[0]->{norms}->[0];

        if ($source_norms =~ /copy/ && $target_norms =~ /paste/) {
            _copyFieldsTo( $record, $record, $source_field, $source_subfield, $target_field, $target_subfield );
        }
        elsif ($source_norms =~ /move/ && $target_norms =~ /paste/) {
            _copyFieldsTo( $record, $record, $source_field, $source_subfield, $target_field, $target_subfield );
            if ($source_field && $source_subfield) {
                my @source_fields = $record->field($source_field);
                foreach my $f (@source_fields) {
                    $f->delete_subfield(code => $source_subfield);
                }
            }
            elsif ($source_field) {
                my @source_fields = $record->field($source_field);
                $record->delete_fields(@source_fields);
            }
        }
        elsif ($source_norms =~ /preserve/ && $target_norms =~ /preserve/) {
            _copyFieldsTo( $old_record, $record, $source_field, $source_subfield, $target_field, $target_subfield );
        }

    }
    return $record;
}
#Copies the given field and subfield from $oldRecord to the $newRecord as a new field and subfield
#
#   _copyFieldsTo($oldRecord, $newRecord, '049', 'a', '051, 'c');
#   _copyFieldsTo($oldRecord, $newRecord, '049', 'a'); #Target field and subfield defaults to '049' and 'a'
#
#@PARAM1  MARC::Record from which to copy fields from
#@PARAM2  MARC::Record to receive the copied fields
#@PARAM3  source tag as String
#@PARAM4  source subfield as String, optional, if omited copies the whole field regardless of target definitions
#@PARAM5  target field, if the source field needs to change the field code
#@PARAM6  target subfield, if the source subfield needs to change code
sub _copyFieldsTo {
    my ($oldRecord, $newRecord, $sourceField, $sourceSubfield, $targetField, $targetSubfield) = @_;
    $targetField = $sourceField unless $targetField;
    $targetSubfield = $sourceSubfield unless $targetSubfield;

    my @oldFields = $oldRecord->field($sourceField);
    my @newFields = $newRecord->field($targetField);

    if (@oldFields) { #There is no point in continuing if there is nothing to preserve.
        for (my $oi=0 ; $oi < scalar @oldFields ; $oi++) {

            my $old_field = $oldFields[$oi];
            my $new_field = $newFields[$oi];
            if (not($new_field) && not($sourceSubfield)) { #If no new field present, clone the old field
                $new_field = $old_field->clone();
                $new_field->set_tag( $targetField ) if $targetField;
                $newRecord->append_fields( $new_field );
            }
            else { #Copy the designated fields
                my @subfields = ($sourceSubfield);
                @subfields = map {$_->[0]} $old_field->subfields() unless $sourceSubfield; #Move all subfields if none are define

                if (@subfields) {
                    foreach my $sftag ( @subfields ) {
                        my $oldSfContent = $old_field->subfield($sftag);
                        if ( $oldSfContent ) {
                            $sftag = $targetSubfield if $targetSubfield;

                            if (not($new_field)) { #Why is MARC::Field so crap that it doesn't allow creating an empty object?
                                $new_field = MARC::Field->new(  $targetField, ' ', ' ', $sftag => $oldSfContent  );
                                $newRecord->append_fields( $new_field );
                            }
                            else {
                                $new_field->update( $sftag => $oldSfContent );
                            }
                        }
                    }
                }
            }
        }
    }
}

1;




use C4::ClassSource;
use C4::ImportBatch;
use C4::Charset;
use C4::Matcher;

use Date::Calc qw(Today);
use MARC::File::USMARC;

my $biblionumber  = $input->param('biblionumber'); # if biblionumber exists, it's a modif, not a new biblio.
my $parentbiblio  = $input->param('parentbiblionumber');
my $breedingid    = $input->param('breedingid');
my $matcherid    = $input->param('matcherid');
my $z3950         = $input->param('z3950');
my $op            = $input->param('op');
my $mode          = $input->param('mode');

if ($breedingid) {
    ( $record, $encoding ) = MARCfindbreeding( $breedingid ) ;
}
#Use a matcher to preserve defined fields/subfields
# -old fields are cloned, if new biblio doesn't have them
# -If preserved fields exist. All old fields, or those defined, are overlayed to the new biblio.
if (($biblionumber) && ($breedingid) && ($matcherid)){
    my $old_record = GetMarcBiblio($biblionumber);
    ( $record, $encoding ) = MARCfindbreeding( $breedingid ) ;
    my $matcher = C4::Matcher->fetch($matcherid);

    $matcher->overlayRecord($old_record, $record); #Makes modifications directly to the $record-object
}

#populate hostfield if hostbiblionumber is available
if ($hostbiblionumber) {

Lines 27-32 use C4::Output; Link Here

(-)a/cataloguing/z3950_search.pl (+7 lines)
27	use C4::Context;	27	use C4::Context;
28	use C4::Breeding;	28	use C4::Breeding;
29	use C4::Koha;	29	use C4::Koha;
		30	use C4::Matcher;
30		31
31	my $input = new CGI;	32	my $input = new CGI;
32	my $dbh = C4::Context->dbh;	33	my $dbh = C4::Context->dbh;
Lines 72-77 $template->param( Link Here
72	subject => $subject,	73	subject => $subject,
73	);	74	);
74		75
		76	#Get the matchers to choose from
		77	my $matcherCookie = $input->cookie('matcher');
		78	my $matchers = [ C4::Matcher::GetMatcherList() ];
		79	foreach (@$matchers) { if($_->{matcher_id} == $matcherCookie) {$_->{selected} = 1;} } #Mark the previously selected matcher as selected
		80	$template->param( matchers => $matchers ); #Send the matcher to the template
		81
75	if ( $op ne "do_search" ) {	82	if ( $op ne "do_search" ) {
76	my $sth = $dbh->prepare("SELECT id,host,name,checked FROM z3950servers WHERE recordtype <> 'authority' ORDER BY rank, name");	83	my $sth = $dbh->prepare("SELECT id,host,name,checked FROM z3950servers WHERE recordtype <> 'authority' ORDER BY rank, name");
77	$sth->execute();	84	$sth->execute();




<title>Koha &rsaquo; Z39.50 search results</title>
[% INCLUDE 'greybox.inc' %]
[% INCLUDE 'doc-head-close.inc' %]
<script type="text/javascript" src="[% themelang %]/lib/jquery/plugins/jquery.checkboxes.min.js"></script>
<script type="text/javascript" src="[% themelang %]/lib/jquery/plugins/jquery.cookie.min.js"></script>
<link rel="stylesheet" type="text/css" href="[% themelang %]/css/datatables.css" />
[% INCLUDE 'datatables.inc' %]
<script type="text/javascript">
//<![CDATA[
function Import(GetThisOne,biblionumber) {

    var matcherid = $("select[breeding="+GetThisOne+"]").val();
    $.cookie('matcher', matcherid); //Firstly set the matcher persistence cookie

    opener.document.location="../cataloguing/addbiblio.pl?biblionumber="+biblionumber+"&z3950=1&frameworkcode=[% frameworkcode %]&breedingid="+GetThisOne+"&matcherid="+matcherid;
    window.close();
    return false;
}

            $(".linktools").hide();
            $("tr").removeClass("selected");
            row.addClass("selected");
            if($tgt.is("option")||$tgt.is("select")||$tgt.is("a")||$tgt.is(":nth-child(7)")||$tgt.is(":nth-child(8)")||$tgt.is(":nth-child(9)")||$tgt.is(":nth-child(10)")||$tgt.is(":nth-child(11)")){
                return true;
            } else {
                var position = $(this).offset();

        <th>LCCN</th>
        <th>MARC</th>
        <th>Card</th>
        <th>Matcher</th>
		<th>&nbsp;</th>
    </tr></thead>
    <tbody>[% FOREACH breeding_loo IN breeding_loop %]

            <td>[% breeding_loo.lccn %]</td>
            <td><a href="/cgi-bin/koha/catalogue/showmarc.pl?importid=[% breeding_loo.breedingid %]" title="MARC" rel="gb_page_center[600,500]">MARC</a></td>
            <td><a href="/cgi-bin/koha/catalogue/showmarc.pl?viewas=card&amp;importid=[% breeding_loo.breedingid %]" title="MARC" rel="gb_page_center[600,500]">Card</a></td>
            <td><select breeding="[% breeding_loo.breedingid %]" id="matcher" name="matcher">
                    <option value=""></option>[% FOREACH matcher IN matchers %]
                    <option value="[% matcher.matcher_id %]" [% IF matcher.selected %]selected[% END %]>[% matcher.description %]</option>
            [% END %]</select></td>
            <td><a href="#" onclick="Import([% breeding_loo.breedingid %],[% breeding_loo.biblionumber %]); return false">Import</a></td> 
        </tr>
        [% END %]
- 

Return to bug 13181

Lines 35-40 use C4::Branch; # XXX subfield_is_koha_internal_p Link Here

(-)a/cataloguing/addbiblio.pl (+12 lines)
35	use C4::ClassSource;	35	use C4::ClassSource;
36	use C4::ImportBatch;	36	use C4::ImportBatch;
37	use C4::Charset;	37	use C4::Charset;
		38	use C4::Matcher;
38		39
39	use Date::Calc qw(Today);	40	use Date::Calc qw(Today);
40	use MARC::File::USMARC;	41	use MARC::File::USMARC;
Lines 722-727 my $error = $input->param('error'); Link Here
722	my $biblionumber = $input->param('biblionumber'); # if biblionumber exists, it's a modif, not a new biblio.	723	my $biblionumber = $input->param('biblionumber'); # if biblionumber exists, it's a modif, not a new biblio.
723	my $parentbiblio = $input->param('parentbiblionumber');	724	my $parentbiblio = $input->param('parentbiblionumber');
724	my $breedingid = $input->param('breedingid');	725	my $breedingid = $input->param('breedingid');
		726	my $matcherid = $input->param('matcherid');
725	my $z3950 = $input->param('z3950');	727	my $z3950 = $input->param('z3950');
726	my $op = $input->param('op');	728	my $op = $input->param('op');
727	my $mode = $input->param('mode');	729	my $mode = $input->param('mode');
Lines 809-814 if (($biblionumber) && !($breedingid)){ Link Here
809	if ($breedingid) {	811	if ($breedingid) {
810	( $record, $encoding ) = MARCfindbreeding( $breedingid ) ;	812	( $record, $encoding ) = MARCfindbreeding( $breedingid ) ;
811	}	813	}
		814	#Use a matcher to preserve defined fields/subfields
		815	# -old fields are cloned, if new biblio doesn't have them
		816	# -If preserved fields exist. All old fields, or those defined, are overlayed to the new biblio.
		817	if (($biblionumber) && ($breedingid) && ($matcherid)){
		818	my $old_record = GetMarcBiblio($biblionumber);
		819	( $record, $encoding ) = MARCfindbreeding( $breedingid ) ;
		820	my $matcher = C4::Matcher->fetch($matcherid);
		821
		822	$matcher->overlayRecord($old_record, $record); #Makes modifications directly to the $record-object
		823	}
812		824
813	#populate hostfield if hostbiblionumber is available	825	#populate hostfield if hostbiblionumber is available
814	if ($hostbiblionumber) {	826	if ($hostbiblionumber) {

Lines 2-14 Link Here

(-)a/koha-tmpl/intranet-tmpl/prog/en/modules/cataloguing/z3950_search.tt (-4 / +13 lines)
2	<title>Koha &rsaquo; Z39.50 search results</title>	2	<title>Koha &rsaquo; Z39.50 search results</title>
3	[% INCLUDE 'greybox.inc' %]	3	[% INCLUDE 'greybox.inc' %]
4	[% INCLUDE 'doc-head-close.inc' %]	4	[% INCLUDE 'doc-head-close.inc' %]
5	<script type="text/javascript" src="[% interface %]/lib/jquery/plugins/jquery.checkboxes.min.js"></script>	5	<script type="text/javascript" src="[% themelang %]/lib/jquery/plugins/jquery.checkboxes.min.js"></script>
		6	<script type="text/javascript" src="[% themelang %]/lib/jquery/plugins/jquery.cookie.min.js"></script>
6	<link rel="stylesheet" type="text/css" href="[% themelang %]/css/datatables.css" />	7	<link rel="stylesheet" type="text/css" href="[% themelang %]/css/datatables.css" />
7	[% INCLUDE 'datatables.inc' %]	8	[% INCLUDE 'datatables.inc' %]
8	<script type="text/javascript">	9	<script type="text/javascript">
9	//<![CDATA[	10	//<![CDATA[
10	function Import(GetThisOne,biblionumber) {	11	function Import(GetThisOne,biblionumber) {
11	opener.document.location="../cataloguing/addbiblio.pl?biblionumber="+biblionumber+"&z3950=1&frameworkcode=[% frameworkcode %]&breedingid="+GetThisOne;	12
		13	var matcherid = $("select[breeding="+GetThisOne+"]").val();
		14	$.cookie('matcher', matcherid); //Firstly set the matcher persistence cookie
		15
		16	opener.document.location="../cataloguing/addbiblio.pl?biblionumber="+biblionumber+"&z3950=1&frameworkcode=[% frameworkcode %]&breedingid="+GetThisOne+"&matcherid="+matcherid;
12	window.close();	17	window.close();
13	return false;	18	return false;
14	}	19	}
Lines 43-49 $(document).ready(function(){ Link Here
43	$(".linktools").hide();	48	$(".linktools").hide();
44	$("tr").removeClass("selected");	49	$("tr").removeClass("selected");
45	row.addClass("selected");	50	row.addClass("selected");
46	if($tgt.is("a")\|\|$tgt.is(":nth-child(7)")\|\|$tgt.is(":nth-child(8)")\|\|$tgt.is(":nth-child(9)")\|\|$tgt.is(":nth-child(10)")){	51	if($tgt.is("option")\|\|$tgt.is("select")\|\|$tgt.is("a")\|\|$tgt.is(":nth-child(7)")\|\|$tgt.is(":nth-child(8)")\|\|$tgt.is(":nth-child(9)")\|\|$tgt.is(":nth-child(10)")\|\|$tgt.is(":nth-child(11)")){
47	return true;	52	return true;
48	} else {	53	} else {
49	var position = $(this).offset();	54	var position = $(this).offset();
Lines 160-165 tr.selected { background-color : #FFFFCC; } tr.selected td { background-color : Link Here
160	<th>LCCN</th>	165	<th>LCCN</th>
161	<th>MARC</th>	166	<th>MARC</th>
162	<th>Card</th>	167	<th>Card</th>
		168	<th>Matcher</th>
163	<th> </th>	169	<th> </th>
164	</tr></thead>	170	</tr></thead>
165	<tbody>[% FOREACH breeding_loo IN breeding_loop %]	171	<tbody>[% FOREACH breeding_loo IN breeding_loop %]
Lines 175-180 tr.selected { background-color : #FFFFCC; } tr.selected td { background-color : Link Here
175	<td>[% breeding_loo.lccn %]</td>	181	<td>[% breeding_loo.lccn %]</td>
176	<td><a href="/cgi-bin/koha/catalogue/showmarc.pl?importid=[% breeding_loo.breedingid %]" title="MARC" rel="gb_page_center[600,500]">MARC</a></td>	182	<td><a href="/cgi-bin/koha/catalogue/showmarc.pl?importid=[% breeding_loo.breedingid %]" title="MARC" rel="gb_page_center[600,500]">MARC</a></td>
177	<td><a href="/cgi-bin/koha/catalogue/showmarc.pl?viewas=card&importid=[% breeding_loo.breedingid %]" title="MARC" rel="gb_page_center[600,500]">Card</a></td>	183	<td><a href="/cgi-bin/koha/catalogue/showmarc.pl?viewas=card&importid=[% breeding_loo.breedingid %]" title="MARC" rel="gb_page_center[600,500]">Card</a></td>
		184	<td><select breeding="[% breeding_loo.breedingid %]" id="matcher" name="matcher">
		185	<option value=""></option>[% FOREACH matcher IN matchers %]
		186	<option value="[% matcher.matcher_id %]" [% IF matcher.selected %]selected[% END %]>[% matcher.description %]</option>
		187	[% END %]</select></td>
178	<td><a href="#" onclick="Import([% breeding_loo.breedingid %],[% breeding_loo.biblionumber %]); return false">Import</a></td>	188	<td><a href="#" onclick="Import([% breeding_loo.breedingid %],[% breeding_loo.biblionumber %]); return false">Import</a></td>
179	</tr>	189	</tr>
180	[% END %]	190	[% END %]
181	-