package C4::Breeding; # Copyright 2000-2002 Katipo Communications # Parts Copyright 2013 Prosentient Systems # # This file is part of Koha. # # Koha is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 3 of the License, or # (at your option) any later version. # # Koha is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with Koha; if not, see . use strict; use warnings; use C4::Biblio qw(TransformMarcToKoha); use C4::Koha qw( GetVariationsOfISBN ); use C4::Charset qw( MarcToUTF8Record SetUTF8Flag ); use MARC::File::USMARC; use MARC::Field; use C4::ImportBatch qw( GetZ3950BatchId AddBiblioToBatch AddAuthToBatch ); use C4::AuthoritiesMarc qw( GuessAuthTypeCode GetAuthorizedHeading ); use C4::Languages; use Koha::Database; use Koha::XSLT::Base; our (@ISA, @EXPORT_OK); BEGIN { require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(BreedingSearch ImportBreedingAuth Z3950Search Z3950SearchAuth); } =head1 NAME C4::Breeding : module to add biblios to import_records via the breeding/reservoir API. =head1 SYNOPSIS Z3950Search($pars, $template); ($count, @results) = &BreedingSearch($title,$isbn); =head1 DESCRIPTION This module contains routines related to Koha's Z39.50 search into cataloguing reservoir features. =head2 BreedingSearch ($count, @results) = &BreedingSearch($term); C<$term> contains the term to search, it will be searched as title,author, or isbn C<$count> is the number of items in C<@results>. C<@results> is an array of references-to-hash; the keys are the items from the C and C tables of the Koha database. =cut sub BreedingSearch { my ($term) = @_; my $dbh = C4::Context->dbh; my $count = 0; my ($query,@bind); my $sth; my @results; my $authortitle = $term; $authortitle =~ s/(\s+)/\%/g; #Replace spaces with wildcard $authortitle = "%" . $authortitle . "%"; #Add wildcard to start and end of string # normalise ISBN like at import my @isbns = C4::Koha::GetVariationsOfISBN($term); $query = "SELECT import_biblios.import_record_id, import_batches.file_name, import_biblios.isbn, import_biblios.title, import_biblios.author, import_batches.upload_timestamp FROM import_biblios JOIN import_records USING (import_record_id) JOIN import_batches USING (import_batch_id) WHERE title LIKE ? OR author LIKE ? OR isbn IN (" . join(',',('?') x @isbns) . ")"; @bind=( $authortitle, $authortitle, @isbns ); $sth = $dbh->prepare($query); $sth->execute(@bind); while (my $data = $sth->fetchrow_hashref) { $results[$count] = $data; # FIXME - hack to reflect difference in name # of columns in old marc_breeding and import_records # There needs to be more separation between column names and # field names used in the templates $data->{'file'} = $data->{'file_name'}; $data->{'id'} = $data->{'import_record_id'}; $count++; } # while $sth->finish; return($count, @results); } # sub breedingsearch =head2 Z3950Search Z3950Search($pars, $template); Parameters for Z3950 search are all passed via the $pars hash. It may contain isbn, title, author, dewey, subject, lccall, controlnumber, stdid, srchany. Also it should contain an arrayref id that points to a list of id's of the z3950 targets to be queried (see z3950servers table). This code is used in acqui/z3950_search and cataloging/z3950_search. The second parameter $template is a Template object. The routine uses this parameter to store the found values into the template. =cut sub Z3950Search { my ($pars, $template)= @_; my @id= @{$pars->{id}}; my $page= $pars->{page}; my $biblionumber= $pars->{biblionumber}; my $show_next = 0; my $total_pages = 0; my @results; my @breeding_loop = (); my @oConnection; my @oResult; my @errconn; my $s = 0; my $imported=0; my ( $zquery, $squery ) = _bib_build_query( $pars ); my $schema = Koha::Database->new()->schema(); my $rs = $schema->resultset('Z3950server')->search( { id => [ @id ] }, { result_class => 'DBIx::Class::ResultClass::HashRefInflator' }, ); my @servers = $rs->all; foreach my $server ( @servers ) { my $server_zquery = $zquery; if(my $attributes = $server->{attributes}){ $server_zquery = "$attributes $zquery"; } $oConnection[$s] = _create_connection( $server ); $oResult[$s] = $server->{servertype} eq 'zed'? $oConnection[$s]->search_pqf( $server_zquery ): $oConnection[$s]->search(ZOOM::Query::CQL->new( _translate_query( $server, $squery ))); $s++; } my $xslh = Koha::XSLT::Base->new; my $nremaining = $s; while ( $nremaining-- ) { my $k; my $event; while ( ( $k = ZOOM::event( \@oConnection ) ) != 0 ) { $event = $oConnection[ $k - 1 ]->last_event(); last if $event == ZOOM::Event::ZEND; } if ( $k != 0 ) { $k--; my ($error)= $oConnection[$k]->error_x(); #ignores errmsg, addinfo, diagset if ($error) { if ($error =~ m/^(10000|10007)$/ ) { push(@errconn, { server => $servers[$k]->{host}, error => $error } ); } } else { my $numresults = $oResult[$k]->size(); my $i; my $res; if ( $numresults > 0 and $numresults >= (($page-1)*20)) { $show_next = 1 if $numresults >= ($page*20); $total_pages = int($numresults/20)+1 if $total_pages < ($numresults/20); for ($i = ($page-1)*20; $i < (($numresults < ($page*20)) ? $numresults : ($page*20)); $i++) { if ( $oResult[$k]->record($i) ) { undef $error; ( $res, $error ) = _handle_one_result( $oResult[$k]->record($i), $servers[$k], ++$imported, $biblionumber, $xslh ); #ignores error in sequence numbering push @breeding_loop, $res if $res; push @errconn, { server => $servers[$k]->{servername}, error => $error, seq => $i+1 } if $error; } else { push @errconn, { 'server' => $servers[$k]->{servername}, error => ( ( $oConnection[$k]->error_x() )[0] ), seq => $i+1 }; } } } #if $numresults } } # if $k !=0 $template->param( numberpending => $nremaining, current_page => $page, total_pages => $total_pages, show_nextbutton => $show_next?1:0, show_prevbutton => $page!=1, ); } # while nremaining #close result sets and connections foreach(0..$s-1) { $oResult[$_]->destroy(); $oConnection[$_]->destroy(); } $template->param( breeding_loop => \@breeding_loop, servers => \@servers, errconn => \@errconn ); } sub _auth_build_query { my ( $pars ) = @_; my $qry_build = { nameany => '@attr 1=1002 "#term" ', authorany => '@attr 1=1003 "#term" ', authorcorp => '@attr 1=2 "#term" ', authorpersonal => '@attr 1=1 "#term" ', authormeetingcon => '@attr 1=3 "#term" ', subject => '@attr 1=21 "#term" ', subjectsubdiv => '@attr 1=47 "#term" ', title => '@attr 1=4 "#term" ', uniformtitle => '@attr 1=6 "#term" ', srchany => '@attr 1=1016 "#term" ', controlnumber => '@attr 1=12 "#term" ', }; return _build_query( $pars, $qry_build ); } sub _bib_build_query { my ( $pars ) = @_; my $qry_build = { isbn => '@attr 1=7 @attr 5=1 "#term" ', issn => '@attr 1=8 @attr 5=1 "#term" ', title => '@attr 1=4 "#term" ', author => '@attr 1=1003 "#term" ', dewey => '@attr 1=16 "#term" ', subject => '@attr 1=21 "#term" ', lccall => '@attr 1=16 @attr 2=3 @attr 3=1 @attr 4=1 @attr 5=1 '. '@attr 6=1 "#term" ', controlnumber => '@attr 1=12 "#term" ', srchany => '@attr 1=1016 "#term" ', stdid => '@attr 1=1007 "#term" ', publicationyear => '@attr 1=31 "#term" ' }; return _build_query( $pars, $qry_build ); } sub _build_query { my ( $pars, $qry_build ) = @_; my $zquery=''; my $squery=''; my $nterms=0; foreach my $k ( sort keys %$pars ) { #note that the sort keys forces an identical result under Perl 5.18 #one of the unit tests is based on that assumption if( ( my $val=$pars->{$k} ) && $qry_build->{$k} ) { $qry_build->{$k} =~ s/#term/$val/g; $zquery .= $qry_build->{$k}; $squery .= "[$k]=\"$val\" and "; $nterms++; } } $zquery = "\@and " . $zquery for 2..$nterms; $squery =~ s/ and $//; return ( $zquery, $squery ); } sub _handle_one_result { my ( $zoomrec, $servhref, $seq, $bib, $xslh )= @_; my $raw= $zoomrec->raw(); my $marcrecord; if( $servhref->{servertype} eq 'sru' ) { $marcrecord= MARC::Record->new_from_xml( $raw, 'UTF-8', $servhref->{syntax} ); $marcrecord->encoding('UTF-8'); } else { ($marcrecord) = MarcToUTF8Record($raw, C4::Context->preference('marcflavour'), $servhref->{encoding} // "iso-5426" ); #ignores charset return values } SetUTF8Flag($marcrecord); my $error; ( $marcrecord, $error ) = _do_xslt_proc($marcrecord, $servhref, $xslh); my $batch_id = GetZ3950BatchId($servhref->{servername}); my $breedingid = AddBiblioToBatch($batch_id, $seq, $marcrecord, 'UTF-8', 0); #Last zero indicates: no update for batch record counts my $row; if( $breedingid ){ my @kohafields = ('biblio.title','biblio.author','biblioitems.isbn','biblioitems.lccn','biblioitems.editionstatement'); push @kohafields, C4::Context->preference('marcflavour') eq "MARC21" ? 'biblio.copyrightdate' : 'biblioitems.publicationyear'; $row = C4::Biblio::TransformMarcToKoha({ record => $marcrecord, kohafields => \@kohafields, limit_table => 'no_items' }); $row->{date} = $row->{copyrightdate} // $row->{publicationyear}; $row->{biblionumber} = $bib; $row->{server} = $servhref->{servername}; $row->{breedingid} = $breedingid; $row->{isbn}=_isbn_replace($row->{isbn}); my $pref_newtags = C4::Context->preference('AdditionalFieldsInZ3950ResultSearch'); $row = _add_custom_field_rowdata( $row, $marcrecord, $pref_newtags ); } return ( $row, $error ); } sub _do_xslt_proc { my ( $marc, $server, $xslh ) = @_; return $marc if !$server->{add_xslt}; my $htdocs = C4::Context->config('intrahtdocs'); my $theme = C4::Context->preference("template"); #staff my $lang = C4::Languages::getlanguage() || 'en'; my @files= split ',', $server->{add_xslt}; my $xml = $marc->as_xml; foreach my $f ( @files ) { $f =~ s/^\s+//; $f =~ s/\s+$//; next if !$f; $f = C4::XSLT::_get_best_default_xslt_filename( $htdocs, $theme, $lang, $f ) unless $f =~ /^\//; $xml = $xslh->transform( $xml, $f ); last if $xslh->err; #skip other files } if( !$xslh->err ) { return MARC::Record->new_from_xml($xml, 'UTF-8'); } else { return ( $marc, $xslh->err ); #original record in case of errors } } sub _add_custom_field_rowdata { my ( $row, $record, $pref_newtags ) = @_; $pref_newtags //= ''; my $pref_flavour = C4::Context->preference('MarcFlavour'); $pref_newtags =~ s/^\s+|\s+$//g; $pref_newtags =~ s/\h+/ /g; my @addnumberfields; foreach my $field (split /\,/, $pref_newtags) { $field =~ s/^\s+|\s+$//g ; # trim whitespace my ($tag, $subtags) = split(/\$/, $field); if ( $record->field($tag) ) { my @content = (); for my $marcfield ($record->field($tag)) { if ( $subtags ) { my $str = ''; for my $code (split //, $subtags) { if ( $marcfield->subfield($code) ) { $str .= $marcfield->subfield($code) . ' '; } } if ( not $str eq '') { push @content, $str; } } elsif ( $tag == 10 ) { push @content, ( $pref_flavour eq "MARC21" ? $marcfield->data : $marcfield->as_string ); } elsif ( $tag < 10 ) { push @content, $marcfield->data(); } else { push @content, $marcfield->as_string(); } } if ( @content ) { $row->{$field} = \@content; push( @addnumberfields, $field ); } } } $row->{'addnumberfields'} = \@addnumberfields; return $row; } sub _isbn_replace { my ($isbn) = @_; return unless defined $isbn; $isbn =~ s/ |-|\.//g; $isbn =~ s/\|/ \| /g; $isbn =~ s/\(/ \(/g; return $isbn; } sub _create_connection { my ( $server ) = @_; my $option1= ZOOM::Options->new(); $option1->option( 'async' => 1 ); $option1->option( 'elementSetName', 'F' ); $option1->option( 'preferredRecordSyntax', $server->{syntax} ); $option1->option( 'timeout', $server->{timeout} ) if $server->{timeout}; if( $server->{servertype} eq 'sru' ) { foreach( split ',', $server->{sru_options}//'' ) { #first remove surrounding spaces at comma and equals-sign s/^\s+|\s+$//g; my @temp= split '=', $_, 2; @temp= map { my $c=$_; $c=~s/^\s+|\s+$//g; $c; } @temp; $option1->option( $temp[0] => $temp[1] ) if @temp; } } elsif( $server->{servertype} eq 'zed' ) { $option1->option( 'databaseName', $server->{db} ); $option1->option( 'user', $server->{userid} ) if $server->{userid}; $option1->option( 'password', $server->{password} ) if $server->{password}; } my $obj= ZOOM::Connection->create($option1); if( $server->{servertype} eq 'sru' ) { my $host= $server->{host}; if( $host !~ /^https?:\/\// ) { #Normally, host will not be prefixed by protocol. #In that case we can (safely) assume http. #In case someone prefixed with https, give it a try.. $host = 'http://' . $host; } $obj->connect( $host.':'.$server->{port}.'/'.$server->{db} ); } else { $obj->connect( $server->{host}, $server->{port} ); } return $obj; } sub _translate_query { #SRU query adjusted per server cf. srufields column my ($server, $query) = @_; #sru_fields is in format title=field,isbn=field,... #if a field doesn't exist, try anywhere or remove [field]= my @parts= split(',', $server->{sru_fields} ); my %trans= map { if( /=/ ) { ( $`,$' ) } else { () } } @parts; my $any= $trans{srchany}?$trans{srchany}.'=':''; my $q=$query; foreach my $key (keys %trans) { my $f=$trans{$key}; if( $f ) { $q=~s/\[$key\]/$f/g; } else { $q=~s/\[$key\]=/$any/g; } } $q=~s/\[\w+\]=/$any/g; # remove remaining fields (not found in field list) return $q; } =head2 ImportBreedingAuth ImportBreedingAuth( $marcrecord, $filename, $encoding, $heading ); ImportBreedingAuth imports MARC records in the reservoir (import_records table) or returns their id if they already exist. =cut sub ImportBreedingAuth { my ( $marcrecord, $filename, $encoding, $heading ) = @_; my $dbh = C4::Context->dbh; my $batch_id = GetZ3950BatchId($filename); my $searchbreeding = $dbh->prepare("select import_record_id from import_auths where control_number=? and authorized_heading=?"); my $controlnumber = $marcrecord->field('001')->data; $searchbreeding->execute($controlnumber,$heading); my ($breedingid) = $searchbreeding->fetchrow; return $breedingid if $breedingid; $breedingid = AddAuthToBatch($batch_id, 0, $marcrecord, $encoding); return $breedingid; } =head2 Z3950SearchAuth Z3950SearchAuth($pars, $template); Parameters for Z3950 search are all passed via the $pars hash. It may contain nameany, namepersonal, namecorp, namemeetingcon, title, uniform title, subject, subjectsubdiv, srchany. Also it should contain an arrayref id that points to a list of IDs of the z3950 targets to be queried (see z3950servers table). This code is used in cataloging/z3950_auth_search. The second parameter $template is a Template object. The routine uses this parameter to store the found values into the template. =cut sub Z3950SearchAuth { my ($pars, $template)= @_; my $dbh = C4::Context->dbh; my @id= @{$pars->{id}}; my $page= $pars->{page} // 1; my $show_next = 0; my $total_pages = 0; my @encoding; my @results; my @breeding_loop = (); my @oConnection; my @oResult; my @errconn; my @servers; my $s = 0; my $query; my $nterms=0; my $marcflavour = C4::Context->preference('marcflavour'); my $marc_type = $marcflavour eq 'UNIMARC' ? 'UNIMARCAUTH' : $marcflavour; my $authid= $pars->{authid}; my ( $zquery, $squery ) = _auth_build_query( $pars ); foreach my $servid (@id) { my $sth = $dbh->prepare("select * from z3950servers where id=?"); $sth->execute($servid); while ( my $server = $sth->fetchrow_hashref ) { $oConnection[$s] = _create_connection( $server ); if ( $server->{servertype} eq 'zed' ) { my $server_zquery = $zquery; if ( my $attributes = $server->{attributes} ) { $server_zquery = "$attributes $zquery"; } $oResult[$s] = $oConnection[$s]->search_pqf( $server_zquery ); } else { $oResult[$s] = $oConnection[$s]->search( ZOOM::Query::CQL->new(_translate_query( $server, $squery )) ); } $encoding[$s] = ($server->{encoding}?$server->{encoding}:"iso-5426"); $servers[$s] = $server; $s++; } ## while fetch } # foreach my $nremaining = $s; while ( $nremaining-- ) { my $k; my $event; while ( ( $k = ZOOM::event( \@oConnection ) ) != 0 ) { $event = $oConnection[ $k - 1 ]->last_event(); last if $event == ZOOM::Event::ZEND; } if ( $k != 0 ) { $k--; my ($error )= $oConnection[$k]->error_x(); #ignores errmsg, addinfo, diagset if ($error) { if ($error =~ m/^(10000|10007)$/ ) { push @errconn, { server => $servers[$k]->{host} }; } } else { my $numresults = $oResult[$k]->size(); my $i; my $result = ''; if ( $numresults > 0 and $numresults >= (($page-1)*20)) { $show_next = 1 if $numresults >= ($page*20); $total_pages = int($numresults/20)+1 if $total_pages < ($numresults/20); for ($i = ($page-1)*20; $i < (($numresults < ($page*20)) ? $numresults : ($page*20)); $i++) { my $rec = $oResult[$k]->record($i); if ($rec) { my $marcdata = $rec->raw(); my $marcrecord; if( $servers[$k]->{servertype} eq 'sru' ) { $marcrecord = eval { MARC::Record->new_from_xml( $marcdata, 'UTF-8', $servers[$k]->{syntax} ) }; if( !$marcrecord || $@ ) { _dump_conversion_error( $servers[$k]->{servername}, $marcdata, $@ ); next; # skip this one } } else { my ($charset_result, $charset_errors); ( $marcrecord, $charset_result, $charset_errors ) = MarcToUTF8Record( $marcdata, $marc_type, $encoding[$k] ); if( !$marcrecord || @$charset_errors ) { _dump_conversion_error( $servers[$k]->{servername}, $marcdata, $charset_result, $charset_errors ); next; # skip this one } } $marcrecord->encoding('UTF-8'); SetUTF8Flag($marcrecord); my $heading_authtype_code = GuessAuthTypeCode($marcrecord) or next; my $heading = GetAuthorizedHeading({ record => $marcrecord }); my $breedingid = ImportBreedingAuth( $marcrecord, $servers[$k]->{host}, 'UTF-8', $heading ); my %row_data; $row_data{server} = $servers[$k]->{'servername'}; $row_data{breedingid} = $breedingid; $row_data{heading} = $heading; $row_data{authid} = $authid; $row_data{heading_code} = $heading_authtype_code; $row_data{row} = _add_custom_field_rowdata( { %row_data }, $marcrecord, C4::Context->preference('AdditionalFieldsInZ3950ResultAuthSearch') ) if C4::Context->preference('AdditionalFieldsInZ3950ResultAuthSearch'); push( @breeding_loop, \%row_data ); } else { push(@breeding_loop,{'server'=>$servers[$k]->{'servername'},'title'=>join(': ',$oConnection[$k]->error_x()),'breedingid'=>-1,'authid'=>-1}); } } } #if $numresults } } # if $k !=0 $template->param( numberpending => $nremaining, current_page => $page, total_pages => $total_pages, show_nextbutton => $show_next?1:0, show_prevbutton => $page!=1, ); } # while nremaining #close result sets and connections foreach(0..$s-1) { $oResult[$_]->destroy(); $oConnection[$_]->destroy(); } @servers = (); foreach my $id (@id) { push @servers, {id => $id}; } $template->param( breeding_loop => \@breeding_loop, servers => \@servers, errconn => \@errconn ); } sub _dump_conversion_error { require Data::Dumper; warn Data::Dumper->new([ 'Z3950SearchAuth conversion error', @_ ])->Indent(0)->Dump; } 1; __END__