Lines 227-232
sub Z3950Search {
Link Here
|
227 |
); |
227 |
); |
228 |
} |
228 |
} |
229 |
|
229 |
|
|
|
230 |
sub _auth_build_query { |
231 |
my ( $pars ) = @_; |
232 |
|
233 |
my $nameany= $pars->{nameany}; |
234 |
my $authorany= $pars->{authorany}; |
235 |
my $authorpersonal= $pars->{authorpersonal}; |
236 |
my $authorcorp= $pars->{authorcorp}; |
237 |
my $authormeetingcon= $pars->{authormeetingcon}; |
238 |
my $title= $pars->{title}; |
239 |
my $uniformtitle= $pars->{uniformtitle}; |
240 |
my $subject= $pars->{subject}; |
241 |
my $subjectsubdiv= $pars->{subjectsubdiv}; |
242 |
my $srchany= $pars->{srchany}; |
243 |
my $authid= $pars->{authid}; |
244 |
|
245 |
my $qry_build = { |
246 |
nameany => '@attr 1=1002 "#term" ', |
247 |
authorany => '@attr 1=1003 "#term" ', |
248 |
authorcorp => '@attr 1=2 "#term" ', |
249 |
authorpersonal => '@attr 1=1 "#term" ', |
250 |
authormeetingcon => '@attr 1=3 "#term" ', |
251 |
subject => '@attr 1=21 "#term" ', |
252 |
subjectsubdiv => '@attr 1=47 "#term" ', |
253 |
title => '@attr 1=4 "#term" ', |
254 |
uniformtitle => '@attr 1=6 "#term" ', |
255 |
srchany => '@attr 1=1016 "#term" ', |
256 |
}; |
257 |
|
258 |
my $zquery=''; |
259 |
my $squery=''; |
260 |
my $nterms=0; |
261 |
foreach my $k ( sort keys %$pars ) { |
262 |
#note that the sort keys forces an identical result under Perl 5.18 |
263 |
#one of the unit tests is based on that assumption |
264 |
if( ( my $val=$pars->{$k} ) && $qry_build->{$k} ) { |
265 |
$qry_build->{$k} =~ s/#term/$val/g; |
266 |
$zquery .= $qry_build->{$k}; |
267 |
$squery .= "[$k]=\"$val\" and "; |
268 |
$nterms++; |
269 |
} |
270 |
} |
271 |
$zquery = "\@and " . $zquery for 2..$nterms; |
272 |
$squery =~ s/ and $//; |
273 |
return ( $zquery, $squery ); |
274 |
|
275 |
} |
276 |
|
230 |
sub _build_query { |
277 |
sub _build_query { |
231 |
my ( $pars ) = @_; |
278 |
my ( $pars ) = @_; |
232 |
|
279 |
|
Lines 268-278
sub _handle_one_result {
Link Here
|
268 |
my $raw= $zoomrec->raw(); |
315 |
my $raw= $zoomrec->raw(); |
269 |
my $marcrecord; |
316 |
my $marcrecord; |
270 |
if( $servhref->{servertype} eq 'sru' ) { |
317 |
if( $servhref->{servertype} eq 'sru' ) { |
271 |
$marcrecord= MARC::Record->new_from_xml( $raw, 'UTF-8', |
318 |
$raw= MARC::Record->new_from_xml( $raw, $servhref->{encoding}, $servhref->{syntax} ); |
272 |
$servhref->{syntax} ); |
|
|
273 |
} else { |
274 |
($marcrecord) = MarcToUTF8Record($raw, C4::Context->preference('marcflavour'), $servhref->{encoding} // "iso-5426" ); #ignores charset return values |
275 |
} |
319 |
} |
|
|
320 |
($marcrecord) = MarcToUTF8Record($raw, C4::Context->preference('marcflavour'), $servhref->{encoding} // "iso-5426" ); #ignores charset return values |
276 |
SetUTF8Flag($marcrecord); |
321 |
SetUTF8Flag($marcrecord); |
277 |
my $error; |
322 |
my $error; |
278 |
( $marcrecord, $error ) = _do_xslt_proc($marcrecord, $servhref, $xslh); |
323 |
( $marcrecord, $error ) = _do_xslt_proc($marcrecord, $servhref, $xslh); |
Lines 369-375
sub _create_connection {
Link Here
|
369 |
$option1->option( 'user', $server->{userid} ) if $server->{userid}; |
414 |
$option1->option( 'user', $server->{userid} ) if $server->{userid}; |
370 |
$option1->option( 'password', $server->{password} ) if $server->{password}; |
415 |
$option1->option( 'password', $server->{password} ) if $server->{password}; |
371 |
} |
416 |
} |
372 |
|
|
|
373 |
my $obj= ZOOM::Connection->create($option1); |
417 |
my $obj= ZOOM::Connection->create($option1); |
374 |
if( $server->{servertype} eq 'sru' ) { |
418 |
if( $server->{servertype} eq 'sru' ) { |
375 |
my $host= $server->{host}; |
419 |
my $host= $server->{host}; |
Lines 410-416
sub _translate_query { #SRU query adjusted per server cf. srufields column
Link Here
|
410 |
|
454 |
|
411 |
=head2 ImportBreedingAuth |
455 |
=head2 ImportBreedingAuth |
412 |
|
456 |
|
413 |
ImportBreedingAuth($marcrecords,$overwrite_auth,$filename,$encoding,$z3950random,$batch_type); |
457 |
ImportBreedingAuth($marcrecords,$overwrite_auth,$filename,$encoding,$z3950random); |
414 |
|
458 |
|
415 |
ImportBreedingAuth imports MARC records in the reservoir (import_records table). |
459 |
ImportBreedingAuth imports MARC records in the reservoir (import_records table). |
416 |
ImportBreedingAuth is based on the ImportBreeding subroutine. |
460 |
ImportBreedingAuth is based on the ImportBreeding subroutine. |
Lines 418-426
ImportBreedingAuth($marcrecords,$overwrite_auth,$filename,$encoding,$z3950random
Link Here
|
418 |
=cut |
462 |
=cut |
419 |
|
463 |
|
420 |
sub ImportBreedingAuth { |
464 |
sub ImportBreedingAuth { |
421 |
my ($marcrecords,$overwrite_auth,$filename,$encoding,$z3950random,$batch_type) = @_; |
465 |
my ($marcrecord,$overwrite_auth,$filename,$encoding,$z3950random) = @_; |
422 |
my @marcarray = split /\x1D/, $marcrecords; |
|
|
423 |
|
424 |
my $dbh = C4::Context->dbh; |
466 |
my $dbh = C4::Context->dbh; |
425 |
|
467 |
|
426 |
my $batch_id = GetZ3950BatchId($filename); |
468 |
my $batch_id = GetZ3950BatchId($filename); |
Lines 435-444
sub ImportBreedingAuth {
Link Here
|
435 |
my $alreadyinfarm = 0; |
477 |
my $alreadyinfarm = 0; |
436 |
my $notmarcrecord = 0; |
478 |
my $notmarcrecord = 0; |
437 |
my $breedingid; |
479 |
my $breedingid; |
438 |
for (my $i=0;$i<=$#marcarray;$i++) { |
|
|
439 |
my ($marcrecord, $charset_result, $charset_errors); |
440 |
($marcrecord, $charset_result, $charset_errors) = |
441 |
MarcToUTF8Record($marcarray[$i]."\x1D", $marc_type, $encoding); |
442 |
|
480 |
|
443 |
# Normalize the record so it doesn't have separated diacritics |
481 |
# Normalize the record so it doesn't have separated diacritics |
444 |
SetUTF8Flag($marcrecord); |
482 |
SetUTF8Flag($marcrecord); |
Lines 482-488
sub ImportBreedingAuth {
Link Here
|
482 |
} |
520 |
} |
483 |
} |
521 |
} |
484 |
} |
522 |
} |
485 |
} |
|
|
486 |
return ($notmarcrecord,$alreadyindb,$alreadyinfarm,$imported,$breedingid); |
523 |
return ($notmarcrecord,$alreadyindb,$alreadyinfarm,$imported,$breedingid); |
487 |
} |
524 |
} |
488 |
|
525 |
|
Lines 506-523
sub Z3950SearchAuth {
Link Here
|
506 |
my $random= $pars->{random}; |
543 |
my $random= $pars->{random}; |
507 |
my $page= $pars->{page}; |
544 |
my $page= $pars->{page}; |
508 |
|
545 |
|
509 |
my $nameany= $pars->{nameany}; |
546 |
|
510 |
my $authorany= $pars->{authorany}; |
|
|
511 |
my $authorpersonal= $pars->{authorpersonal}; |
512 |
my $authorcorp= $pars->{authorcorp}; |
513 |
my $authormeetingcon= $pars->{authormeetingcon}; |
514 |
my $title= $pars->{title}; |
515 |
my $uniformtitle= $pars->{uniformtitle}; |
516 |
my $subject= $pars->{subject}; |
517 |
my $subjectsubdiv= $pars->{subjectsubdiv}; |
518 |
my $srchany= $pars->{srchany}; |
519 |
my $authid= $pars->{authid}; |
520 |
|
521 |
my $show_next = 0; |
547 |
my $show_next = 0; |
522 |
my $total_pages = 0; |
548 |
my $total_pages = 0; |
523 |
my $attr = ''; |
549 |
my $attr = ''; |
Lines 531-631
sub Z3950SearchAuth {
Link Here
|
531 |
my $count; |
557 |
my $count; |
532 |
my $record; |
558 |
my $record; |
533 |
my @serverhost; |
559 |
my @serverhost; |
534 |
my @servername; |
|
|
535 |
my @breeding_loop = (); |
560 |
my @breeding_loop = (); |
536 |
|
561 |
|
537 |
my @oConnection; |
562 |
my @oConnection; |
538 |
my @oResult; |
563 |
my @oResult; |
539 |
my @errconn; |
564 |
my @errconn; |
|
|
565 |
my @servers; |
540 |
my $s = 0; |
566 |
my $s = 0; |
541 |
my $query; |
567 |
my $query; |
542 |
my $nterms=0; |
568 |
my $nterms=0; |
543 |
|
569 |
|
544 |
my $marcflavour = C4::Context->preference('marcflavour'); |
570 |
my $marcflavour = C4::Context->preference('marcflavour'); |
545 |
my $marc_type = $marcflavour eq 'UNIMARC' ? 'UNIMARCAUTH' : $marcflavour; |
571 |
my $marc_type = $marcflavour eq 'UNIMARC' ? 'UNIMARCAUTH' : $marcflavour; |
546 |
|
572 |
my $authid= $pars->{authid}; |
547 |
if ($nameany) { |
573 |
my ( $zquery, $squery ) = _auth_build_query( $pars ); |
548 |
$query .= " \@attr 1=1002 \"$nameany\" "; #Any name (this includes personal, corporate, meeting/conference authors, and author names in subject headings) |
|
|
549 |
#This attribute is supported by both the Library of Congress and Libraries Australia 08/05/2013 |
550 |
$nterms++; |
551 |
} |
552 |
|
553 |
if ($authorany) { |
554 |
$query .= " \@attr 1=1003 \"$authorany\" "; #Author-name (this includes personal, corporate, meeting/conference authors, but not author names in subject headings) |
555 |
#This attribute is not supported by the Library of Congress, but is supported by Libraries Australia 08/05/2013 |
556 |
$nterms++; |
557 |
} |
558 |
|
559 |
if ($authorcorp) { |
560 |
$query .= " \@attr 1=2 \"$authorcorp\" "; #1005 is another valid corporate author attribute... |
561 |
$nterms++; |
562 |
} |
563 |
|
564 |
if ($authorpersonal) { |
565 |
$query .= " \@attr 1=1 \"$authorpersonal\" "; #1004 is another valid personal name attribute... |
566 |
$nterms++; |
567 |
} |
568 |
|
569 |
if ($authormeetingcon) { |
570 |
$query .= " \@attr 1=3 \"$authormeetingcon\" "; #1006 is another valid meeting/conference name attribute... |
571 |
$nterms++; |
572 |
} |
573 |
|
574 |
if ($subject) { |
575 |
$query .= " \@attr 1=21 \"$subject\" "; |
576 |
$nterms++; |
577 |
} |
578 |
|
579 |
if ($subjectsubdiv) { |
580 |
$query .= " \@attr 1=47 \"$subjectsubdiv\" "; |
581 |
$nterms++; |
582 |
} |
583 |
|
584 |
if ($title) { |
585 |
$query .= " \@attr 1=4 \"$title\" "; #This is a regular title search. 1=6 will give just uniform titles |
586 |
$nterms++; |
587 |
} |
588 |
|
589 |
if ($uniformtitle) { |
590 |
$query .= " \@attr 1=6 \"$uniformtitle\" "; #This is the uniform title search |
591 |
$nterms++; |
592 |
} |
593 |
|
594 |
if($srchany) { |
595 |
$query .= " \@attr 1=1016 \"$srchany\" "; |
596 |
$nterms++; |
597 |
} |
598 |
|
599 |
for my $i (1..$nterms-1) { |
600 |
$query = "\@and " . $query; |
601 |
} |
602 |
|
603 |
foreach my $servid (@id) { |
574 |
foreach my $servid (@id) { |
604 |
my $sth = $dbh->prepare("select * from z3950servers where id=?"); |
575 |
my $sth = $dbh->prepare("select * from z3950servers where id=?"); |
605 |
$sth->execute($servid); |
576 |
$sth->execute($servid); |
606 |
while ( $server = $sth->fetchrow_hashref ) { |
577 |
while ( $server = $sth->fetchrow_hashref ) { |
607 |
my $option1 = new ZOOM::Options(); |
578 |
$oConnection[$s] = _create_connection( $server ); |
608 |
$option1->option( 'async' => 1 ); |
579 |
|
609 |
$option1->option( 'elementSetName', 'F' ); |
580 |
$oResult[$s] = |
610 |
$option1->option( 'databaseName', $server->{db} ); |
581 |
$server->{servertype} eq 'zed'? |
611 |
$option1->option( 'user', $server->{userid} ) if $server->{userid}; |
582 |
$oConnection[$s]->search_pqf( $zquery ): |
612 |
$option1->option( 'password', $server->{password} ) if $server->{password}; |
583 |
$oConnection[$s]->search(new ZOOM::Query::CQL( |
613 |
$option1->option( 'preferredRecordSyntax', $server->{syntax} ); |
584 |
_translate_query( $server, $squery ))); |
614 |
$option1->option( 'timeout', $server->{timeout} ) if $server->{timeout}; |
|
|
615 |
$oConnection[$s] = create ZOOM::Connection($option1); |
616 |
$oConnection[$s]->connect( $server->{host}, $server->{port} ); |
617 |
$serverhost[$s] = $server->{host}; |
618 |
$servername[$s] = $server->{servername}; |
619 |
$encoding[$s] = ($server->{encoding}?$server->{encoding}:"iso-5426"); |
585 |
$encoding[$s] = ($server->{encoding}?$server->{encoding}:"iso-5426"); |
|
|
586 |
$servers[$s] = $server; |
620 |
$s++; |
587 |
$s++; |
621 |
} ## while fetch |
588 |
} ## while fetch |
622 |
} # foreach |
589 |
} # foreach |
623 |
my $nremaining = $s; |
590 |
my $nremaining = $s; |
624 |
|
591 |
|
625 |
for ( my $z = 0 ; $z < $s ; $z++ ) { |
|
|
626 |
$oResult[$z] = $oConnection[$z]->search_pqf($query); |
627 |
} |
628 |
|
629 |
while ( $nremaining-- ) { |
592 |
while ( $nremaining-- ) { |
630 |
my $k; |
593 |
my $k; |
631 |
my $event; |
594 |
my $event; |
Lines 657-672
sub Z3950SearchAuth {
Link Here
|
657 |
$marcdata = $rec->raw(); |
620 |
$marcdata = $rec->raw(); |
658 |
|
621 |
|
659 |
my ($charset_result, $charset_errors); |
622 |
my ($charset_result, $charset_errors); |
|
|
623 |
if( $servers[$k]->{servertype} eq 'sru' ) { |
624 |
$marcdata = MARC::Record->new_from_xml( $marcdata, $encoding[$k], $servers[$k]->{syntax} ); |
625 |
} |
660 |
($marcrecord, $charset_result, $charset_errors)= MarcToUTF8Record($marcdata, $marc_type, $encoding[$k]); |
626 |
($marcrecord, $charset_result, $charset_errors)= MarcToUTF8Record($marcdata, $marc_type, $encoding[$k]); |
661 |
|
|
|
662 |
my $heading; |
627 |
my $heading; |
663 |
my $heading_authtype_code; |
628 |
my $heading_authtype_code; |
664 |
$heading_authtype_code = GuessAuthTypeCode($marcrecord); |
629 |
$heading_authtype_code = GuessAuthTypeCode($marcrecord); |
665 |
$heading = C4::AuthoritiesMarc::GetAuthorizedHeading({ record => $marcrecord }); |
630 |
$heading = C4::AuthoritiesMarc::GetAuthorizedHeading({ record => $marcrecord }); |
666 |
|
631 |
|
667 |
my ($notmarcrecord, $alreadyindb, $alreadyinfarm, $imported, $breedingid)= ImportBreedingAuth( $marcdata, 2, $serverhost[$k], $encoding[$k], $random, 'z3950' ); |
632 |
my ($notmarcrecord, $alreadyindb, $alreadyinfarm, $imported, $breedingid)= ImportBreedingAuth( $marcrecord, 2, $serverhost[$k], $encoding[$k], $random); |
668 |
my %row_data; |
633 |
my %row_data; |
669 |
$row_data{server} = $servername[$k]; |
634 |
$row_data{server} = $servers[$k]->{'servername'}; |
670 |
$row_data{breedingid} = $breedingid; |
635 |
$row_data{breedingid} = $breedingid; |
671 |
$row_data{heading} = $heading; |
636 |
$row_data{heading} = $heading; |
672 |
$row_data{authid} = $authid; |
637 |
$row_data{authid} = $authid; |
Lines 674-680
sub Z3950SearchAuth {
Link Here
|
674 |
push( @breeding_loop, \%row_data ); |
639 |
push( @breeding_loop, \%row_data ); |
675 |
} |
640 |
} |
676 |
else { |
641 |
else { |
677 |
push(@breeding_loop,{'server'=>$servername[$k],'title'=>join(': ',$oConnection[$k]->error_x()),'breedingid'=>-1,'authid'=>-1}); |
642 |
push(@breeding_loop,{'server'=>$servers[$k]->{'servername'},'title'=>join(': ',$oConnection[$k]->error_x()),'breedingid'=>-1,'authid'=>-1}); |
678 |
} |
643 |
} |
679 |
} |
644 |
} |
680 |
} #if $numresults |
645 |
} #if $numresults |
Lines 696-702
sub Z3950SearchAuth {
Link Here
|
696 |
$oConnection[$_]->destroy(); |
661 |
$oConnection[$_]->destroy(); |
697 |
} |
662 |
} |
698 |
|
663 |
|
699 |
my @servers = (); |
664 |
@servers = (); |
700 |
foreach my $id (@id) { |
665 |
foreach my $id (@id) { |
701 |
push @servers, {id => $id}; |
666 |
push @servers, {id => $id}; |
702 |
} |
667 |
} |