Lines 1-6
Link Here
|
1 |
package C4::Breeding; |
1 |
package C4::Breeding; |
2 |
|
2 |
|
3 |
# Copyright 2000-2002 Katipo Communications |
3 |
# Copyright 2000-2002 Katipo Communications |
|
|
4 |
# Parts Copyright 2013 Prosentient Systems |
4 |
# |
5 |
# |
5 |
# This file is part of Koha. |
6 |
# This file is part of Koha. |
6 |
# |
7 |
# |
Lines 25-30
use C4::Koha;
Link Here
|
25 |
use C4::Charset; |
26 |
use C4::Charset; |
26 |
use MARC::File::USMARC; |
27 |
use MARC::File::USMARC; |
27 |
use C4::ImportBatch; |
28 |
use C4::ImportBatch; |
|
|
29 |
use C4::AuthoritiesMarc; #GuessAuthTypeCode, FindDuplicateAuthority |
28 |
|
30 |
|
29 |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
31 |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
30 |
|
32 |
|
Lines 33-39
BEGIN {
Link Here
|
33 |
$VERSION = 3.07.00.049; |
35 |
$VERSION = 3.07.00.049; |
34 |
require Exporter; |
36 |
require Exporter; |
35 |
@ISA = qw(Exporter); |
37 |
@ISA = qw(Exporter); |
36 |
@EXPORT = qw(&ImportBreeding &BreedingSearch &Z3950Search); |
38 |
@EXPORT = qw(&ImportBreeding &BreedingSearch &Z3950Search &Z3950SearchAuth); |
37 |
} |
39 |
} |
38 |
|
40 |
|
39 |
=head1 NAME |
41 |
=head1 NAME |
Lines 436-441
sub Z3950Search {
Link Here
|
436 |
); |
438 |
); |
437 |
} |
439 |
} |
438 |
|
440 |
|
|
|
441 |
=head2 ImportBreedingAuth |
442 |
|
443 |
ImportBreedingAuth($marcrecords,$overwrite_auth,$filename,$encoding,$z3950random,$batch_type); |
444 |
|
445 |
TODO description |
446 |
|
447 |
=cut |
448 |
|
449 |
sub ImportBreedingAuth { |
450 |
my ($marcrecords,$overwrite_auth,$filename,$encoding,$z3950random,$batch_type) = @_; |
451 |
my @marcarray = split /\x1D/, $marcrecords; |
452 |
|
453 |
my $dbh = C4::Context->dbh; |
454 |
|
455 |
my $batch_id = GetZ3950BatchId($filename); |
456 |
my $searchbreeding = $dbh->prepare("select import_record_id from import_auths where control_number=? and authorized_heading=?"); |
457 |
|
458 |
# $encoding = C4::Context->preference("marcflavour") unless $encoding; |
459 |
# fields used for import results |
460 |
my $imported=0; |
461 |
my $alreadyindb = 0; |
462 |
my $alreadyinfarm = 0; |
463 |
my $notmarcrecord = 0; |
464 |
my $breedingid; |
465 |
for (my $i=0;$i<=$#marcarray;$i++) { |
466 |
my ($marcrecord, $charset_result, $charset_errors); |
467 |
($marcrecord, $charset_result, $charset_errors) = |
468 |
MarcToUTF8Record($marcarray[$i]."\x1D", C4::Context->preference("marcflavour"), $encoding); |
469 |
|
470 |
# Normalize the record so it doesn't have separated diacritics |
471 |
SetUTF8Flag($marcrecord); |
472 |
|
473 |
# warn "$i : $marcarray[$i]"; |
474 |
# FIXME - currently this does nothing |
475 |
my @warnings = $marcrecord->warnings(); |
476 |
|
477 |
if (scalar($marcrecord->fields()) == 0) { |
478 |
$notmarcrecord++; |
479 |
} else { |
480 |
my $heading; |
481 |
$heading = C4::AuthoritiesMarc::GetAuthorizedHeading({ record => $marcrecord }); |
482 |
|
483 |
my $heading_authtype_code; |
484 |
$heading_authtype_code = GuessAuthTypeCode($marcrecord); |
485 |
|
486 |
my $controlnumber; |
487 |
$controlnumber = $marcrecord->field('001')->data; |
488 |
|
489 |
#Check if the authority record already exists in the database... |
490 |
my ($duplicateauthid,$duplicateauthvalue); |
491 |
if ($marcrecord && $heading_authtype_code) { |
492 |
($duplicateauthid,$duplicateauthvalue) = FindDuplicateAuthority( $marcrecord, $heading_authtype_code); |
493 |
} |
494 |
|
495 |
if ($duplicateauthid && $overwrite_auth ne 2) { |
496 |
#If the authority record exists and $overwrite_auth doesn't equal 2, then mark it as already in the DB |
497 |
#FIXME: What does $overwrite_auth = 2 even mean? |
498 |
|
499 |
#FIXME: Should we bother with $overwrite_auth values? Currently, the hard-coded $overwrite_auth value is 2, which means the database gets filled with import_records... |
500 |
#^^ of course, we might not want to reject records if their control number/heading exist in the db or breeding/import pool...as we might be wanting to update existing authority records... |
501 |
$alreadyindb++; |
502 |
} else { |
503 |
if ($controlnumber && $heading) { |
504 |
$searchbreeding->execute($controlnumber,$heading); |
505 |
($breedingid) = $searchbreeding->fetchrow; |
506 |
} |
507 |
if ($breedingid && $overwrite_auth eq '0') { |
508 |
#FIXME: What does $overwrite_auth = 0 even mean? |
509 |
$alreadyinfarm++; |
510 |
} else { |
511 |
if ($breedingid && $overwrite_auth eq '1') { |
512 |
#FIXME: What does $overwrite_auth = 1 even mean? |
513 |
ModAuthorityInBatch($breedingid, $marcrecord); |
514 |
} else { |
515 |
my $import_id = AddAuthToBatch($batch_id, $imported, $marcrecord, $encoding, $z3950random); |
516 |
$breedingid = $import_id; |
517 |
} |
518 |
$imported++; |
519 |
} |
520 |
} |
521 |
} |
522 |
} |
523 |
return ($notmarcrecord,$alreadyindb,$alreadyinfarm,$imported,$breedingid); |
524 |
} |
525 |
|
526 |
=head2 Z3950SearchAuth |
527 |
|
528 |
Z3950SearchAuth($pars, $template); |
529 |
|
530 |
Parameters for Z3950 search are all passed via the $pars hash. It may contain nameany, namepersonal, namecorp, namemeetingcon, |
531 |
title, uniform title, subject, subjectsubdiv, srchany. |
532 |
Also it should contain an arrayref id that points to a list of IDs of the z3950 targets to be queried (see z3950servers table). |
533 |
This code is used in cataloging/z3950_auth_search. |
534 |
The second parameter $template is a Template object. The routine uses this parameter to store the found values into the template. |
535 |
|
536 |
=cut |
537 |
|
538 |
sub Z3950SearchAuth { |
539 |
my ($pars, $template)= @_; |
540 |
|
541 |
my $dbh = C4::Context->dbh; |
542 |
my @id= @{$pars->{id}}; |
543 |
my $random= $pars->{random}; |
544 |
my $page= $pars->{page}; |
545 |
|
546 |
my $nameany= $pars->{nameany}; |
547 |
my $authorany= $pars->{authorany}; |
548 |
my $authorpersonal= $pars->{authorpersonal}; |
549 |
my $authorcorp= $pars->{authorcorp}; |
550 |
my $authormeetingcon= $pars->{authormeetingcon}; |
551 |
my $title= $pars->{title}; |
552 |
my $uniformtitle= $pars->{uniformtitle}; |
553 |
my $subject= $pars->{subject}; |
554 |
my $subjectsubdiv= $pars->{subjectsubdiv}; |
555 |
my $srchany= $pars->{srchany}; |
556 |
|
557 |
my $show_next = 0; |
558 |
my $total_pages = 0; |
559 |
my $attr = ''; |
560 |
my $host; |
561 |
my $server; |
562 |
my $database; |
563 |
my $port; |
564 |
my $marcdata; |
565 |
my @encoding; |
566 |
my @results; |
567 |
my $count; |
568 |
my $record; |
569 |
my @serverhost; |
570 |
my @servername; |
571 |
my @breeding_loop = (); |
572 |
|
573 |
my @oConnection; |
574 |
my @oResult; |
575 |
my @errconn; |
576 |
my $s = 0; |
577 |
my $query; |
578 |
my $nterms=0; |
579 |
|
580 |
if ($nameany) { |
581 |
$query .= " \@attr 1=1002 \"$nameany\" "; #Any name (this includes personal, corporate, meeting/conference authors, and author names in subject headings) |
582 |
#This attribute is supported by both the Library of Congress and Libraries Australia 08/05/2013 |
583 |
$nterms++; |
584 |
} |
585 |
|
586 |
if ($authorany) { |
587 |
$query .= " \@attr 1=1003 \"$authorany\" "; #Author-name (this includes personal, corporate, meeting/conference authors, but not author names in subject headings) |
588 |
#This attribute is not supported by the Library of Congress, but is supported by Libraries Australia 08/05/2013 |
589 |
$nterms++; |
590 |
} |
591 |
|
592 |
if ($authorcorp) { |
593 |
$query .= " \@attr 1=2 \"$authorcorp\" "; #1005 is another valid corporate author attribute... |
594 |
$nterms++; |
595 |
} |
596 |
|
597 |
if ($authorpersonal) { |
598 |
$query .= " \@attr 1=1 \"$authorpersonal\" "; #1004 is another valid personal name attribute... |
599 |
$nterms++; |
600 |
} |
601 |
|
602 |
if ($authormeetingcon) { |
603 |
$query .= " \@attr 1=3 \"$authormeetingcon\" "; #1006 is another valid meeting/conference name attribute... |
604 |
$nterms++; |
605 |
} |
606 |
|
607 |
if ($subject) { |
608 |
$query .= " \@attr 1=21 \"$subject\" "; |
609 |
$nterms++; |
610 |
} |
611 |
|
612 |
if ($subjectsubdiv) { |
613 |
$query .= " \@attr 1=47 \"$subjectsubdiv\" "; |
614 |
$nterms++; |
615 |
} |
616 |
|
617 |
if ($title) { |
618 |
$query .= " \@attr 1=4 \"$title\" "; #This is a regular title search. 1=6 will give just uniform titles |
619 |
$nterms++; |
620 |
} |
621 |
|
622 |
if ($uniformtitle) { |
623 |
$query .= " \@attr 1=6 \"$uniformtitle\" "; #This is the uniform title search |
624 |
$nterms++; |
625 |
} |
626 |
|
627 |
if($srchany) { |
628 |
$query .= " \@attr 1=1016 \"$srchany\" "; |
629 |
$nterms++; |
630 |
} |
631 |
|
632 |
for my $i (1..$nterms-1) { |
633 |
$query = "\@and " . $query; |
634 |
} |
635 |
|
636 |
foreach my $servid (@id) { |
637 |
my $sth = $dbh->prepare("select * from z3950servers where id=?"); |
638 |
$sth->execute($servid); |
639 |
while ( $server = $sth->fetchrow_hashref ) { |
640 |
my $option1 = new ZOOM::Options(); |
641 |
$option1->option( 'async' => 1 ); |
642 |
$option1->option( 'elementSetName', 'F' ); |
643 |
$option1->option( 'databaseName', $server->{db} ); |
644 |
$option1->option( 'user', $server->{userid} ) if $server->{userid}; |
645 |
$option1->option( 'password', $server->{password} ) if $server->{password}; |
646 |
$option1->option( 'preferredRecordSyntax', $server->{syntax} ); |
647 |
$option1->option( 'timeout', $server->{timeout} ) if $server->{timeout}; |
648 |
$oConnection[$s] = create ZOOM::Connection($option1); |
649 |
$oConnection[$s]->connect( $server->{host}, $server->{port} ); |
650 |
$serverhost[$s] = $server->{host}; |
651 |
$servername[$s] = $server->{name}; |
652 |
$encoding[$s] = ($server->{encoding}?$server->{encoding}:"iso-5426"); |
653 |
$s++; |
654 |
} ## while fetch |
655 |
} # foreach |
656 |
my $nremaining = $s; |
657 |
|
658 |
for ( my $z = 0 ; $z < $s ; $z++ ) { |
659 |
$oResult[$z] = $oConnection[$z]->search_pqf($query); |
660 |
} |
661 |
|
662 |
while ( $nremaining-- ) { |
663 |
my $k; |
664 |
my $event; |
665 |
while ( ( $k = ZOOM::event( \@oConnection ) ) != 0 ) { |
666 |
$event = $oConnection[ $k - 1 ]->last_event(); |
667 |
last if $event == ZOOM::Event::ZEND; |
668 |
} |
669 |
|
670 |
if ( $k != 0 ) { |
671 |
$k--; |
672 |
my ($error, $errmsg, $addinfo, $diagset)= $oConnection[$k]->error_x(); |
673 |
if ($error) { |
674 |
if ($error =~ m/^(10000|10007)$/ ) { |
675 |
push(@errconn, {'server' => $serverhost[$k]}); |
676 |
} |
677 |
} |
678 |
else { |
679 |
my $numresults = $oResult[$k]->size(); |
680 |
my $i; |
681 |
my $result = ''; |
682 |
if ( $numresults > 0 and $numresults >= (($page-1)*20)) { |
683 |
$show_next = 1 if $numresults >= ($page*20); |
684 |
$total_pages = int($numresults/20)+1 if $total_pages < ($numresults/20); |
685 |
for ($i = ($page-1)*20; $i < (($numresults < ($page*20)) ? $numresults : ($page*20)); $i++) { |
686 |
my $rec = $oResult[$k]->record($i); |
687 |
if ($rec) { |
688 |
my $marcrecord; |
689 |
my $marcdata; |
690 |
$marcdata = $rec->raw(); |
691 |
|
692 |
my ($charset_result, $charset_errors); |
693 |
($marcrecord, $charset_result, $charset_errors)= MarcToUTF8Record($marcdata, C4::Context->preference('marcflavour'), $encoding[$k]); |
694 |
|
695 |
my $heading; |
696 |
my $heading_authtype_code; |
697 |
$heading_authtype_code = GuessAuthTypeCode($marcrecord); |
698 |
$heading = C4::AuthoritiesMarc::GetAuthorizedHeading({ record => $marcrecord }); |
699 |
|
700 |
my ($notmarcrecord, $alreadyindb, $alreadyinfarm, $imported, $breedingid)= ImportBreedingAuth( $marcdata, 2, $serverhost[$k], $encoding[$k], $random, 'z3950' ); |
701 |
my %row_data; |
702 |
$row_data{server} = $servername[$k]; |
703 |
$row_data{breedingid} = $breedingid; |
704 |
$row_data{heading} = $heading; |
705 |
$row_data{heading_code} = $heading_authtype_code; |
706 |
push( @breeding_loop, \%row_data ); |
707 |
} |
708 |
else { |
709 |
push(@breeding_loop,{'server'=>$servername[$k],'title'=>join(': ',$oConnection[$k]->error_x()),'breedingid'=>-1}); |
710 |
} |
711 |
} |
712 |
} #if $numresults |
713 |
} |
714 |
} # if $k !=0 |
715 |
|
716 |
$template->param( |
717 |
numberpending => $nremaining, |
718 |
current_page => $page, |
719 |
total_pages => $total_pages, |
720 |
show_nextbutton => $show_next?1:0, |
721 |
show_prevbutton => $page!=1, |
722 |
); |
723 |
} # while nremaining |
724 |
|
725 |
#close result sets and connections |
726 |
foreach(0..$s-1) { |
727 |
$oResult[$_]->destroy(); |
728 |
$oConnection[$_]->destroy(); |
729 |
} |
730 |
|
731 |
my @servers = (); |
732 |
foreach my $id (@id) { |
733 |
push @servers, {id => $id}; |
734 |
} |
735 |
$template->param( |
736 |
breeding_loop => \@breeding_loop, |
737 |
servers => \@servers, |
738 |
errconn => \@errconn |
739 |
); |
740 |
} |
741 |
|
439 |
1; |
742 |
1; |
440 |
__END__ |
743 |
__END__ |
441 |
|
744 |
|