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

(-)a/C4/Matcher.pm (-494 / +612 lines)
Lines 27-33 use vars qw($VERSION); Link Here
27
27
28
BEGIN {
28
BEGIN {
29
	# set the version for version checking
29
	# set the version for version checking
30
    $VERSION = 3.07.00.049;
30
	$VERSION = 3.07.00.049;
31
}
31
}
32
32
33
=head1 NAME
33
=head1 NAME
Lines 49-64 C4::Matcher - find MARC records matching another one Link Here
49
49
50
  $matcher->add_simple_required_check('245', 'a', -1, 0, '', '245', 'a', -1, 0, '');
50
  $matcher->add_simple_required_check('245', 'a', -1, 0, '', '245', 'a', -1, 0, '');
51
  $matcher->add_required_check([ { tag => '245', subfields => 'a', norms => [] } ], 
51
  $matcher->add_required_check([ { tag => '245', subfields => 'a', norms => [] } ], 
52
                               [ { tag => '245', subfields => 'a', norms => [] } ]);
52
							   [ { tag => '245', subfields => 'a', norms => [] } ]);
53
53
54
  my @matches = $matcher->get_matches($marc_record, $max_matches);
54
  my @matches = $matcher->get_matches($marc_record, $max_matches);
55
55
56
  foreach $match (@matches) {
56
  foreach $match (@matches) {
57
57
58
      # matches already sorted in order of
58
	  # matches already sorted in order of
59
      # decreasing score
59
	  # decreasing score
60
      print "record ID: $match->{'record_id'};
60
	  print "record ID: $match->{'record_id'};
61
      print "score:     $match->{'score'};
61
	  print "score:     $match->{'score'};
62
62
63
  }
63
  }
