Browse Source

Finalizing main components. All koha modules are now working with the new XML API

3.0.x
tgarip1957 18 years ago
parent
commit
9b266b13ee
  1. 169
      C4/Accounts2.pm
  2. 28
      C4/AuthoritiesMarc.pm
  3. 13
      C4/Biblio.pm
  4. 6
      C4/Circulation/Circ2.pm
  5. 14
      C4/Circulation/Fines.pm
  6. 15
      C4/Context.pm
  7. 76
      C4/Koha.pm
  8. 225
      C4/Search.pm

169
C4/Accounts2.pm

@ -142,16 +142,11 @@ sub recordpayment{
$newamtos = $accdata->{'amountoutstanding'} - $amountleft;
$amountleft = 0;
}
my $thisacct = $accdata->{accountno};
my $thisacct = $accdata->{accountid};
my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
where (borrowernumber = ?) and (accountno=?)");
$usth->execute($newamtos,$bornumber,$thisacct);
where accountid=?");
$usth->execute($newamtos,$thisacct);
$usth->finish;
# $usth = $dbh->prepare("insert into accountoffsets
# (borrowernumber, accountno, offsetaccount, offsetamount)
# values (?,?,?,?)");
# $usth->execute($bornumber,$accdata->{'accountno'},$nextaccntno,$newamtos);
# $usth->finish;
}
# create new line
my $usth = $dbh->prepare("insert into accountlines
@ -167,13 +162,12 @@ sub recordpayment{
&makepayment($borrowernumber, $acctnumber, $amount, $branchcode);
Records the fact that a patron has paid off the entire amount he or
Records the fact that a patron has paid off the an amount he or
she owes.
C<$borrowernumber> is the patron's borrower number. C<$acctnumber> is
the account that was credited. C<$amount> is the amount paid (this is
only used to record the payment. It is assumed to be equal to the
amount owed). C<$branchcode> is the code of the branch where payment
only used to record the payment. C<$branchcode> is the code of the branch where payment
was made.
=cut
@ -212,13 +206,7 @@ if ($type eq "Pay"){
AND accountno = $accountno
EOT
# print $updquery;
# $dbh->do(<<EOT);
# INSERT INTO accountoffsets
# (borrowernumber, accountno, offsetaccount,
# offsetamount)
# VALUES ($bornumber, $accountno, $nextaccntno, $newamtos)
# EOT
# create new line
my $payment=0-$amount;
@ -286,7 +274,7 @@ sub getnextacctno {
=cut
#'
# FIXME - I don't understand what this function does.
# FIXME - I don't know whether used
sub fixaccounts {
my ($borrowernumber,$accountno,$amount)=@_;
my $dbh = C4::Context->dbh;
@ -317,34 +305,26 @@ sub returnlost{
borrowernumber=? and itemnumber=? and returndate is null");
$sth->execute($borrnum,$itemnum);
$sth->finish;
my @datearr = localtime(time);
my $date = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
my $bor="$borrower->{'firstname'} $borrower->{'surname'} $borrower->{'cardnumber'}";
$sth=$dbh->prepare("Update items set paidfor=? where itemnumber=?");
$sth->execute("Paid for by $bor $date",$itemnum);
$sth->finish;
}
=item manualinvoice
&manualinvoice($borrowernumber, $itemnumber, $description, $type,
&manualinvoice($borrowernumber, $description, $type,
$amount, $user);
C<$borrowernumber> is the patron's borrower number.
C<$description> is a description of the transaction.
C<$type> may be one of C<CS>, C<CB>, C<CW>, C<CF>, C<CL>, C<N>, C<L>,
or C<REF>.
C<$itemnumber> is the item involved, if pertinent; otherwise, it
should be the empty string.
=cut
#'
# FIXME - Okay, so what does this function do, really?
sub manualinvoice{
my ($bornum,$itemnum,$desc,$type,$amount,$user)=@_;
my ($bornum,$desc,$type,$amount,$user)=@_;
my $dbh = C4::Context->dbh;
my $insert;
$itemnum=~ s/ //g;
my %env;
my $accountno=getnextacctno('',$bornum,$dbh);
my $amountleft=$amount;
@ -359,67 +339,42 @@ sub manualinvoice{
}
if ($type eq 'REF'){
$desc="Cash refund";
$amountleft=refund('',$bornum,$amount);
}
if ($itemnum ne ''){
$desc.=" ".$itemnum;
my $sth=$dbh->prepare("INSERT INTO accountlines
(borrowernumber, accountno, date, amount, description, accounttype, amountoutstanding, itemnumber)
VALUES (?, ?, now(), ?,?, ?,?,?)");
$sth->execute($bornum, $accountno, $amount, $desc, $type, $amountleft, $itemnum);
} else {
$desc=$dbh->quote($desc);
$amountleft=refund('',$bornum,$amount);
my $sth=$dbh->prepare("INSERT INTO accountlines
(borrowernumber, accountno, date, amount, description, accounttype, amountoutstanding)
VALUES (?, ?, now(), ?, ?, ?, ?)");
$sth->execute($bornum, $accountno, $amount, $desc, $type, $amountleft);
}
}
sub manualcredit{
my ($bornum,$itemnum,$desc,$type,$amount,$user,$oldaccount)=@_;
my ($bornum,$accountid,$desc,$type,$amount,$user,$oldaccount)=@_;
my $dbh = C4::Context->dbh;
my $insert;
$itemnum=~ s/ //g;
my $accountno=getnextacctno('',$bornum,$dbh);
# my $amountleft=$amount;
my $amountleft;
my $noerror;
if ($type eq 'CN' || $type eq 'CA' || $type eq 'CR'
|| $type eq 'CF' || $type eq 'CL' || $type eq 'CM'){
my $amount2=$amount*-1; # FIXME - $amount2 = -$amount
( $amountleft, $noerror,$oldaccount)=fixcredit($dbh,$bornum,$amount2,$itemnum,$type,$user);
my $amount2=$amount*-1;
( $amountleft, $noerror,$oldaccount)=fixcredit($dbh,$bornum,$amount2,$accountid,$type,$user);
}
if ($noerror>0){
if ($type eq 'CN'){
$desc.="Card fee credited by:".$user;
}
if ($type eq 'CM'){
$desc.="Other fees credited by:".$user;
}
if ($type eq 'CR'){
$desc.="Resrvation fee credited by:".$user;
}
if ($type eq 'CA'){
$desc.="Managenent fee credited by:".$user;
}
if ($type eq 'CL' && $desc eq ''){
$desc="Lost Item credited by:".$user;
}
if ($itemnum ne ''){
$desc.=" Credited for overdue item:".$itemnum. " by:".$user;
my $sth=$dbh->prepare("INSERT INTO accountlines
(borrowernumber, accountno, date, amount, description, accounttype, amountoutstanding, itemnumber,offset)
VALUES (?, ?, now(), ?,?, ?,?,?,?)");
$sth->execute($bornum, $accountno, $amount, $desc, $type, $amountleft, $itemnum,$oldaccount);
} else {
my $sth=$dbh->prepare("INSERT INTO accountlines
## find the accountline desc
my $sth2=$dbh->prepare("select description from accountlines where accountid=?");
$sth2->execute($accountid);
my $desc2=$sth2->fetchrow;
$desc.=" Credited for ".$desc2." by ".$user;
$sth2->finish;
my $sth=$dbh->prepare("INSERT INTO accountlines
(borrowernumber, accountno, date, amount, description, accounttype, amountoutstanding,offset)
VALUES (?, ?, now(), ?, ?, ?, ?,?)");
$sth->execute($bornum, $accountno, $amount, $desc, $type, $amountleft,$oldaccount);
}
return ("0");
} else {
return("1");
@ -428,36 +383,14 @@ return ("0");
# fixcredit
sub fixcredit{
#here we update both the accountoffsets and the account lines
my ($dbh,$bornumber,$data,$itemnumber,$type,$user)=@_;
my ($dbh,$bornumber,$data,$accountid,$type,$user)=@_;
my $newamtos = 0;
my $accdata = "";
my $amountleft = $data;
my $env;
my $query="Select * from accountlines where (borrowernumber=?
and amountoutstanding > 0)";
my $exectype;
if ($type eq 'CL'){
$query.=" and (accounttype = 'L' or accounttype = 'Rep')";
} elsif ($type eq 'CF'){
$query.=" and ( itemnumber= ? and (accounttype = 'FU' or accounttype='F') )";
$exectype=1;
} elsif ($type eq 'CN'){
$query.=" and ( accounttype = 'N' )";
} elsif ($type eq 'CR'){
$query.=" and ( itemnumber= ? and ( accounttype='Res' or accounttype='Rent'))";
$exectype=1;
}elsif ($type eq 'CM'){
$query.=" and ( accounttype = 'M' )";
}elsif ($type eq 'CA'){
$query.=" and ( accounttype = 'A' )";
}
# print $query;
my $sth=$dbh->prepare($query);
if ($exectype && $itemnumber ne ''){
$sth->execute($bornumber,$itemnumber);
}else{
$sth->execute($bornumber);
}
my $query="Select * from accountlines where accountid=? and amountoutstanding > 0";
my $sth=$dbh->prepare($query);
$sth->execute($accountid);
$accdata=$sth->fetchrow_hashref;
$sth->finish;
@ -469,13 +402,12 @@ if ($accdata){
$newamtos = $accdata->{'amountoutstanding'} - $amountleft;
$amountleft = 0;
}
my $thisacct = $accdata->{accountno};
my $thisacct = $accdata->{accountid};
my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
where (borrowernumber = ?) and (accountno=?)");
$usth->execute($newamtos,$bornumber,$thisacct);
where accountid=?");
$usth->execute($newamtos,$thisacct);
$usth->finish;
# begin transaction
# get lines with outstanding amounts to offset
my $sth = $dbh->prepare("select * from accountlines
@ -485,29 +417,30 @@ if ($accdata){
# print $query;
# offset transactions
while (($accdata=$sth->fetchrow_hashref) and ($amountleft>0)){
if ($accdata->{'amountoutstanding'} < $amountleft) {
$newamtos = 0;
$amountleft -= $accdata->{'amountoutstanding'};
} else {
$newamtos = $accdata->{'amountoutstanding'} - $amountleft;
if ($accdata->{'amountoutstanding'} < $amountleft) {
$newamtos = 0;
$amountleft -= $accdata->{'amountoutstanding'};
} else {
$newamtos = $accdata->{'amountoutstanding'} - $amountleft;
$amountleft = 0;
}
my $thisacct = $accdata->{accountno};
}
my $thisacct = $accdata->{accountid};
my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
where (borrowernumber = ?) and (accountno=?)");
$usth->execute($newamtos,$bornumber,$thisacct);
where accountid=?");
$usth->execute($newamtos,$thisacct);
$usth->finish;
}
}## while account
$sth->finish;
$amountleft*=-1;
return($amountleft,1,$accdata->{'accountno'});
}else{
return("",0)
return("",0);
}
}
# FIXME - Figure out what this function does, and write it down.
#
sub refund{
#here we update both the accountoffsets and the account lines
my ($env,$bornumber,$data)=@_;
@ -534,15 +467,15 @@ sub refund{
$amountleft = 0;
}
# print $amountleft;
my $thisacct = $accdata->{accountno};
my $thisacct = $accdata->{accountid};
my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
where (borrowernumber = ?) and (accountno=?)");
$usth->execute($newamtos,$bornumber,$thisacct);
where accountid=?");
$usth->execute($newamtos,$thisacct);
$usth->finish;
}
$sth->finish;
return($amountleft);
return($amountleft*-1);
}
#Funtion to manage the daily account#

28
C4/AuthoritiesMarc.pm

@ -121,7 +121,7 @@ my $counter = $offset;
$length=10 unless $length;
my @oAuth;
my $i;
$oAuth[0]=C4::Context->Zconn("authorityserver",1,1);
$oAuth[0]=C4::Context->Zconnauth("authorityserver");
my ($mainentry)=MARCfind_attr_from_kohafield("mainentry");
my ($allentry)=MARCfind_attr_from_kohafield("allentry");
@ -316,15 +316,23 @@ sub AUTHaddauthority {
$sth->execute;
($authid)=$sth->fetchrow;
$authid=$authid+1;
}
##Modified record may also come here use REPLACE -- bulk import comes here
XML_writeline($record,"authid",$authid,"authorities");
XML_writeline($record,"authtypecode",$authtypecode,"authorities");
my $xml=XML_hash2xml($record);
my $sth=$dbh->prepare("REPLACE auth_header set marcxml=?, authid=?,authtypecode=?,datecreated=now()");
$sth->execute($xml,$authid,$authtypecode);
XML_writeline($record,"authid",$authid,"authorities");
XML_writeline($record,"authtypecode",$authtypecode,"authorities");
my $xml=XML_hash2xml($record);
$dbh->do("lock tables auth_header WRITE");
$sth=$dbh->prepare("insert into auth_header (authid,datecreated,authtypecode,marcxml) values (?,now(),?,?)");
$sth->execute($authid,$authtypecode,$xml);
$sth->finish;
}else
##Modified record may also come here use UPDATE -- bulk import comes here
XML_writeline($record,"authid",$authid,"authorities");
XML_writeline($record,"authtypecode",$authtypecode,"authorities");
my $xml=XML_hash2xml($record);
my $sth=$dbh->prepare("UPDATE auth_header set marcxml=?,authtypecode=? where authid=?");
$sth->execute($xml,$authtypecode,$authid);
$sth->finish;
}
ZEBRAop($dbh,$authid,'specialUpdate',"authorityserver");
## If the record is linked to another update the linked authorities with new authid
my @linkids=XML_readline_asarray($record,"linkid","authorities");
@ -738,7 +746,7 @@ $oConnection[0]->destroy();
if ($update==1){
my $biblionumber=XML_readline_onerecord($xmlhash,"biblionumber","biblios");
my $frameworkcode=MARCfind_frameworkcode($dbh,$biblionumber);
ModBiblio($dbh,$biblionumber,$xmlhash,$frameworkcode) ;
NEWmodbiblio($dbh,$biblionumber,$xmlhash,$frameworkcode) ;
}
}#foreach $xmlhash

13
C4/Biblio.pm

@ -436,7 +436,7 @@ if ($related_record eq "biblios" || $related_record eq "" || !$related_record){
}
}else{
my $sth2=$dbh->prepare("SELECT marctokoha from koha_attr where recordtype like 'biblios' and tagfield is not null" );
my $sth2=$dbh->prepare("SELECT kohafield from koha_attr where recordtype like 'biblios' and tagfield is not null" );
$sth2->execute();
my $field;
while ($field=$sth2->fetchrow) {
@ -479,7 +479,7 @@ my $itemresult;
push @items, $itemresult;
}
}else{
my $sth2=$dbh->prepare("SELECT marctokoha from koha_attr where recordtype like 'holdings' and tagfield is not null" );
my $sth2=$dbh->prepare("SELECT kohafield from koha_attr where recordtype like 'holdings' and tagfield is not null" );
foreach my $holding (@$holdings){
$sth2->execute();
my $field;
@ -510,7 +510,7 @@ sub XMLmarc2koha_onerecord {
$result->{$field}=$val if $val;
}
}else{
my $sth2=$dbh->prepare("SELECT marctokoha from koha_attr where recordtype like ? and tagfield is not null" );
my $sth2=$dbh->prepare("SELECT kohafield from koha_attr where recordtype like ? and tagfield is not null" );
$sth2->execute($related_record);
my $field;
while ($field=$sth2->fetchrow) {
@ -572,7 +572,7 @@ my ($titletag,$titlesubf)=MARCfind_marc_from_kohafield("title","biblios");
my $xml="<record><leader> naa a22 7ar4500</leader><controlfield tag='xxx'></controlfield><datafield ind1='' ind2='' tag='$titletag'></datafield></record>";
## Now build XML
my $record = XML_xml2hash($xml);
my $sth2=$dbh->prepare("SELECT marctokoha from koha_attr where tagfield is not null and recordtype=?");
my $sth2=$dbh->prepare("SELECT kohafield from koha_attr where tagfield is not null and recordtype=?");
$sth2->execute($recordtype);
my $field;
while (($field)=$sth2->fetchrow) {
@ -913,7 +913,6 @@ NEWmoditem ( $dbh, $xmlhash, $biblionumber, $itemnumber);
##Add biblionumber to $record
$xmlhash=XML_writeline($xmlhash,"biblionumber",$biblionumber,"holdings");
# MARCkoha2marcOnefield($record,"biblionumber",$biblionumber,"holdings");
my $sth=$dbh->prepare("select notforloan from itemtypes where itemtype='$itemtype'");
$sth->execute();
my $notforloan=$sth->fetchrow;
@ -1381,7 +1380,7 @@ sub getitemtypes {
sub getkohafields{
#returns MySQL like fieldnames to emulate searches on sql like fieldnames
my $type=@_;
my $type=shift;
## Either opac or intranet to select appropriate fields
## Assumes intranet
$type="intra" unless $type;
@ -1390,7 +1389,7 @@ my $dbh = C4::Context->dbh;
my $i=0;
my @results;
$type=$type."show";
my $sth=$dbh->prepare("SELECT * FROM koha_attr where $type=1 order by liblibrarian");
my $sth=$dbh->prepare("SELECT * FROM koha_attr where $type=1 order by label");
$sth->execute();
while (my $data=$sth->fetchrow_hashref){
$results[$i]=$data;

6
C4/Circulation/Circ2.pm

@ -85,8 +85,8 @@ Also deals with stocktaking.
&fixdate
&itemissues
&patronflags
get_current_return_date_of
get_transfert_infos
&get_current_return_date_of
&get_transfert_infos
&checktransferts
&GetReservesForBranch
&GetReservesToBranch
@ -1730,7 +1730,7 @@ sub renewstatus {
my $renewokay; ##
# Look in the issues table for this item, lent to this borrower,
# and not yet returned.
my $borrower=getpatroninformation($dbh,$bornum,undef);
my $borrower=C4::Members::getpatroninformation($dbh,$bornum,undef);
if (C4::Context->preference("LibraryName") eq "NEU Grand Library"){
## faculty members and privileged get renewal whatever the case may be
if ($borrower->{'categorycode'} eq 'F' ||$borrower->{'categorycode'} eq 'P'){

14
C4/Circulation/Fines.pm

@ -171,19 +171,19 @@ sub CalcFine {
# the first thing the patron gets is a second notice, but that's a
# week after the server crash, so people may not connect the two
# events.
if ($difference >= $data->{'firstremind'}){
if ($difference > $data->{'firstremind'}){
# Yes. Set the fine as listed.
$amount=$data->{'fine'}* $difference;
$printout="First Notice";
}
# Is it time to send out a second reminder?
# my $second=$data->{'firstremind'}+$data->{'chargeperiod'};
# if ($difference == $second){
my $second=$data->{'firstremind'}+$data->{'chargeperiod'};
if ($difference == $second){
# # Yes. The fine is double.
# $amount=$data->{'fine'}*2;
# $printout="Second Notice";
# }
$printout="Second Notice";
}
# Is it time to send the account to a collection agency?
# FIXME - At least, I *think* that's what this code is doing.
@ -252,8 +252,8 @@ sub UpdateFine {
my $out=$data->{'amountoutstanding'}+$diff;
my $sth2=$dbh->prepare("update accountlines set date=now(), amount=?,
amountoutstanding=?,accounttype='FU' where
accountno=?");
$sth2->execute($amount,$out,$data->{'accountno'});
accountid=?");
$sth2->execute($amount,$out,$data->{'accountid'});
$sth2->finish;
} else {
print "no update needed $data->{'amount'} \n";

15
C4/Context.pm

@ -434,9 +434,9 @@ my $Zconn;
my ($tcp,$host,$port)=split /:/,$context->{"listen"}->{$server}->{"content"};
my $o = new ZOOM::Options();
$o->option(async => 1);
$o->option(preferredRecordSyntax => $syntax); ## Authorities use marc while biblioserver is xml
$o->option(preferredRecordSyntax => $syntax); ## in case we use MARC
$o->option(databaseName=>$context->{"config"}->{$server});
#$o->option(proxy=>$context->{"config"}->{"proxy"});## if proxyserver provided will route searches to proxy
my $o2= new ZOOM::Options();
$Zconn=create ZOOM::Connection($o);
@ -635,7 +635,7 @@ sub _new_marcfromkohafield
{
my $dbh = C4::Context->dbh;
my $marcfromkohafield;
my $sth = $dbh->prepare("select marctokoha,tagfield,tagsubfield,recordtype from koha_attr where tagfield is not null ");
my $sth = $dbh->prepare("select kohafield,tagfield,tagsubfield,recordtype from koha_attr where tagfield is not null ");
$sth->execute;
while (my ($kohafield,$tagfield,$tagsubfield,$recordtype) = $sth->fetchrow) {
my $retval = {};
@ -652,11 +652,11 @@ sub _new_attrfromkohafield
{
my $dbh = C4::Context->dbh;
my $attrfromkohafield;
my $sth2 = $dbh->prepare("select marctokoha,attr from koha_attr" );
my $sth2 = $dbh->prepare("select kohafield,attr,extraattr from koha_attr" );
$sth2->execute;
while (my ($marctokoha,$attr) = $sth2->fetchrow) {
while (my ($kohafield,$attr,$extra) = $sth2->fetchrow) {
my $retval = {};
$attrfromkohafield->{$marctokoha} = $attr;
$attrfromkohafield->{$kohafield} = "\@attr 1=".$attr." ".$extra;
}
return $attrfromkohafield;
}
@ -832,6 +832,9 @@ Andrew Arensburger <arensb at ooblick dot com>
=cut
# $Log$
# Revision 1.47 2006/09/27 19:53:52 tgarip1957
# Finalizing main components. All koha modules are now working with the new XML API
#
# Revision 1.46 2006/09/06 16:21:03 tgarip1957
# Clean up before final commits
#

76
C4/Koha.pm

@ -56,7 +56,7 @@ Koha.pm provides many functions for Koha scripts.
&getframeworks &getframeworkinfo
&getauthtypes &getauthtype
&getallthemes &getalllanguages
&getallbranches &getletters
&GetallBranches &getletters
&getbranchname
getnbpages
getitemtypeimagedir
@ -67,6 +67,8 @@ Koha.pm provides many functions for Koha scripts.
get_branchinfos_of
get_notforloan_label_of
get_infos_of
&getFacets
$DEBUG);
use vars qw();
@ -173,61 +175,26 @@ sub getbranchname {
=head2 getallbranches
$branches = &getallbranches();
@branches = &GetallBranches();
returns informations about ALL branches.
Create a branch selector with the following code
IndependantBranches Insensitive...
=head3 in PERL SCRIPT
my $branches = getallbranches;
my @branchloop;
foreach my $thisbranch (keys %$branches) {
my $selected = 1 if $thisbranch eq $branch;
my %row =(value => $thisbranch,
selected => $selected,
branchname => $branches->{$thisbranch}->{'branchname'},
);
push @branchloop, \%row;
}
=head3 in TEMPLATE
<select name="branch">
<option value="">Default</option>
<!-- TMPL_LOOP name="branchloop" -->
<option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="branchname" --></option>
<!-- /TMPL_LOOP -->
</select>
=cut
sub getallbranches {
# returns a reference to a hash of references to ALL branches...
my %branches;
sub GetallBranches {
# returns an array to ALL branches...
my @branches;
my $dbh = C4::Context->dbh;
my $sth;
$sth = $dbh->prepare("Select * from branches order by branchname");
$sth->execute;
while (my $branch=$sth->fetchrow_hashref) {
my $nsth = $dbh->prepare("select categorycode from branchrelations where branchcode = ?");
$nsth->execute($branch->{'branchcode'});
while (my ($cat) = $nsth->fetchrow_array) {
# FIXME - This seems wrong. It ought to be
# $branch->{categorycodes}{$cat} = 1;
# otherwise, there's a namespace collision if there's a
# category with the same name as a field in the 'branches'
# table (i.e., don't create a category called "issuing").
# In addition, the current structure doesn't really allow
# you to list the categories that a branch belongs to:
# you'd have to list keys %$branch, and remove those keys
# that aren't fields in the "branches" table.
$branch->{$cat} = 1;
}
$branches{$branch->{'branchcode'}}=$branch;
push @branches,$branch;
}
return (\%branches);
return (@branches);
}
=head2 getletters
@ -945,6 +912,31 @@ sub get_infos_of {
return \%infos_of;
}
sub getFacets {
###Subfields is an array as well although MARC21 has them all in "a" in case UNIMARC has differing subfields
my $dbh=C4::Context->dbh;
my @facets;
my $sth=$dbh->prepare("SELECT facets_label,attr FROM koha_attr where (facets_label<>'' ) group by facets_label");
my $sth2=$dbh->prepare("SELECT * FROM koha_attr where facets_label=?");
$sth->execute();
while (my ($label,$attr)=$sth->fetchrow){
$sth2->execute($label);
my (@tags,@subfield);
while (my $data=$sth2->fetchrow_hashref){
push @tags,$data->{tagfield} ;
push @subfield,$data->{tagsubfield} ;
}
my $facet = {
link_value =>"kohafield=$attr",
label_value =>$label,
tags => \@tags,
subfield =>\@subfield,
} ;
push @facets,$facet;
}
return \@facets;
}
1;
__END__

225
C4/Search.pm

@ -22,7 +22,9 @@ use C4::Context;
use C4::Reserves2;
use C4::Biblio;
use Date::Calc;
use ZOOM;
use Encode;
# FIXME - C4::Search uses C4::Reserves2, which uses C4::Search.
# So Perl complains that all of the functions here get redefined.
use C4::Date;
@ -60,11 +62,11 @@ ZEBRA databases.
@EXPORT = qw(
&barcodes &ItemInfo &itemcount
&getcoverPhoto &add_query_line
&FindDuplicate &ZEBRAsearch_kohafields &sqlsearch &cataloguing_search
&FindDuplicate &ZEBRAsearch_kohafields &convertPQF &sqlsearch &cataloguing_search
&getMARCnotes &getMARCsubjects &getMARCurls &parsefields);
# make all your functions, whether exported or not;
=item
=head1
ZEBRAsearchkohafields is the underlying API for searching zebra for KOHA internal use
its kept similar to earlier version Koha Marc searches. instead of passing marc tags to the routine
you pass named kohafields
@ -72,7 +74,7 @@ So you give an array of @kohafieldnames,@values, what relation they have @relati
you receive an array of XML records.
The routine also has a flag $fordisplay and if it is set to 1 it will return the @results as an array of Perl hashes so that your previous
search results templates do actually work.
However more advanced search frontends will be available and this routine can serve as the connecting API for circulation and serials management
This routine will also take CCL,CQL or PQF queries and pass them straight to the server
See sub FindDuplicates for an example;
=cut
@ -80,17 +82,17 @@ See sub FindDuplicates for an example;
sub ZEBRAsearch_kohafields{
my ($kohafield,$value, $relation,$sort, $and_or, $fordisplay,$reorder,$startfrom,$number_of_results,$searchfrom)=@_;
my ($kohafield,$value, $relation,$sort, $and_or, $fordisplay,$reorder,$startfrom,$number_of_results,$searchfrom,$searchtype)=@_;
return (0,undef) unless (@$value[0]);
my $server="biblioserver";
my @results;
my $attr;
my $query;
my $i;
unless($searchtype){
for ( $i=0; $i<=$#{$value}; $i++){
last if (@$value[$i] eq "");
next if (@$value[$i] eq "");
my $keyattr=MARCfind_attr_from_kohafield(@$kohafield[$i]) if (@$kohafield[$i]);
if (!$keyattr){$keyattr=" \@attr 1=any";}
@ -100,39 +102,42 @@ my $i;
for (my $z= 0;$z<=$#{$and_or};$z++){
$query=@$and_or[$z]." ".$query if (@$value[$z+1] ne "");
}
}
#warn $query;
my @oConnection;
($oConnection[0])=C4::Context->Zconn($server);
if ($reorder){
my (@sortpart)=split /,/,$reorder;
if (@sortpart<2){
push @sortpart,1; ##
}
my ($sortattr)=MARCfind_attr_from_kohafield($sortpart[0]);
my @sortfield=split /@/,$sortattr; ## incase our $sortattr contains type modifiers
$query.=" \@attr 7=".$sortpart[1]." \@".$sortfield[1]." 0";##
$query= "\@or ".$query;
my @sortpart;
if ($reorder ){
(@sortpart)=split /,/,$reorder;
}elsif ($sort){
my (@sortpart)=split /,/,$sort;
(@sortpart)=split /,/,$sort;
}
if (@sortpart){
##sortpart is expected to contain the form "title i<" notation or "title,1" both mean the same thing
if (@sortpart<2){
push @sortpart,1; ## Ascending by default
push @sortpart," "; ##In case multisort variable is coming as a single query
}
if ($sortpart[1]==2){
$sortpart[1]=">i"; ##Descending
}elsif ($sortpart[1]==1){
$sortpart[1]="<i"; ##Ascending
}
my ($sortattr)=MARCfind_attr_from_kohafield($sortpart[0]);
my @sortfield=split /@/,$sortattr; ## incase our $sortattr contains type modifiers
$query.=" \@attr 7=".$sortpart[1]." \@".$sortfield[1]." 0";## fix to accept secondary sort as well
$query= "\@or ".$query;
}else{
unless($query=~/4=109/){ ###ranked sort not valid for numeric fields
##Use Ranked sort
$query="\@attr 2=102 ".$query;
}
}
#warn $query;
if ($searchtype){
$query=convertPQF($searchtype,$oConnection[0],$value);
}else{
$query=new ZOOM::Query::PQF($query);
}
goto EXITING unless $query;## erronous query coming in
$query->sortby($sortpart[0]." ".$sortpart[1]) if @sortpart;
my $oResult;
my $tried=0;
@ -140,7 +145,7 @@ my $tried=0;
my $numresults;
retry:
$oResult= $oConnection[0]->search_pqf($query);
$oResult= $oConnection[0]->search($query);
my $i;
my $event;
while (($i = ZOOM::event(\@oConnection)) != 0) {
@ -170,27 +175,57 @@ my $dbh=C4::Context->dbh;
$ri=$startfrom if $startfrom;
for ( $ri; $ri<$numresults ; $ri++){
my $xmlrecord=$oResult->record($ri)->raw();
$xmlrecord=Encode::decode("utf8",$xmlrecord);
$xmlrecord=XML_xml2hash($xmlrecord);
$z++;
push @results,$xmlrecord;
last if ($number_of_results && $z>=$number_of_results);
}## for #numresults
if ($fordisplay){
my (@parsed)=parsefields($dbh,$searchfrom,@results);
return ($numresults,@parsed) ;
my ($facets,@parsed)=parsefields($dbh,$searchfrom,@results);
return ($numresults,$facets,@parsed) ;
}
}# if numresults
EXITING:
$oResult->destroy();
$oConnection[0]->destroy();
return ($numresults,@results) ;
#return (0,undef);
}
sub convertPQF{
# Convert CCL, CQF or PQF to ZEBRA RPN queries,trap errors
my ($search_type,$zconn,$query)=@_;
my $pqf_query;
if ($search_type eq "pqf"){
eval{
$pqf_query=new ZOOM::Query::PQF(@$query[0]);
};
}elsif ($search_type eq "ccl"){
my $cclfile=C4::Context->config("ccl2rpn");
$zconn->option(cclfile=>$cclfile);## CCL conversion file path
eval{
$pqf_query=new ZOOM::Query::CCL2RPN(@$query[0],$zconn);
};
}elsif ($search_type eq "cql"){
eval{
$pqf_query=new ZOOM::Query::CQL(@$query[0]);
};
}
if ($@){
$pqf_query=0;
}
return $pqf_query;
}
=item add_bold_fields
After a search the searched keyword is <b>boldened</b> in the displayed search results if it exists in the title or author
It is now depreceated
@ -201,11 +236,9 @@ sub add_html_bold_fields {
my $new_key;
$new_key = 'bold_' . $key;
$data->{$new_key} = $data->{$key};
$data->{$new_key} = $data->{$key};
my $key1;
$key1 = $key;
@ -508,23 +541,27 @@ sub getMARCnotes {
my ($dbh, $record, $marcflavour) = @_;
my ($mintag, $maxtag);
if ($marcflavour eq "MARC21") {
if (uc($marcflavour) eq uc"MARC21" || uc($marcflavour) eq "USMARC") {
$mintag = "500";
$maxtag = "599";
} else { # assume unimarc if not marc21
$mintag = "300";
$maxtag = "399";
}
my @marcnotes;
my @marcnotes=();
foreach my $field ($mintag..$maxtag) {
my @value=XML_readline_asarray($record,"","",$field,"");
push @marcnotes, \@value;
my %line;
my @values=XML_readline_asarray($record,"","",$field,"");
foreach my $value (@values){
$line{MARCNOTE}=$value if $value;
push @marcnotes,\%line if $line{MARCNOTE};
}
}
my $marcnotesarray=\@marcnotes;
return $marcnotesarray;
return $marcnotesarray;
} # end getMARCnotes
@ -532,7 +569,7 @@ sub getMARCsubjects {
my ($dbh, $record, $marcflavour) = @_;
my ($mintag, $maxtag);
if ($marcflavour eq "MARC21") {
if (uc($marcflavour) eq uc"MARC21" || uc($marcflavour) eq "USMARC") {
$mintag = "600";
$maxtag = "699";
} else { # assume unimarc if not marc21
@ -561,7 +598,7 @@ sub getMARCurls {
### This code is wrong only works with MARC21
my ($dbh, $record, $marcflavour) = @_;
my ($mintag, $maxtag);
if ($marcflavour eq "MARC21") {
if (uc($marcflavour) eq uc"MARC21" || uc($marcflavour) eq "USMARC") {
$mintag = "856";
$maxtag = "856";
} else { # assume unimarc if not marc21
@ -575,7 +612,7 @@ sub getMARCurls {
my $marcurl;
my $value;
foreach my $field ($mintag..$maxtag) {
my @value =XML_readline_asarray($record,"","",$field,"a");
my @value =XML_readline_asarray($record,"","",$field,"u");
foreach my $url (@value){
if ( $value ne $url) {
$marcurl = {MARCURL => $url,};
@ -623,8 +660,16 @@ my $shelfstatus = $dbh->prepare("select authorised_value from holdings_subfield_
}
}
my $even=1;
### FACETED RESULTS
my $facets_counter = ();
my $facets_info = ();
my @facets_loop; # stores the ref to array of hashes for template
foreach my $xml(@marcrecords){
#my $xml=XML_xml2hash($xmlrecord);
if (C4::Context->preference('useFacets')){
($facets_counter,$facets_info)=FillFacets($xml,$facets_counter,$facets_info);
}
my @kohafields; ## just name those necessary for the result page
push @kohafields, "biblionumber","title","author","publishercode","classification","itemtype","copyrightdate", "holdingbranch","date_due","location","shelf","itemcallnumber","notforloan","itemlost","wthdrawn";
my ($oldbiblio,@itemrecords) = XMLmarc2koha($dbh,$xml,"",@kohafields);
@ -713,9 +758,95 @@ my $norequests = 1;
push @results,$oldbiblio;
}## For each record received
return(@results);
@facets_loop=BuildFacets($facets_counter,$facets_info,%branches);
return(@facets_loop,@results);
}
sub FillFacets{
my ($facet_record,$facets_counter,$facets_info)=@_;
my $facets = C4::Koha::getFacets();
for (my $k=0; $k<@$facets;$k++) {
my $tags=@$facets->[$k]->{tags};
my $subfields=@$facets->[$k]->{subfield};
my @fields;
for (my $i=0; $i<@$tags;$i++) {
my $type="biblios";
$type="holdings" if @$facets->[$k]->{'link_value'} =~/branch/; ## if using other facets from items add them here
if ($type eq "holdings"){
###Read each item record
my $holdings=$facet_record->{holdings}->[0]->{record};
foreach my $holding(@$holdings){
my $data=XML_readline($holding,"","holdings",@$tags[$i],@$subfields[$i]);
$facets_counter->{ @$facets->[$k]->{'link_value'} }->{ $data }++ if $data;
}
}else{
my $data=XML_readline($facet_record,"","biblios",@$tags[$i],@$subfields[$i]);
$facets_counter->{ @$facets->[$k]->{'link_value'} }->{ $data }++ if $data;
}
}
$facets_info->{ @$facets->[$k]->{'link_value'} }->{ 'label_value' } = @$facets->[$k]->{'label_value'};
$facets_info->{ @$facets->[$k]->{'link_value'} }->{ 'expanded' } = @$facets->[$k]->{'expanded'};
}
return ($facets_counter,$facets_info);
}
sub BuildFacets {
my ($facets_counter, $facets_info,%branches) = @_;
my @facets_loop; # stores the ref to array of hashes for template
# BUILD FACETS
foreach my $link_value ( sort { $facets_counter->{$b} <=> $facets_counter->{$a} } keys %$facets_counter) {
my $expandable;
my $number_of_facets;
my @this_facets_array;
foreach my $one_facet ( sort { $facets_counter->{ $link_value }->{$b} <=> $facets_counter->{ $link_value }->{$a} } keys %{$facets_counter->{$link_value}} ) {
$number_of_facets++;
if (($number_of_facets < 11) || ($facets_info->{ $link_value }->{ 'expanded'})) {
# sanitize the link value ), ( will cause errors with CCL
my $facet_link_value = $one_facet;
$facet_link_value =~ s/(\(|\))/ /g;
# fix the length that will display in the label
my $facet_label_value = $one_facet;
$facet_label_value = substr($one_facet,0,20)."..." unless length($facet_label_value)<=20;
# well, if it's a branch, label by the name, not the code
if ($link_value =~/branch/) {
$facet_label_value = $branches{$one_facet};
}
# but we're down with the whole label being in the link's title
my $facet_title_value = $one_facet;
push @this_facets_array ,
( { facet_count => $facets_counter->{ $link_value }->{ $one_facet },
facet_label_value => $facet_label_value,
facet_title_value => $facet_title_value,
facet_link_value => $facet_link_value,
type_link_value => $link_value,
},
);
}## if $number_of_facets
}##for $one_facet
unless ($facets_info->{ $link_value }->{ 'expanded'}) {
$expandable=1 if ($number_of_facets > 10);
}
push @facets_loop,(
{ type_link_value => $link_value,
type_id => $link_value."_id",
type_label => $facets_info->{ $link_value }->{ 'label_value' },
facets => \@this_facets_array,
expandable => $expandable,
expand => $link_value,
},
);
}
return \@facets_loop;
}
sub getcoverPhoto {
## return the address of a cover image if defined otherwise the amazon cover images
my $record =shift ;

Loading…
Cancel
Save