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