64
64
Lines 82-96 present in the database. Each hashref includes: Link Here
82
=cut
82
=cut
83
83
84
sub GetMatcherList {
84
sub GetMatcherList {
85
    my $dbh = C4::Context->dbh;
85
	my $dbh = C4::Context->dbh;
86
    
86
87
    my $sth = $dbh->prepare_cached("SELECT matcher_id, code, description FROM marc_matchers ORDER BY matcher_id");
87
	my $sth = $dbh->prepare_cached("SELECT matcher_id, code, description FROM marc_matchers ORDER BY matcher_id");
88
    $sth->execute();
88
	$sth->execute();
89
    my @results = ();
89
	my @results = ();
90
    while (my $row = $sth->fetchrow_hashref) {
90
	while (my $row = $sth->fetchrow_hashref) {
91
        push @results, $row;
91
		push @results, $row;
92
    } 
92
	}
93
    return @results;
93
	return @results;
94
}
94
}
95
95
96
=head2 GetMatcherId
96
=head2 GetMatcherId
Lines 102-112 Returns the matcher_id of a code. Link Here
102
=cut
102
=cut
103
103
104
sub GetMatcherId {
104
sub GetMatcherId {
105
    my ($code) = @_;
105
	my ($code) = @_;
106
    my $dbh = C4::Context->dbh;
106
	my $dbh = C4::Context->dbh;
107
107
108
    my $matcher_id = $dbh->selectrow_array("SELECT matcher_id FROM marc_matchers WHERE code = ?", undef, $code);
108
	my $matcher_id = $dbh->selectrow_array("SELECT matcher_id FROM marc_matchers WHERE code = ?", undef, $code);
109
    return $matcher_id;
109
	return $matcher_id;
110
}
110
}
111
111
112
=head1 METHODS
112
=head1 METHODS
Lines 123-153 and defaults to 1000. Link Here
123
=cut
123
=cut
124
124
125
sub new {
125
sub new {
126
    my $class = shift;
126
	my $class = shift;
127
    my $self = {};
127
	my $self = {};
128
128
129
    $self->{'id'} = undef;
129
	$self->{'id'} = undef;
130
130
131
    if ($#_ > -1) {
131
	if ($#_ > -1) {
132
        $self->{'record_type'} = shift;
132
		$self->{'record_type'} = shift;
133
    } else {
133
	} else {
134
        $self->{'record_type'} = 'biblio';
134
		$self->{'record_type'} = 'biblio';
135
    }
135
	}
136
136
137
    if ($#_ > -1) {
137
	if ($#_ > -1) {
138
        $self->{'threshold'} = shift;
138
		$self->{'threshold'} = shift;
139
    } else {
139
	} else {
140
        $self->{'threshold'} = 1000;
140
		$self->{'threshold'} = 1000;
141
    }
141
	}
142
142
143
    $self->{'code'} = '';
143
	$self->{'code'} = '';
144
    $self->{'description'} = '';
144
	$self->{'description'} = '';
145
145
146
    $self->{'matchpoints'} = [];
146
	$self->{'matchpoints'} = [];
147
    $self->{'required_checks'} = [];
147
	$self->{'required_checks'} = [];
148
148
149
    bless $self, $class;
149
	bless $self, $class;
150
    return $self;
150
	return $self;
151
}
151
}
152
152
153
=head2 fetch
153
=head2 fetch
Lines 161-242 id does not exist, returns undef. Link Here
161
=cut
161
=cut
162
162
163
sub fetch {
163
sub fetch {
164
    my $class = shift;
164
	my $class = shift;
165
    my $id = shift;
165
	my $id = shift;
166
    my $dbh = C4::Context->dbh();
166
	my $dbh = C4::Context->dbh();
167
167
168
    my $sth = $dbh->prepare_cached("SELECT * FROM marc_matchers WHERE matcher_id = ?");
168
	my $sth = $dbh->prepare_cached("SELECT * FROM marc_matchers WHERE matcher_id = ?");
169
    $sth->execute($id);
169
	$sth->execute($id);
170
    my $row = $sth->fetchrow_hashref;
170
	my $row = $sth->fetchrow_hashref;
171
    $sth->finish();
171
	$sth->finish();
172
    return undef unless defined $row;
172
	return undef unless defined $row;
173
173
174
    my $self = {};
174
	my $self = {};
175
    $self->{'id'} = $row->{'matcher_id'};
175
	$self->{'id'} = $row->{'matcher_id'};
176
    $self->{'record_type'} = $row->{'record_type'};
176
	$self->{'record_type'} = $row->{'record_type'};
177
    $self->{'code'} = $row->{'code'};
177
	$self->{'code'} = $row->{'code'};
178
    $self->{'description'} = $row->{'description'};
178
	$self->{'description'} = $row->{'description'};
179
    $self->{'threshold'} = int($row->{'threshold'});
179
	$self->{'threshold'} = int($row->{'threshold'});
180
    bless $self, $class;
180
	bless $self, $class;
181
181
182
    # matchpoints
182
	# matchpoints
183
    $self->{'matchpoints'} = [];
183
	$self->{'matchpoints'} = [];
184
    $sth = $dbh->prepare_cached("SELECT * FROM matcher_matchpoints WHERE matcher_id = ? ORDER BY matchpoint_id");
184
	$sth = $dbh->prepare_cached("SELECT * FROM matcher_matchpoints WHERE matcher_id = ? ORDER BY matchpoint_id");
185
    $sth->execute($self->{'id'});
185
	$sth->execute($self->{'id'});
186
    while (my $row = $sth->fetchrow_hashref) {
186
	while (my $row = $sth->fetchrow_hashref) {
187
        my $matchpoint = $self->_fetch_matchpoint($row->{'matchpoint_id'});
187
		my $matchpoint = $self->_fetch_matchpoint($row->{'matchpoint_id'});
188
        push @{ $self->{'matchpoints'} }, $matchpoint;
188
		push @{ $self->{'matchpoints'} }, $matchpoint;
189
    }
189
	}
190
190
191
    # required checks
191
	# required checks
192
    $self->{'required_checks'} = [];
192
	$self->{'required_checks'} = [];
193
    $sth = $dbh->prepare_cached("SELECT * FROM matchchecks WHERE matcher_id = ? ORDER BY matchcheck_id");
193
	$sth = $dbh->prepare_cached("SELECT * FROM matchchecks WHERE matcher_id = ? ORDER BY matchcheck_id");
194
    $sth->execute($self->{'id'});
194
	$sth->execute($self->{'id'});
195
    while (my $row = $sth->fetchrow_hashref) {
195
	while (my $row = $sth->fetchrow_hashref) {
196
        my $source_matchpoint = $self->_fetch_matchpoint($row->{'source_matchpoint_id'});
196
		my $source_matchpoint = $self->_fetch_matchpoint($row->{'source_matchpoint_id'});
197
        my $target_matchpoint = $self->_fetch_matchpoint($row->{'target_matchpoint_id'});
197
		my $target_matchpoint = $self->_fetch_matchpoint($row->{'target_matchpoint_id'});
198
        my $matchcheck = {};
198
		my $matchcheck = {};
199
        $matchcheck->{'source_matchpoint'} = $source_matchpoint;
199
		$matchcheck->{'source_matchpoint'} = $source_matchpoint;
200
        $matchcheck->{'target_matchpoint'} = $target_matchpoint;
200
		$matchcheck->{'target_matchpoint'} = $target_matchpoint;
201
        push @{ $self->{'required_checks'} }, $matchcheck;
201
		push @{ $self->{'required_checks'} }, $matchcheck;
202
    }
202
	}
203
203
204
    return $self;
204
	return $self;
205
}
205
}
206
206
207
sub _fetch_matchpoint {
207
sub _fetch_matchpoint {
208
    my $self = shift;
208
	my $self = shift;
209
    my $matchpoint_id = shift;
209
	my $matchpoint_id = shift;
210
    
210
211
    my $dbh = C4::Context->dbh;
211
	my $dbh = C4::Context->dbh;
212
    my $sth = $dbh->prepare_cached("SELECT * FROM matchpoints WHERE matchpoint_id = ?");
212
	my $sth = $dbh->prepare_cached("SELECT * FROM matchpoints WHERE matchpoint_id = ?");
213
    $sth->execute($matchpoint_id);
213
	$sth->execute($matchpoint_id);
214
    my $row = $sth->fetchrow_hashref;
214
	my $row = $sth->fetchrow_hashref;
215
    my $matchpoint = {};
215
	my $matchpoint = {};
216
    $matchpoint->{'index'} = $row->{'search_index'};
216
	$matchpoint->{'index'} = $row->{'search_index'};
217
    $matchpoint->{'score'} = int($row->{'score'});
217
	$matchpoint->{'score'} = int($row->{'score'});
218
    $sth->finish();
218
	$sth->finish();
219
219
220
    $matchpoint->{'components'} = [];
220
	$matchpoint->{'components'} = [];
221
    $sth = $dbh->prepare_cached("SELECT * FROM matchpoint_components WHERE matchpoint_id = ? ORDER BY sequence");
221
	$sth = $dbh->prepare_cached("SELECT * FROM matchpoint_components WHERE matchpoint_id = ? ORDER BY sequence");
222
    $sth->execute($matchpoint_id);
222
	$sth->execute($matchpoint_id);
223
    while ($row = $sth->fetchrow_hashref) {
223
	while ($row = $sth->fetchrow_hashref) {
224
        my $component = {};
224
		my $component = {};
225
        $component->{'tag'} = $row->{'tag'};
225
		$component->{'tag'} = $row->{'tag'};
226
        $component->{'subfields'} = { map { $_ => 1 } split(//,  $row->{'subfields'}) };
226
		$component->{'subfields'} = { map { $_ => 1 } split(//,  $row->{'subfields'}) };
227
        $component->{'offset'} = int($row->{'offset'});
227
		$component->{'offset'} = int($row->{'offset'});
228
        $component->{'length'} = int($row->{'length'});
228
		$component->{'length'} = int($row->{'length'});
229
        $component->{'norms'} = [];
229
		$component->{'norms'} = [];
230
        my $sth2 = $dbh->prepare_cached("SELECT * 
230
		my $sth2 = $dbh->prepare_cached("SELECT *
231
                                         FROM matchpoint_component_norms 
231
										 FROM matchpoint_component_norms
232
                                         WHERE matchpoint_component_id = ? ORDER BY sequence");
232
										 WHERE matchpoint_component_id = ? ORDER BY sequence");
233
        $sth2->execute($row->{'matchpoint_component_id'});
233
		$sth2->execute($row->{'matchpoint_component_id'});
234
        while (my $row2 = $sth2->fetchrow_hashref) {
234
		while (my $row2 = $sth2->fetchrow_hashref) {
235
            push @{ $component->{'norms'} }, $row2->{'norm_routine'};
235
			push @{ $component->{'norms'} }, $row2->{'norm_routine'};
236
        }
236
		}
237
        push @{ $matchpoint->{'components'} }, $component;
237
		push @{ $matchpoint->{'components'} }, $component;
238
    }
238
	}
239
    return $matchpoint;
239
	return $matchpoint;
240
}
240
}
241
241
242
=head2 store
242
=head2 store
Lines 252-366 is replaced. Link Here
252
=cut
252
=cut
253
253
254
sub store {
254
sub store {
255
    my $self = shift;
255
	my $self = shift;
256
256
257
    if (defined $self->{'id'}) {
257
	if (defined $self->{'id'}) {
258
        # update
258
		# update
259
        $self->_del_matcher_components();
259
		$self->_del_matcher_components();
260
        $self->_update_marc_matchers();
260
		$self->_update_marc_matchers();
261
    } else {
261
	} else {
262
        # create new
262
		# create new
263
        $self->_new_marc_matchers();
263
		$self->_new_marc_matchers();
264
    }
264
	}
265
    $self->_store_matcher_components();
265
	$self->_store_matcher_components();
266
    return $self->{'id'};
266
	return $self->{'id'};
267
}
267
}
268
268
269
sub _del_matcher_components {
269
sub _del_matcher_components {
270
    my $self = shift;
270
	my $self = shift;
271
271
272
    my $dbh = C4::Context->dbh();
272
	my $dbh = C4::Context->dbh();
273
    my $sth = $dbh->prepare_cached("DELETE FROM matchpoints WHERE matcher_id = ?");
273
	my $sth = $dbh->prepare_cached("DELETE FROM matchpoints WHERE matcher_id = ?");
274
    $sth->execute($self->{'id'});
274
	$sth->execute($self->{'id'});
275
    $sth = $dbh->prepare_cached("DELETE FROM matchchecks WHERE matcher_id = ?");
275
	$sth = $dbh->prepare_cached("DELETE FROM matchchecks WHERE matcher_id = ?");
276
    $sth->execute($self->{'id'});
276
	$sth->execute($self->{'id'});
277
    # foreign key delete cascades take care of deleting relevant rows
277
	# foreign key delete cascades take care of deleting relevant rows
278
    # from matcher_matchpoints, matchpoint_components, and
278
	# from matcher_matchpoints, matchpoint_components, and
279
    # matchpoint_component_norms
279
	# matchpoint_component_norms
280
}
280
}
281
281
282
sub _update_marc_matchers {
282
sub _update_marc_matchers {
283
    my $self = shift;
283
	my $self = shift;
284
284
285
    my $dbh = C4::Context->dbh();
285
	my $dbh = C4::Context->dbh();
286
    my $sth = $dbh->prepare_cached("UPDATE marc_matchers 
286
	my $sth = $dbh->prepare_cached("UPDATE marc_matchers
287
                                    SET code = ?,
287
									SET code = ?,
288
                                        description = ?,
288
										description = ?,
289
                                        record_type = ?,
289
										record_type = ?,
290
                                        threshold = ?
290
										threshold = ?
291
                                    WHERE matcher_id = ?");
291
									WHERE matcher_id = ?");
292
    $sth->execute($self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'}, $self->{'id'});
292
	$sth->execute($self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'}, $self->{'id'});
293
}
293
}
294
294
295
sub _new_marc_matchers {
295
sub _new_marc_matchers {
296
    my $self = shift;
296
	my $self = shift;
297
297
298
    my $dbh = C4::Context->dbh();
298
	my $dbh = C4::Context->dbh();
299
    my $sth = $dbh->prepare_cached("INSERT INTO marc_matchers
299
	my $sth = $dbh->prepare_cached("INSERT INTO marc_matchers
300
                                    (code, description, record_type, threshold)
300
									(code, description, record_type, threshold)
301
                                    VALUES (?, ?, ?, ?)");
301
									VALUES (?, ?, ?, ?)");
302
    $sth->execute($self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'});
302
	$sth->execute($self->{'code'}, $self->{'description'}, $self->{'record_type'}, $self->{'threshold'});
303
    $self->{'id'} = $dbh->{'mysql_insertid'};
303
	$self->{'id'} = $dbh->{'mysql_insertid'};
304
}
304
}
305
305
306
sub _store_matcher_components {
306
sub _store_matcher_components {
307
    my $self = shift;
307
	my $self = shift;
308
308
309
    my $dbh = C4::Context->dbh();
309
	my $dbh = C4::Context->dbh();
310
    my $sth;
310
	my $sth;
311
    my $matcher_id = $self->{'id'};
311
	my $matcher_id = $self->{'id'};
312
    foreach my $matchpoint (@{ $self->{'matchpoints'}}) {
312
	foreach my $matchpoint (@{ $self->{'matchpoints'}}) {
313
        my $matchpoint_id = $self->_store_matchpoint($matchpoint);
313
		my $matchpoint_id = $self->_store_matchpoint($matchpoint);
314
        $sth = $dbh->prepare_cached("INSERT INTO matcher_matchpoints (matcher_id, matchpoint_id)
314
		$sth = $dbh->prepare_cached("INSERT INTO matcher_matchpoints (matcher_id, matchpoint_id)
315
                                     VALUES (?, ?)");
315
									 VALUES (?, ?)");
316
        $sth->execute($matcher_id, $matchpoint_id);
316
		$sth->execute($matcher_id, $matchpoint_id);
317
    }
317
	}
318
    foreach my $matchcheck (@{ $self->{'required_checks'} }) {
318
	foreach my $matchcheck (@{ $self->{'required_checks'} }) {
319
        my $source_matchpoint_id = $self->_store_matchpoint($matchcheck->{'source_matchpoint'});
319
		my $source_matchpoint_id = $self->_store_matchpoint($matchcheck->{'source_matchpoint'});
320
        my $target_matchpoint_id = $self->_store_matchpoint($matchcheck->{'target_matchpoint'});
320
		my $target_matchpoint_id = $self->_store_matchpoint($matchcheck->{'target_matchpoint'});
321
        $sth = $dbh->prepare_cached("INSERT INTO matchchecks
321
		$sth = $dbh->prepare_cached("INSERT INTO matchchecks
322
                                     (matcher_id, source_matchpoint_id, target_matchpoint_id)
322
									 (matcher_id, source_matchpoint_id, target_matchpoint_id)
323
                                     VALUES (?, ?, ?)");
323
									 VALUES (?, ?, ?)");
324
        $sth->execute($matcher_id, $source_matchpoint_id,  $target_matchpoint_id);
324
		$sth->execute($matcher_id, $source_matchpoint_id,  $target_matchpoint_id);
325
    }
325
	}
326
326
327
}
327
}
328
328
329
sub _store_matchpoint {
329
sub _store_matchpoint {
330
    my $self = shift;
330
	my $self = shift;
331
    my $matchpoint = shift;
331
	my $matchpoint = shift;
332
332
333
    my $dbh = C4::Context->dbh();
333
	my $dbh = C4::Context->dbh();
334
    my $sth;
334
	my $sth;
335
    my $matcher_id = $self->{'id'};
335
	my $matcher_id = $self->{'id'};
336
    $sth = $dbh->prepare_cached("INSERT INTO matchpoints (matcher_id, search_index, score)
336
	$sth = $dbh->prepare_cached("INSERT INTO matchpoints (matcher_id, search_index, score)
337
                                 VALUES (?, ?, ?)");
337
								 VALUES (?, ?, ?)");
338
    $sth->execute($matcher_id, $matchpoint->{'index'}, $matchpoint->{'score'});
338
	$sth->execute($matcher_id, $matchpoint->{'index'}, $matchpoint->{'score'});
339
    my $matchpoint_id = $dbh->{'mysql_insertid'};
339
	my $matchpoint_id = $dbh->{'mysql_insertid'};
340
    my $seqnum = 0;
340
	my $seqnum = 0;
341
    foreach my $component (@{ $matchpoint->{'components'} }) {
341
	foreach my $component (@{ $matchpoint->{'components'} }) {
342
        $seqnum++;
342
		$seqnum++;
343
        $sth = $dbh->prepare_cached("INSERT INTO matchpoint_components 
343
		$sth = $dbh->prepare_cached("INSERT INTO matchpoint_components
344
                                     (matchpoint_id, sequence, tag, subfields, offset, length)
344
									 (matchpoint_id, sequence, tag, subfields, offset, length)
345
                                     VALUES (?, ?, ?, ?, ?, ?)");
345
									 VALUES (?, ?, ?, ?, ?, ?)");
346
        $sth->bind_param(1, $matchpoint_id);
346
		$sth->bind_param(1, $matchpoint_id);
347
        $sth->bind_param(2, $seqnum);
347
		$sth->bind_param(2, $seqnum);
348
        $sth->bind_param(3, $component->{'tag'});
348
		$sth->bind_param(3, $component->{'tag'});
349
        $sth->bind_param(4, join "", sort keys %{ $component->{'subfields'} });
349
		$sth->bind_param(4, join "", sort keys %{ $component->{'subfields'} });
350
        $sth->bind_param(5, $component->{'offset'});
350
		$sth->bind_param(5, $component->{'offset'});
351
        $sth->bind_param(6, $component->{'length'});
351
		$sth->bind_param(6, $component->{'length'});
352
        $sth->execute();
352
		$sth->execute();
353
        my $matchpoint_component_id = $dbh->{'mysql_insertid'};
353
		my $matchpoint_component_id = $dbh->{'mysql_insertid'};
354
        my $normseq = 0;
354
		my $normseq = 0;
355
        foreach my $norm (@{ $component->{'norms'} }) {
355
		foreach my $norm (@{ $component->{'norms'} }) {
356
            $normseq++;
356
			$normseq++;
357
            $sth = $dbh->prepare_cached("INSERT INTO matchpoint_component_norms
357
			$sth = $dbh->prepare_cached("INSERT INTO matchpoint_component_norms
358
                                         (matchpoint_component_id, sequence, norm_routine)
358
										 (matchpoint_component_id, sequence, norm_routine)
359
                                         VALUES (?, ?, ?)");
359
										 VALUES (?, ?, ?)");
360
            $sth->execute($matchpoint_component_id, $normseq, $norm);
360
			$sth->execute($matchpoint_component_id, $normseq, $norm);
361
        }
361
		}
362
    }
362
	}
363
    return $matchpoint_id;
363
	return $matchpoint_id;
364
}
364
}
365
365
366
366
Lines 374-385 from the database. Link Here
374
=cut
374
=cut
375
375
376
sub delete {
376
sub delete {
377
    my $class = shift;
377
	my $class = shift;
378
    my $matcher_id = shift;
378
	my $matcher_id = shift;
379
379
380
    my $dbh = C4::Context->dbh;
380
	my $dbh = C4::Context->dbh;
381
    my $sth = $dbh->prepare("DELETE FROM marc_matchers WHERE matcher_id = ?");
381
	my $sth = $dbh->prepare("DELETE FROM marc_matchers WHERE matcher_id = ?");
382
    $sth->execute($matcher_id); # relying on cascading deletes to clean up everything
382
	$sth->execute($matcher_id); # relying on cascading deletes to clean up everything
383
}
383
}
384
384
385
=head2 record_type
385
=head2 record_type
Lines 392-399 Accessor method. Link Here
392
=cut
392
=cut
393
393
394
sub record_type {
394
sub record_type {
395
    my $self = shift;
395
	my $self = shift;
396
    @_ ? $self->{'record_type'} = shift : $self->{'record_type'};
396
	@_ ? $self->{'record_type'} = shift : $self->{'record_type'};
397
}
397
}
398
398
399
=head2 threshold
399
=head2 threshold
Lines 406-413 Accessor method. Link Here
406
=cut
406
=cut
407
407
408
sub threshold {
408
sub threshold {
409
    my $self = shift;
409
	my $self = shift;
410
    @_ ? $self->{'threshold'} = shift : $self->{'threshold'};
410
	@_ ? $self->{'threshold'} = shift : $self->{'threshold'};
411
}
411
}
412
412
413
=head2 _id
413
=head2 _id
Lines 422-429 done outside of the editing CGI. Link Here
422
=cut
422
=cut
423
423
424
sub _id {
424
sub _id {
425
    my $self = shift;
425
	my $self = shift;
426
    @_ ? $self->{'id'} = shift : $self->{'id'};
426
	@_ ? $self->{'id'} = shift : $self->{'id'};
427
}
427
}
428
428
429
=head2 code
429
=head2 code
Lines 436-443 Accessor method. Link Here
436
=cut
436
=cut
437
437
438
sub code {
438
sub code {
439
    my $self = shift;
439
	my $self = shift;
440
    @_ ? $self->{'code'} = shift : $self->{'code'};
440
	@_ ? $self->{'code'} = shift : $self->{'code'};
441
}
441
}
442
442
443
=head2 description
443
=head2 description
Lines 450-457 Accessor method. Link Here
450
=cut
450
=cut
451
451
452
sub description {
452
sub description {
453
    my $self = shift;
453
	my $self = shift;
454
    @_ ? $self->{'description'} = shift : $self->{'description'};
454
	@_ ? $self->{'description'} = shift : $self->{'description'};
455
}
455
}
456
456
457
=head2 add_matchpoint
457
=head2 add_matchpoint
Lines 465-475 is the weight that will be added if a match is found. Link Here
465
$matchcomponents should be a reference to an array of matchpoint
465
$matchcomponents should be a reference to an array of matchpoint
466
compoents, each of which should be a hash containing the following 
466
compoents, each of which should be a hash containing the following 
467
keys:
467
keys:
468
    tag
468
	tag
469
    subfields
469
	subfields
470
    offset
470
	offset
471
    length
471
	length
472
    norms
472
	norms
473
473
474
The normalization_rules value should in turn be a reference to an
474
The normalization_rules value should in turn be a reference to an
475
array, each element of which should be a reference to a 
475
array, each element of which should be a reference to a 
Lines 477-502 normalization subroutine (under C4::Normalize) to be applied Link Here
477
to the source string.
477
to the source string.
478
478
479
=cut
479
=cut
480
    
480
481
sub add_matchpoint {
481
sub add_matchpoint {
482
    my $self = shift;
482
	my $self = shift;
483
    my ($index, $score, $matchcomponents) = @_;
483
	my ($index, $score, $matchcomponents) = @_;
484
484
485
    my $matchpoint = {};
485
	my $matchpoint = {};
486
    $matchpoint->{'index'} = $index;
486
	$matchpoint->{'index'} = $index;
487
    $matchpoint->{'score'} = $score;
487
	$matchpoint->{'score'} = $score;
488
    $matchpoint->{'components'} = [];
488
	$matchpoint->{'components'} = [];
489
    foreach my $input_component (@{ $matchcomponents }) {
489
	foreach my $input_component (@{ $matchcomponents }) {
490
        push @{ $matchpoint->{'components'} }, _parse_match_component($input_component);
490
		push @{ $matchpoint->{'components'} }, _parse_match_component($input_component);
491
    }
491
	}
492
    push @{ $self->{'matchpoints'} }, $matchpoint;
492
	push @{ $self->{'matchpoints'} }, $matchpoint;
493
}
493
}
494
494
495
=head2 add_simple_matchpoint
495
=head2 add_simple_matchpoint
496
496
497
  $matcher->add_simple_matchpoint($index, $score, $source_tag,
497
  $matcher->add_simple_matchpoint($index, $score, $source_tag,
498
                            $source_subfields, $source_offset, 
498
							$source_subfields, $source_offset,
499
                            $source_length, $source_normalizer);
499
							$source_length, $source_normalizer);
500
500
501
501
502
Adds a simple matchpoint rule -- after composing a key based on the source tag and subfields,
502
Adds a simple matchpoint rule -- after composing a key based on the source tag and subfields,
Lines 506-520 will receive the assigned score. Link Here
506
=cut
506
=cut
507
507
508
sub add_simple_matchpoint {
508
sub add_simple_matchpoint {
509
    my $self = shift;
509
	my $self = shift;
510
    my ($index, $score, $source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer) = @_;
510
	my ($index, $score, $source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer) = @_;
511
511
512
    $self->add_matchpoint($index, $score, [
512
	$self->add_matchpoint($index, $score, [
513
                          { tag => $source_tag, subfields => $source_subfields,
513
						  { tag => $source_tag, subfields => $source_subfields,
514
                            offset => $source_offset, 'length' => $source_length,
514
							offset => $source_offset, 'length' => $source_length,
515
                            norms => [ $source_normalizer ]
515
							norms => [ $source_normalizer ]
516
                          }
516
						  }
517
                         ]);
517
						 ]);
518
}
518
}
519
519
520
=head2 add_required_check
520
=head2 add_required_check
Lines 536-546 $source_matchpoint and $target_matchpoint are each a reference to Link Here
536
an array of hashes, where each hash follows the same definition
536
an array of hashes, where each hash follows the same definition
537
as the matchpoint component specification in add_matchpoint, i.e.,
537
as the matchpoint component specification in add_matchpoint, i.e.,
538
538
539
    tag
539
	tag
540
    subfields
540
	subfields
541
    offset
541
	offset
542
    length
542
	length
543
    norms
543
	norms
544
544
545
The normalization_rules value should in turn be a reference to an
545
The normalization_rules value should in turn be a reference to an
546
array, each element of which should be a reference to a 
546
array, each element of which should be a reference to a 
Lines 550-580 to the source string. Link Here
550
=cut
550
=cut
551
551
552
sub add_required_check {
552
sub add_required_check {
553
    my $self = shift;
553
	my $self = shift;
554
    my ($source_matchpoint, $target_matchpoint) = @_;
554
	my ($source_matchpoint, $target_matchpoint) = @_;
555
555
556
    my $matchcheck = {};
556
	my $matchcheck = {};
557
    $matchcheck->{'source_matchpoint'}->{'index'} = '';
557
	$matchcheck->{'source_matchpoint'}->{'index'} = '';
558
    $matchcheck->{'source_matchpoint'}->{'score'} = 0;
558
	$matchcheck->{'source_matchpoint'}->{'score'} = 0;
559
    $matchcheck->{'source_matchpoint'}->{'components'} = [];
559
	$matchcheck->{'source_matchpoint'}->{'components'} = [];
560
    $matchcheck->{'target_matchpoint'}->{'index'} = '';
560
	$matchcheck->{'target_matchpoint'}->{'index'} = '';
561
    $matchcheck->{'target_matchpoint'}->{'score'} = 0;
561
	$matchcheck->{'target_matchpoint'}->{'score'} = 0;
562
    $matchcheck->{'target_matchpoint'}->{'components'} = [];
562
	$matchcheck->{'target_matchpoint'}->{'components'} = [];
563
    foreach my $input_component (@{ $source_matchpoint }) {
563
	foreach my $input_component (@{ $source_matchpoint }) {
564
        push @{ $matchcheck->{'source_matchpoint'}->{'components'} }, _parse_match_component($input_component);
564
		push @{ $matchcheck->{'source_matchpoint'}->{'components'} }, _parse_match_component($input_component);
565
    }
565
	}
566
    foreach my $input_component (@{ $target_matchpoint }) {
566
	foreach my $input_component (@{ $target_matchpoint }) {
567
        push @{ $matchcheck->{'target_matchpoint'}->{'components'} }, _parse_match_component($input_component);
567
		push @{ $matchcheck->{'target_matchpoint'}->{'components'} }, _parse_match_component($input_component);
568
    }
568
	}
569
    push @{ $self->{'required_checks'} }, $matchcheck;
569
	push @{ $self->{'required_checks'} }, $matchcheck;
570
}
570
}
571
571
572
=head2 add_simple_required_check
572
=head2 add_simple_required_check
573
573
574
  $matcher->add_simple_required_check($source_tag, $source_subfields,
574
  $matcher->add_simple_required_check($source_tag, $source_subfields,
575
                $source_offset, $source_length, $source_normalizer, 
575
				$source_offset, $source_length, $source_normalizer,
576
                $target_tag, $target_subfields, $target_offset, 
576
				$target_tag, $target_subfields, $target_offset,
577
                $target_length, $target_normalizer);
577
				$target_length, $target_normalizer);
578
578
579
Adds a required check, which requires that the normalized keys made from the source and targets
579
Adds a required check, which requires that the normalized keys made from the source and targets
580
must match for a match to be considered valid.
580
must match for a match to be considered valid.
Lines 582-607 must match for a match to be considered valid. Link Here
582
=cut
582
=cut
583
583
584
sub add_simple_required_check {
584
sub add_simple_required_check {
585
    my $self = shift;
585
	my $self = shift;
586
    my ($source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer,
586
	my ($source_tag, $source_subfields, $source_offset, $source_length, $source_normalizer,
587
        $target_tag, $target_subfields, $target_offset, $target_length, $target_normalizer) = @_;
587
		$target_tag, $target_subfields, $target_offset, $target_length, $target_normalizer) = @_;
588
588
589
    $self->add_required_check(
589
	$self->add_required_check(
590
      [ { tag => $source_tag, subfields => $source_subfields, offset => $source_offset, 'length' => $source_length,
590
	  [ { tag => $source_tag, subfields => $source_subfields, offset => $source_offset, 'length' => $source_length,
591
          norms => [ $source_normalizer ] } ],
591
		  norms => [ $source_normalizer ] } ],
592
      [ { tag => $target_tag, subfields => $target_subfields, offset => $target_offset, 'length' => $target_length,
592
	  [ { tag => $target_tag, subfields => $target_subfields, offset => $target_offset, 'length' => $target_length,
593
          norms => [ $target_normalizer ] } ]
593
		  norms => [ $target_normalizer ] } ]
594
    );
594
	);
595
}
595
}
596
596
597
=head2 get_matches
597
=head2 get_matches
598
598
599
  my @matches = $matcher->get_matches($marc_record, $max_matches);
599
  my @matches = $matcher->get_matches($marc_record, $max_matches);
600
  foreach $match (@matches) {
600
  foreach $match (@matches) {
601
      # matches already sorted in order of
601
	  # matches already sorted in order of
602
      # decreasing score
602
	  # decreasing score
603
      print "record ID: $match->{'record_id'};
603
	  print "record ID: $match->{'record_id'};
604
      print "score:     $match->{'score'};
604
	  print "score:     $match->{'score'};
605
  }
605
  }
606
606
607
Identifies all of the records matching the given MARC record.  For a record already 
607
Identifies all of the records matching the given MARC record.  For a record already 
Lines 621-743 in order of decreasing score, i.e., the best match is first. Link Here
621
=cut
621
=cut
622
622
623
sub get_matches {
623
sub get_matches {
624
    my $self = shift;
624
	my $self = shift;
625
    my ($source_record, $max_matches) = @_;
625
	my ($source_record, $max_matches) = @_;
626
626
627
    my %matches = ();
627
	my %matches = ();
628
628
629
    my $QParser;
629
	my $QParser;
630
    $QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser'));
630
	$QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser'));
631
    foreach my $matchpoint ( @{ $self->{'matchpoints'} } ) {
631
	foreach my $matchpoint ( @{ $self->{'matchpoints'} } ) {
632
        my @source_keys = _get_match_keys( $source_record, $matchpoint );
632
		my @source_keys = _get_match_keys( $source_record, $matchpoint );
633
633
634
        next if scalar(@source_keys) == 0;
634
		next if scalar(@source_keys) == 0;
635
635
636
        # FIXME - because of a bug in QueryParser, an expression ofthe
636
		# FIXME - because of a bug in QueryParser, an expression ofthe
637
        # format 'isbn:"isbn1" || isbn:"isbn2" || isbn"isbn3"...'
637
		# format 'isbn:"isbn1" || isbn:"isbn2" || isbn"isbn3"...'
638
        # does not get parsed correctly, so we will not
638
		# does not get parsed correctly, so we will not
639
        # do AggressiveMatchOnISBN if UseQueryParser is on
639
		# do AggressiveMatchOnISBN if UseQueryParser is on
640
        @source_keys = C4::Koha::GetVariationsOfISBNs(@source_keys)
640
		@source_keys = C4::Koha::GetVariationsOfISBNs(@source_keys)
641
          if ( $matchpoint->{index} =~ /^isbn$/i
641
		  if ( $matchpoint->{index} =~ /^isbn$/i
642
            && C4::Context->preference('AggressiveMatchOnISBN') )
642
			&& C4::Context->preference('AggressiveMatchOnISBN') )
643
            && !C4::Context->preference('UseQueryParser');
643
			&& !C4::Context->preference('UseQueryParser');
644
644
645
        # build query
645
		# build query
646
        my $query;
646
		my $query;
647
        my $error;
647
		my $error;
648
        my $searchresults;
648
		my $searchresults;
649
        my $total_hits;
649
		my $total_hits;
650
        if ( $self->{'record_type'} eq 'biblio' ) {
650
		if ( $self->{'record_type'} eq 'biblio' ) {
651
651
652
            if ($QParser) {
652
			if ($QParser) {
653
                $query = join( " || ",
653
				$query = join( " || ",
654
                    map { "$matchpoint->{'index'}:$_" } @source_keys );
654
					map { "$matchpoint->{'index'}:$_" } @source_keys );
655
            }
655
			}
656
            else {
656
			else {
657
                my $phr = C4::Context->preference('AggressiveMatchOnISBN') ? ',phr' : q{};
657
				my $phr = C4::Context->preference('AggressiveMatchOnISBN') ? ',phr' : q{};
658
                $query = join( " or ",
658
				$query = join( " or ",
659
                    map { "$matchpoint->{'index'}$phr=$_" } @source_keys );
659
					map { "$matchpoint->{'index'}$phr=$_" } @source_keys );
660
            }
660
			}
661
662
            require C4::Search;
663
664
            ( $error, $searchresults, $total_hits ) =
665
              C4::Search::SimpleSearch( $query, 0, $max_matches );
666
        }
667
        elsif ( $self->{'record_type'} eq 'authority' ) {
668
            my $authresults;
669
            my @marclist;
670
            my @and_or;
671
            my @excluding = [];
672
            my @operator;
673
            my @value;
674
            foreach my $key (@source_keys) {
675
                push @marclist, $matchpoint->{'index'};
676
                push @and_or,   'or';
677
                push @operator, 'exact';
678
                push @value,    $key;
679
            }
680
            require C4::AuthoritiesMarc;
681
            ( $authresults, $total_hits ) =
682
              C4::AuthoritiesMarc::SearchAuthorities(
683
                \@marclist,  \@and_or, \@excluding, \@operator,
684
                \@value,     0,        20,          undef,
685
                'AuthidAsc', 1
686
              );
687
            foreach my $result (@$authresults) {
688
                push @$searchresults, $result->{'authid'};
689
            }
690
        }
691
692
        #Collect the results
693
        if ( defined $error ) {
694
            warn "search failed ($query) $error";
695
        }
696
        else {
697
            if ($self->{'record_type'} eq 'authority') {
698
                foreach my $matched ( @{$searchresults} ) {
699
                    $matches{$matched}->{score} += $matchpoint->{'score'};
700
                }
701
            }
702
            elsif ($self->{'record_type'} eq 'biblio') {
703
                foreach my $matched ( @{$searchresults} ) {
704
                    my $record = C4::Search::new_record_from_zebra( 'biblioserver', $matched );
705
                    $matches{$record}->{score} += $matchpoint->{'score'}; #Using $record HASH string representation as the key :)
706
                    $matches{$record}->{record} = $record;
707
                }
708
            }
709
661
710
        }
662
			require C4::Search;
711
    }
663
664
			( $error, $searchresults, $total_hits ) =
665
			  C4::Search::SimpleSearch( $query, 0, $max_matches );
666
		}
667
		elsif ( $self->{'record_type'} eq 'authority' ) {
668
			my $authresults;
669
			my @marclist;
670
			my @and_or;
671
			my @excluding = [];
672
			my @operator;
673
			my @value;
674
			foreach my $key (@source_keys) {
675
				push @marclist, $matchpoint->{'index'};
676
				push @and_or,   'or';
677
				push @operator, 'exact';
678
				push @value,    $key;
679
			}
680
			require C4::AuthoritiesMarc;
681
			( $authresults, $total_hits ) =
682
			  C4::AuthoritiesMarc::SearchAuthorities(
683
				\@marclist,  \@and_or, \@excluding, \@operator,
684
				\@value,     0,        20,          undef,
685
				'AuthidAsc', 1
686
			  );
687
			foreach my $result (@$authresults) {
688
				push @$searchresults, $result->{'authid'};
689
			}
690
		}
691
692
		#Collect the results
693
		if ( defined $error ) {
694
			warn "search failed ($query) $error";
695
		}
696
		else {
697
			if ($self->{'record_type'} eq 'authority') {
698
				foreach my $matched ( @{$searchresults} ) {
699
					$matches{$matched}->{score} += $matchpoint->{'score'};
700
				}
701
			}
702
			elsif ($self->{'record_type'} eq 'biblio') {
703
				foreach my $matched ( @{$searchresults} ) {
704
					my $record = C4::Search::new_record_from_zebra( 'biblioserver', $matched );
705
					$matches{$record}->{score} += $matchpoint->{'score'}; #Using $record HASH string representation as the key :)
706
					$matches{$record}->{record} = $record;
707
				}
708
			}
712
709
713
    # get rid of any that don't meet the threshold
710
		}
714
    %matches = map { ($matches{$_}->{score} >= $self->{'threshold'}) ? ($_ => $matches{$_}) : () } keys %matches;
711
	}
715
712
716
    # get rid of any that don't meet the required checks
713
	# get rid of any that don't meet the threshold
717
    %matches = map { _passes_required_checks($source_record, $matches{$_}->{record}, $self->{'required_checks'}) ?  ($_ => $matches{$_}) : () }
714
	%matches = map { ($matches{$_}->{score} >= $self->{'threshold'}) ? ($_ => $matches{$_}) : () } keys %matches;
718
                keys %matches unless ($self->{'record_type'} eq 'auth');
715
719
716
	# get rid of any that don't meet the required checks
720
    my @results = ();
717
	%matches = map { _passes_required_checks($source_record, $matches{$_}->{record}, $self->{'required_checks'}) ?  ($_ => $matches{$_}) : () }
721
    if ($self->{'record_type'} eq 'biblio') {
718
				keys %matches unless ($self->{'record_type'} eq 'auth');
722
        require C4::Biblio;
719
723
        foreach my $hashkey (keys %matches) {
720
	my @results = ();
724
            my $target_record = $matches{$hashkey}->{record};
721
	if ($self->{'record_type'} eq 'biblio') {
725
            my $record_number;
722
		require C4::Biblio;
726
            my $result = C4::Biblio::TransformMarcToKoha(C4::Context->dbh, $target_record, '');
723
		foreach my $hashkey (keys %matches) {
727
            $record_number = $result->{'biblionumber'};
724
			my $target_record = $matches{$hashkey}->{record};
728
            push @results, { 'record_id' => $record_number, 'score' => $matches{$hashkey}->{score}, 'target_record' => $target_record, 'target_biblio' => $result };
725
			my $record_number;
729
        }
726
			my $result = C4::Biblio::TransformMarcToKoha(C4::Context->dbh, $target_record, '');
730
    } elsif ($self->{'record_type'} eq 'authority') {
727
			$record_number = $result->{'biblionumber'};
731
        require C4::AuthoritiesMarc;
728
			push @results, { 'record_id' => $record_number, 'score' => $matches{$hashkey}->{score}, 'target_record' => $target_record, 'target_biblio' => $result };
732
        foreach my $authid (keys %matches) {
729
		}
733
            push @results, { 'record_id' => $authid, 'score' => $matches{$authid}->{score} };
730
	} elsif ($self->{'record_type'} eq 'authority') {
734
        }
731
		require C4::AuthoritiesMarc;
735
    }
732
		foreach my $authid (keys %matches) {
736
    @results = sort { $b->{'score'} cmp $a->{'score'} } @results;
733
			push @results, { 'record_id' => $authid, 'score' => $matches{$authid}->{score} };
737
    if (scalar(@results) > $max_matches) {
734
		}
738
        @results = @results[0..$max_matches-1];
735
	}
739
    }
736
	@results = sort { $b->{'score'} cmp $a->{'score'} } @results;
740
    return @results;
737
	if (scalar(@results) > $max_matches) {
738
		@results = @results[0..$max_matches-1];
739
	}
740
	return @results;
741
741
742
}
742
}
743
743
Lines 752-872 aid setting up a HTML editing form. Link Here
752
=cut
752
=cut
753
753
754
sub dump {
754
sub dump {
755
    my $self = shift;
755
	my $self = shift;
756
   
756
   
757
    my $result = {};
757
	my $result = {};
758
758
759
    $result->{'matcher_id'} = $self->{'id'};
759
	$result->{'matcher_id'} = $self->{'id'};
760
    $result->{'code'} = $self->{'code'};
760
	$result->{'code'} = $self->{'code'};
761
    $result->{'description'} = $self->{'description'};
761
	$result->{'description'} = $self->{'description'};
762
    $result->{'record_type'} = $self->{'record_type'};
762
	$result->{'record_type'} = $self->{'record_type'};
763
763
764
    $result->{'matchpoints'} = [];
764
	$result->{'matchpoints'} = [];
765
    foreach my $matchpoint (@{ $self->{'matchpoints'} }) {
765
	foreach my $matchpoint (@{ $self->{'matchpoints'} }) {
766
        push @{  $result->{'matchpoints'} }, $matchpoint;
766
		push @{  $result->{'matchpoints'} }, $matchpoint;
767
    }
767
	}
768
    $result->{'matchchecks'} = [];
768
	$result->{'matchchecks'} = [];
769
    foreach my $matchcheck (@{ $self->{'required_checks'} }) {
769
	foreach my $matchcheck (@{ $self->{'required_checks'} }) {
770
        push @{  $result->{'matchchecks'} }, $matchcheck;
770
		push @{  $result->{'matchchecks'} }, $matchcheck;
771
    }
771
	}
772
772
773
    return $result;
773
	return $result;
774
}
774
}
775
775
776
sub _passes_required_checks {
776
sub _passes_required_checks {
777
    my ($source_record, $target_record, $matchchecks) = @_;
777
	my ($source_record, $target_record, $matchchecks) = @_;
778
778
779
    # no checks supplied == automatic pass
779
	# no checks supplied == automatic pass
780
    return 1 if $#{ $matchchecks } == -1;
780
	return 1 if $#{ $matchchecks } == -1;
781
781
782
    foreach my $matchcheck (@{ $matchchecks }) {
782
	foreach my $matchcheck (@{ $matchchecks }) {
783
        my $source_key = join "", _get_match_keys($source_record, $matchcheck->{'source_matchpoint'});
783
		my $source_key = join "", _get_match_keys($source_record, $matchcheck->{'source_matchpoint'});
784
        my $target_key = join "", _get_match_keys($target_record, $matchcheck->{'target_matchpoint'});
784
		my $target_key = join "", _get_match_keys($target_record, $matchcheck->{'target_matchpoint'});
785
        return 0 unless $source_key eq $target_key;
785
		return 0 unless $source_key eq $target_key;
786
    }
786
	}
787
    return 1;
787
	return 1;
788
}
788
}
789
789
790
sub _get_match_keys {
790
sub _get_match_keys {
791
    my $source_record = shift;
791
	my $source_record = shift;
792
    my $matchpoint = shift;
792
	my $matchpoint = shift;
793
    my $check_only_first_repeat = @_ ? shift : 0;
793
	my $check_only_first_repeat = @_ ? shift : 0;
794
794
795
    # If there is more than one component to the matchpoint (e.g.,
795
	# If there is more than one component to the matchpoint (e.g.,
796
    # matchpoint includes both 003 and 001), any repeats
796
	# matchpoint includes both 003 and 001), any repeats
797
    # of the first component's tag are identified; repeats
797
	# of the first component's tag are identified; repeats
798
    # of the subsequent components' tags are appended to
798
	# of the subsequent components' tags are appended to
799
    # each parallel key dervied from the first component,
799
	# each parallel key dervied from the first component,
800
    # up to the number of repeats of the first component's tag.
800
	# up to the number of repeats of the first component's tag.
801
    #
801
	#
802
    # For example, if the record has one 003 and two 001s, only
802
	# For example, if the record has one 003 and two 001s, only
803
    # one key is retrieved because there is only one 003.  The key
803
	# one key is retrieved because there is only one 003.  The key
804
    # will consist of the contents of the first 003 and first 001.
804
	# will consist of the contents of the first 003 and first 001.
805
    #
805
	#
806
    # If there are two 003s and two 001s, there will be two keys:
806
	# If there are two 003s and two 001s, there will be two keys:
807
    #    first 003 + first 001
807
	#    first 003 + first 001
808
    #    second 003 + second 001
808
	#    second 003 + second 001
809
    
809
810
    my @keys = ();
810
	my @keys = ();
811
    for (my $i = 0; $i <= $#{ $matchpoint->{'components'} }; $i++) {
811
	for (my $i = 0; $i <= $#{ $matchpoint->{'components'} }; $i++) {
812
        my $component = $matchpoint->{'components'}->[$i];
812
		my $component = $matchpoint->{'components'}->[$i];
813
        my $j = -1;
813
		my $j = -1;
814
        FIELD: foreach my $field ($source_record->field($component->{'tag'})) {
814
		FIELD: foreach my $field ($source_record->field($component->{'tag'})) {
815
            $j++;
815
			$j++;
816
            last FIELD if $j > 0 and $check_only_first_repeat;
816
			last FIELD if $j > 0 and $check_only_first_repeat;
817
            last FIELD if $i > 0 and $j > $#keys;
817
			last FIELD if $i > 0 and $j > $#keys;
818
            my $key = "";
818
			my $key = "";
819
			my $string;
819
			my $string;
820
            if ($field->is_control_field()) {
820
			if ($field->is_control_field()) {
821
				$string=$field->data();
821
				$string=$field->data();
822
            } else {
822
			} else {
823
                foreach my $subfield ($field->subfields()) {
823
				foreach my $subfield ($field->subfields()) {
824
                    if (exists $component->{'subfields'}->{$subfield->[0]}) {
824
					if (exists $component->{'subfields'}->{$subfield->[0]}) {
825
                        $string .= " " . $subfield->[1];
825
						$string .= " " . $subfield->[1];
826
                    }
826
					}
827
                }
827
				}
828
			}
828
			}
829
            if ($component->{'length'}>0) {
829
			if ($component->{'length'}>0) {
830
                    $string= substr($string, $component->{'offset'}, $component->{'length'});
830
					$string= substr($string, $component->{'offset'}, $component->{'length'});
831
                            # FIXME normalize, substr
831
							# FIXME normalize, substr
832
            } elsif ($component->{'offset'}) {
832
			} elsif ($component->{'offset'}) {
833
                    $string= substr($string, $component->{'offset'});
833
					$string= substr($string, $component->{'offset'});
834
            }
834
			}
835
            $key = _normalize($string);
835
			$key = _normalize($string);
836
            if ($i == 0) {
836
			if ($i == 0) {
837
                push @keys, $key if $key;
837
				push @keys, $key if $key;
838
            } else {
838
			} else {
839
                $keys[$j] .= " $key" if $key;
839
				$keys[$j] .= " $key" if $key;
840
            }
840
			}
841
        }
841
		}
842
    }
842
	}
843
    return @keys;
843
	return @keys;
844
}
844
}
845
845
846
846
847
sub _parse_match_component {
847
sub _parse_match_component {
848
    my $input_component = shift;
848
	my $input_component = shift;
849
849
850
    my $component = {};
850
	my $component = {};
851
    $component->{'tag'} = $input_component->{'tag'};
851
	$component->{'tag'} = $input_component->{'tag'};
852
    $component->{'subfields'} = { map { $_ => 1 } split(//, $input_component->{'subfields'}) };
852
	$component->{'subfields'} = { map { $_ => 1 } split(//, $input_component->{'subfields'}) };
853
    $component->{'offset'} = exists($input_component->{'offset'}) ? $input_component->{'offset'} : -1;
853
	$component->{'offset'} = exists($input_component->{'offset'}) ? $input_component->{'offset'} : -1;
854
    $component->{'length'} = $input_component->{'length'} ? $input_component->{'length'} : 0;
854
	$component->{'length'} = $input_component->{'length'} ? $input_component->{'length'} : 0;
855
    $component->{'norms'} =  $input_component->{'norms'} ? $input_component->{'norms'} : [];
855
	$component->{'norms'} =  $input_component->{'norms'} ? $input_component->{'norms'} : [];
856
856
857
    return $component;
857
	return $component;
858
}
858
}
859
859
860
# FIXME - default normalizer
860
# FIXME - default normalizer
861
sub _normalize {
861
sub _normalize {
862
    my $value = uc shift;
862
	my $value = uc shift;
863
    $value =~ s/[.;:,\]\[\)\(\/'"]//g;
863
	$value =~ s/[.;:,\]\[\)\(\/'"]//g;
864
    $value =~ s/^\s+//;
864
	$value =~ s/^\s+//;
865
    #$value =~ s/^\s+$//;
865
	#$value =~ s/^\s+$//;
866
    $value =~ s/\s+$//;
866
	$value =~ s/\s+$//;
867
    $value =~ s/\s+/ /g;
867
	$value =~ s/\s+/ /g;
868
    #$value =~ s/[.;,\]\[\)\(\/"']//g;
868
	#$value =~ s/[.;,\]\[\)\(\/"']//g;
869
    return $value;
869
	return $value;
870
}
871
872
=head2 overlayRecord
873
874
  $mergedRecord = $matcher->overlayRecord($old_record, $new_record);
875
876
@Param1 MARC:Record of the old record whose fields should be preserved
877
@Param2 MARC:Record of the record whose fields should be overwritten with the old ones
878
@Returns MARC::Record-object with overlayed fields.
879
880
Overlays the new_record with the designated fields from the old_record.
881
Fields are defined using this C4::Matcher's "Match points".
882
-Tag and subfields can be used. If only tag is given, all subfields for all the tags present in the old_record are selected.
883
-If subfields are defined, only the defined subfields are selected and other subfields are lost.
884
-Selected subfields/fields are copied over same elements in the new_record, or if the new_record misses those elements,
885
  new ones are created.
886
887
=cut
888
889
sub overlayRecord {
890
    my $matcher = shift; #Get my $self!
891
    my ($old_record, $record) = @_;
892
    foreach my $matchpoint ( @{$matcher->{matchpoints}} ) {
893
        foreach my $component ( @{$matchpoint->{components}} ) {
894
            my $tag = $component->{tag};
895
            my @t = keys(%{$component->{subfields}});
896
            my $subfield = shift(@t);
897
            my $normalizer = $component->{norms}->[0];
898
899
            _copyFieldsTo( $old_record, $record, $tag, $subfield );
900
        }
901
    }
902
903
    foreach my $required_check (@{$matcher->{required_checks}}) {
904
        my $source_field = $required_check->{source_matchpoint}->{components}->[0]->{tag};
905
        my @t = keys(%{$required_check->{source_matchpoint}->{components}->[0]->{subfields}});
906
        my $source_subfield = shift @t;
907
        my $source_norms = $required_check->{source_matchpoint}->{components}->[0]->{norms}->[0];
908
        my $target_field = $required_check->{target_matchpoint}->{components}->[0]->{tag};
909
        @t = keys(%{$required_check->{target_matchpoint}->{components}->[0]->{subfields}});
910
        my $target_subfield = shift @t;
911
        my $target_norms = $required_check->{target_matchpoint}->{components}->[0]->{norms}->[0];
912
913
        if ($source_norms =~ /copy/ && $target_norms =~ /paste/) {
914
            _copyFieldsTo( $record, $record, $source_field, $source_subfield, $target_field, $target_subfield );
915
        }
916
        elsif ($source_norms =~ /move/ && $target_norms =~ /paste/) {
917
            _copyFieldsTo( $record, $record, $source_field, $source_subfield, $target_field, $target_subfield );
918
            if ($source_field && $source_subfield) {
919
                my @source_fields = $record->field($source_field);
920
                foreach my $f (@source_fields) {
921
                    $f->delete_subfield(code => $source_subfield);
922
                }
923
            }
924
            elsif ($source_field) {
925
                my @source_fields = $record->field($source_field);
926
                $record->delete_fields(@source_fields);
927
            }
928
        }
929
        elsif ($source_norms =~ /preserve/ && $target_norms =~ /preserve/) {
930
            _copyFieldsTo( $old_record, $record, $source_field, $source_subfield, $target_field, $target_subfield );
931
        }
932
933
    }
934
    return $record;
935
}
936
#Copies the given field and subfield from $oldRecord to the $newRecord as a new field and subfield
937
#
938
#   _copyFieldsTo($oldRecord, $newRecord, '049', 'a', '051, 'c');
939
#   _copyFieldsTo($oldRecord, $newRecord, '049', 'a'); #Target field and subfield defaults to '049' and 'a'
940
#
941
#@PARAM1  MARC::Record from which to copy fields from
942
#@PARAM2  MARC::Record to receive the copied fields
943
#@PARAM3  source tag as String
944
#@PARAM4  source subfield as String, optional, if omited copies the whole field regardless of target definitions
945
#@PARAM5  target field, if the source field needs to change the field code
946
#@PARAM6  target subfield, if the source subfield needs to change code
947
sub _copyFieldsTo {
948
    my ($oldRecord, $newRecord, $sourceField, $sourceSubfield, $targetField, $targetSubfield) = @_;
949
    $targetField = $sourceField unless $targetField;
950
    $targetSubfield = $sourceSubfield unless $targetSubfield;
951
952
    my @oldFields = $oldRecord->field($sourceField);
953
    my @newFields = $newRecord->field($targetField);
954
955
    if (@oldFields) { #There is no point in continuing if there is nothing to preserve.
956
        for (my $oi=0 ; $oi < scalar @oldFields ; $oi++) {
957
958
            my $old_field = $oldFields[$oi];
959
            my $new_field = $newFields[$oi];
960
            if (not($new_field) && not($sourceSubfield)) { #If no new field present, clone the old field
961
                $new_field = $old_field->clone();
962
                $new_field->set_tag( $targetField ) if $targetField;
963
                $newRecord->append_fields( $new_field );
964
            }
965
            else { #Copy the designated fields
966
                my @subfields = ($sourceSubfield);
967
                @subfields = map {$_->[0]} $old_field->subfields() unless $sourceSubfield; #Move all subfields if none are define
968
969
                if (@subfields) {
970
                    foreach my $sftag ( @subfields ) {
971
                        my $oldSfContent = $old_field->subfield($sftag);
972
                        if ( $oldSfContent ) {
973
                            $sftag = $targetSubfield if $targetSubfield;
974
975
                            if (not($new_field)) { #Why is MARC::Field so crap that it doesn't allow creating an empty object?
976
                                $new_field = MARC::Field->new(  $targetField, ' ', ' ', $sftag => $oldSfContent  );
977
                                $newRecord->append_fields( $new_field );
978
                            }
979
                            else {
980
                                $new_field->update( $sftag => $oldSfContent );
981
                            }
982
                        }
983
                    }
984
                }
985
            }
986
        }
987
    }
870
}
988
}
871
989
872
1;
990
1;
(-)a/cataloguing/addbiblio.pl (+12 lines)
Lines 35-40 use C4::Branch; # XXX subfield_is_koha_internal_p Link Here
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) {
(-)a/cataloguing/z3950_search.pl (+7 lines)
Lines 27-32 use C4::Output; Link Here
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();
(-)a/koha-tmpl/intranet-tmpl/prog/en/modules/cataloguing/z3950_search.tt (-4 / +13 lines)
Lines 2-14 Link Here
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>&nbsp;</th>
169
		<th>&nbsp;</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&amp;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&amp;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
- 

Return to bug 13181